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.
21 (sb!xc:defmacro def-boolean-attribute (name &rest attribute-names)
23 "Def-Boolean-Attribute Name Attribute-Name*
24 Define a new class of boolean attributes, with the attributes having the
25 specified Attribute-Names. Name is the name of the class, which is used to
26 generate some macros to manipulate sets of the attributes:
28 NAME-attributep attributes attribute-name*
29 Return true if one of the named attributes is present, false otherwise.
30 When set with SETF, updates the place Attributes setting or clearing the
33 NAME-attributes attribute-name*
34 Return a set of the named attributes."
36 (let ((const-name (symbolicate name "-ATTRIBUTE-TRANSLATIONS"))
37 (test-name (symbolicate name "-ATTRIBUTEP")))
39 (do ((mask 1 (ash mask 1))
40 (names attribute-names (cdr names)))
42 (alist (cons (car names) mask)))
45 (eval-when (:compile-toplevel :load-toplevel :execute)
46 (defconstant ,const-name ',(alist)))
48 (defmacro ,test-name (attributes &rest attribute-names)
49 "Automagically generated boolean attribute test function. See
50 Def-Boolean-Attribute."
51 `(logtest ,(compute-attribute-mask attribute-names ,const-name)
52 (the attributes ,attributes)))
54 (define-setf-expander ,test-name (place &rest attributes
56 "Automagically generated boolean attribute setter. See
57 Def-Boolean-Attribute."
58 (boolean-attribute-setter--target place
61 (compute-attribute-mask
67 (defmacro ,(symbolicate name "-ATTRIBUTES") (&rest attribute-names)
68 "Automagically generated boolean attribute creation function. See
69 Def-Boolean-Attribute."
70 (compute-attribute-mask attribute-names ,const-name))))))
72 ;;; a helper function for the cross-compilation target Lisp code which
73 ;;; DEF-BOOLEAN-ATTRIBUTE expands into
75 ;;; KLUDGE: Eventually I'd like to rewrite the mainstream DEF-BOOLEAN-ATTRIBUTE
76 ;;; to use code like this, to factor out some shared functionality for clarity
77 ;;; and for economy. But the motivation for splitting out this code here is
78 ;;; much weirder. In the current version of the code, the cross-compiler calls
79 ;;; UNCROSS on each top-level form before processing it. Ordinarily, UNCROSS
80 ;;; isn't called on macro expansions, but since DEF-BOOLEAN-ATTRIBUTE expands
81 ;;; into a PROGN, the cross-compiler does end up calling UNCROSS on (the
82 ;;; components of) its macroexpansion, since they're separate top-level forms.
83 ;;; In the classic CMU CL macroexpansion, the call to GET-SETF-EXPANSION is in
84 ;;; the macroexpansion, and even when I translate it to
85 ;;; SB!XC:GET-SETF-MACROEXPANSION so that it will work on target code, my
86 ;;; damned, damned UNCROSS kludge unconverts it before processing it. Moving
87 ;;; this shared logic (which includes the troublesome
88 ;;; SB!XC:GET-SETF-EXPANSION code) out of the macroexpansion and into this
89 ;;; helper function works around this problem. -- WHN 19990812
90 (defun boolean-attribute-setter--target (place attributes env mask test-name)
91 (multiple-value-bind (temps values stores set get)
92 (sb!xc:get-setf-expansion place env)
94 (error "multiple store variables for ~S" place))
95 (let ((newval (gensym))
97 (values `(,@temps ,n-place)
100 `(let ((,(first stores)
102 (logior ,n-place ,mask)
103 (logand ,n-place ,(lognot mask)))))
106 `(,test-name ,n-place ,@attributes)))))
109 (sb!xc:defmacro deletef-in (next place item &environment env)
110 (multiple-value-bind (temps vals stores store access)
111 (sb!xc:get-setf-expansion place env)
113 (error "multiple store variables for ~S" place))
114 (let ((n-item (gensym))
118 `(let* (,@(mapcar #'list temps vals)
121 (if (eq ,n-place ,n-item)
122 (let ((,(first stores) (,next ,n-place)))
124 (do ((,n-prev ,n-place ,n-current)
125 (,n-current (,next ,n-place)
127 ((eq ,n-current ,n-item)
128 (setf (,next ,n-prev)
129 (,next ,n-current)))))
133 (sb!xc:defmacro push-in (next item place &environment env)
135 "Push Item onto a list linked by the accessor function Next that is stored in
137 (multiple-value-bind (temps vals stores store access)
138 (sb!xc:get-setf-expansion place env)
140 (error "multiple store variables for ~S" place))
141 `(let (,@(mapcar #'list temps vals)
142 (,(first stores) ,item))
143 (setf (,next ,(first stores)) ,access)