1 ;;;; macros which use GET-SETF-EXPANSION in their macroexpander code,
2 ;;;; and hence need special treatment. Currently (19990806) this
3 ;;;; special treatment involves bare calls to SB!XC:DEFMACRO, and so
4 ;;;; this code can't appear in the build sequence until after
5 ;;;; SB!XC:DEFMACRO has been defined, and so this stuff is separated
6 ;;;; out of the main compiler/macros.lisp file (which has to appear
9 ;;;; This software is part of the SBCL system. See the README file for
10 ;;;; more information.
12 ;;;; This software is derived from the CMU CL system, which was
13 ;;;; written at Carnegie Mellon University and released into the
14 ;;;; public domain. The software is in the public domain and is
15 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
16 ;;;; files for more information.
24 (sb!xc:defmacro def-boolean-attribute (name &rest attribute-names)
26 "Def-Boolean-Attribute Name Attribute-Name*
27 Define a new class of boolean attributes, with the attributes having the
28 specified Attribute-Names. Name is the name of the class, which is used to
29 generate some macros to manipulate sets of the attributes:
31 NAME-attributep attributes attribute-name*
32 Return true if one of the named attributes is present, false otherwise.
33 When set with SETF, updates the place Attributes setting or clearing the
36 NAME-attributes attribute-name*
37 Return a set of the named attributes."
39 (let ((const-name (symbolicate name "-ATTRIBUTE-TRANSLATIONS"))
40 (test-name (symbolicate name "-ATTRIBUTEP")))
42 (do ((mask 1 (ash mask 1))
43 (names attribute-names (cdr names)))
45 (alist (cons (car names) mask)))
48 (eval-when (:compile-toplevel :load-toplevel :execute)
49 (defconstant ,const-name ',(alist)))
51 (defmacro ,test-name (attributes &rest attribute-names)
52 "Automagically generated boolean attribute test function. See
53 Def-Boolean-Attribute."
54 `(logtest ,(compute-attribute-mask attribute-names ,const-name)
55 (the attributes ,attributes)))
57 (define-setf-expander ,test-name (place &rest attributes
59 "Automagically generated boolean attribute setter. See
60 Def-Boolean-Attribute."
61 (boolean-attribute-setter--target place
64 (compute-attribute-mask
70 (defmacro ,(symbolicate name "-ATTRIBUTES") (&rest attribute-names)
71 "Automagically generated boolean attribute creation function. See
72 Def-Boolean-Attribute."
73 (compute-attribute-mask attribute-names ,const-name))))))
75 ;;; a helper function for the cross-compilation target Lisp code which
76 ;;; DEF-BOOLEAN-ATTRIBUTE expands into
78 ;;; KLUDGE: Eventually I'd like to rewrite the mainstream DEF-BOOLEAN-ATTRIBUTE
79 ;;; to use code like this, to factor out some shared functionality for clarity
80 ;;; and for economy. But the motivation for splitting out this code here is
81 ;;; much weirder. In the current version of the code, the cross-compiler calls
82 ;;; UNCROSS on each top-level form before processing it. Ordinarily, UNCROSS
83 ;;; isn't called on macro expansions, but since DEF-BOOLEAN-ATTRIBUTE expands
84 ;;; into a PROGN, the cross-compiler does end up calling UNCROSS on (the
85 ;;; components of) its macroexpansion, since they're separate top-level forms.
86 ;;; In the classic CMU CL macroexpansion, the call to GET-SETF-EXPANSION is in
87 ;;; the macroexpansion, and even when I translate it to
88 ;;; SB!XC:GET-SETF-MACROEXPANSION so that it will work on target code, my
89 ;;; damned, damned UNCROSS kludge unconverts it before processing it. Moving
90 ;;; this shared logic (which includes the troublesome
91 ;;; SB!XC:GET-SETF-EXPANSION code) out of the macroexpansion and into this
92 ;;; helper function works around this problem. -- WHN 19990812
93 (defun boolean-attribute-setter--target (place attributes env mask test-name)
94 (multiple-value-bind (temps values stores set get)
95 (sb!xc:get-setf-expansion place env)
97 (error "multiple store variables for ~S" place))
98 (let ((newval (gensym))
100 (values `(,@temps ,n-place)
103 `(let ((,(first stores)
105 (logior ,n-place ,mask)
106 (logand ,n-place ,(lognot mask)))))
109 `(,test-name ,n-place ,@attributes)))))
112 (sb!xc:defmacro deletef-in (next place item &environment env)
113 (multiple-value-bind (temps vals stores store access)
114 (sb!xc:get-setf-expansion place env)
116 (error "multiple store variables for ~S" place))
117 (let ((n-item (gensym))
121 `(let* (,@(mapcar #'list temps vals)
124 (if (eq ,n-place ,n-item)
125 (let ((,(first stores) (,next ,n-place)))
127 (do ((,n-prev ,n-place ,n-current)
128 (,n-current (,next ,n-place)
130 ((eq ,n-current ,n-item)
131 (setf (,next ,n-prev)
132 (,next ,n-current)))))
136 (sb!xc:defmacro push-in (next item place &environment env)
138 "Push Item onto a list linked by the accessor function Next that is stored in
140 (multiple-value-bind (temps vals stores store access)
141 (sb!xc:get-setf-expansion place env)
143 (error "multiple store variables for ~S" place))
144 `(let (,@(mapcar #'list temps vals)
145 (,(first stores) ,item))
146 (setf (,next ,(first stores)) ,access)