/[cmucl]/src/code/setf-funs.lisp
ViewVC logotype

Contents of /src/code/setf-funs.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.5.2.1 - (show annotations)
Sun Jul 19 01:06:12 1998 UTC (15 years, 9 months ago) by dtc
Branch: RELENG_18
CVS Tags: RELEASE_18d, RELEASE_18b, RELEASE_18c
Changes since 1.5: +2 -2 lines
Update from the current main branch.
1 ;;; -*- Package: Kernel -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written as part of the CMU Common Lisp project at
5 ;;; Carnegie Mellon University, and has been placed in the public domain.
6 ;;;
7 (ext:file-comment
8 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/setf-funs.lisp,v 1.5.2.1 1998/07/19 01:06:12 dtc Exp $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;; Stuff to automatically generate SETF functions for all the standard
13 ;;; functions that are currently implemented with setf macros.
14 ;;;
15 (in-package "KERNEL")
16
17 (eval-when (compile eval)
18
19 (defun compute-one-setter (name type)
20 (let* ((args (second type))
21 (res (type-specifier
22 (single-value-type
23 (values-specifier-type (third type)))))
24 (arglist (loop repeat (1+ (length args)) collect (gensym))))
25 (cond
26 ((null (intersection args lambda-list-keywords))
27 `(defun (setf ,name) ,arglist
28 (declare ,@(mapcar #'(lambda (arg type)
29 `(type ,type ,arg))
30 arglist
31 (cons res args)))
32 (setf (,name ,@(rest arglist)) ,(first arglist))))
33 (t
34 (warn "Hairy setf expander for function ~S." name)
35 nil))))
36
37
38 (defmacro define-setters (packages &rest ignore)
39 (collect ((res))
40 (dolist (pkg packages)
41 (do-external-symbols (sym pkg)
42 (when (and (fboundp sym)
43 (eq (info function kind sym) :function)
44 (or (info setf inverse sym)
45 (info setf expander sym))
46 (not (member sym ignore)))
47 (let ((type (type-specifier (info function type sym))))
48 (assert (consp type))
49 (res `(declaim (inline (setf ,sym))))
50 (res (compute-one-setter sym type))))))
51 `(progn ,@(res))))
52
53 ); eval-when (compile eval)
54
55 (define-setters ("LISP")
56 ;; Semantically silly...
57 getf apply ldb mask-field logbitp subseq values
58 ;; Have explicit redundant definitions...
59 setf bit sbit get aref gethash)

  ViewVC Help
Powered by ViewVC 1.1.5