0.7.8.7:
[sbcl.git] / src / compiler / late-macros.lisp
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
7 ;;;; earlier).
8
9 ;;;; This software is part of the SBCL system. See the README file for
10 ;;;; more information.
11 ;;;;
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.
17
18 (in-package "SB!C")
19
20 ;;; Def-Boolean-Attribute Name Attribute-Name*
21 ;;;
22 ;;; Define a new class of Boolean attributes, with the attributes
23 ;;; having the specified ATTRIBUTE-NAMES. NAME is the name of the
24 ;;; class, which is used to generate some macros to manipulate sets of
25 ;;; the attributes:
26 ;;;
27 ;;;   NAME-attributep attributes attribute-name*
28 ;;;     Return true if any of the named attributes are present, false
29 ;;;     otherwise. When set with SETF, updates the place Attributes
30 ;;;     setting or clearing the specified attributes.
31 ;;;
32 ;;;   NAME-attributes attribute-name*
33 ;;;     Return a set of the named attributes.
34 #+sb-xc-host
35 (sb!xc:defmacro def-boolean-attribute (name &rest attribute-names)
36   (let ((translations-name (symbolicate "*" name "-ATTRIBUTE-TRANSLATIONS*"))
37         (test-name (symbolicate name "-ATTRIBUTEP")))
38     (collect ((alist))
39       (do ((mask 1 (ash mask 1))
40            (names attribute-names (cdr names)))
41           ((null names))
42         (alist (cons (car names) mask)))
43
44       `(progn
45
46          (eval-when (:compile-toplevel :load-toplevel :execute)
47            (defparameter ,translations-name ',(alist)))
48
49          (defmacro ,test-name (attributes &rest attribute-names)
50            "Automagically generated Boolean attribute test function. See
51             DEF-BOOLEAN-ATTRIBUTE."
52            `(logtest ,(compute-attribute-mask attribute-names
53                                               ,translations-name)
54                      (the attributes ,attributes)))
55
56          (define-setf-expander ,test-name (place &rest attributes
57                                                  &environment env)
58            "Automagically generated Boolean attribute setter. See
59             DEF-BOOLEAN-ATTRIBUTE."
60            (boolean-attribute-setter--target place
61                                              attributes
62                                              env
63                                              (compute-attribute-mask
64                                               attributes
65                                               ,translations-name
66                                               )
67                                              ',test-name))
68
69          (defmacro ,(symbolicate name "-ATTRIBUTES") (&rest attribute-names)
70            "Automagically generated Boolean attribute creation function. See
71             DEF-BOOLEAN-ATTRIBUTE."
72            (compute-attribute-mask attribute-names ,translations-name))))))
73
74 ;;; a helper function for the cross-compilation target Lisp code which
75 ;;; DEF-BOOLEAN-ATTRIBUTE expands into
76 ;;;
77 ;;; KLUDGE: Eventually I'd like to rewrite the mainstream DEF-BOOLEAN-ATTRIBUTE
78 ;;; to use code like this, to factor out some shared functionality for clarity
79 ;;; and for economy. But the motivation for splitting out this code here is
80 ;;; much weirder. In the current version of the code, the cross-compiler calls
81 ;;; UNCROSS on each top level form before processing it. Ordinarily, UNCROSS
82 ;;; isn't called on macro expansions, but since DEF-BOOLEAN-ATTRIBUTE expands
83 ;;; into a PROGN, the cross-compiler does end up calling UNCROSS on (the
84 ;;; components of) its macroexpansion, since they're separate top level forms.
85 ;;; In the classic CMU CL macroexpansion, the call to GET-SETF-EXPANSION is in
86 ;;; the macroexpansion, and even when I translate it to
87 ;;; SB!XC:GET-SETF-MACROEXPANSION so that it will work on target code, my
88 ;;; damned, damned UNCROSS kludge unconverts it before processing it. Moving
89 ;;; this shared logic (which includes the troublesome
90 ;;; SB!XC:GET-SETF-EXPANSION code) out of the macroexpansion and into this
91 ;;; helper function works around this problem. -- WHN 19990812
92 (defun boolean-attribute-setter--target (place attributes env mask test-name)
93   (multiple-value-bind (temps values stores set get)
94       (sb!xc:get-setf-expansion place env)
95     (when (cdr stores)
96       (error "multiple store variables for ~S" place))
97     (let ((newval (gensym))
98           (n-place (gensym)))
99       (values `(,@temps ,n-place)
100               `(,@values ,get)
101               `(,newval)
102               `(let ((,(first stores)
103                       (if ,newval
104                         (logior ,n-place ,mask)
105                         (logand ,n-place ,(lognot mask)))))
106                  ,set
107                  ,newval)
108               `(,test-name ,n-place ,@attributes)))))
109
110 #+sb-xc-host
111 (sb!xc:defmacro deletef-in (next place item &environment env)
112   (multiple-value-bind (temps vals stores store access)
113       (sb!xc:get-setf-expansion place env)
114     (when (cdr stores)
115       (error "multiple store variables for ~S" place))
116     (let ((n-item (gensym))
117           (n-place (gensym))
118           (n-current (gensym))
119           (n-prev (gensym)))
120       `(let* (,@(mapcar #'list temps vals)
121               (,n-place ,access)
122               (,n-item ,item))
123          (if (eq ,n-place ,n-item)
124              (let ((,(first stores) (,next ,n-place)))
125                ,store)
126              (do ((,n-prev ,n-place ,n-current)
127                   (,n-current (,next ,n-place)
128                               (,next ,n-current)))
129                  ((eq ,n-current ,n-item)
130                   (setf (,next ,n-prev)
131                         (,next ,n-current)))))
132          (values)))))
133
134 ;;; Push ITEM onto a list linked by the accessor function NEXT that is
135 ;;; stored in PLACE.
136 #+sb-xc-host
137 (sb!xc:defmacro push-in (next item place &environment env)
138   (multiple-value-bind (temps vals stores store access)
139       (sb!xc:get-setf-expansion place env)
140     (when (cdr stores)
141       (error "multiple store variables for ~S" place))
142     `(let (,@(mapcar #'list temps vals)
143            (,(first stores) ,item))
144        (setf (,next ,(first stores)) ,access)
145        ,store
146        (values))))