;;;; macros which use GET-SETF-EXPANSION in their macroexpander code,
;;;; and hence need special treatment. Currently (19990806) this
-;;;; special treatment involves bare calls to SB!XC:DEFMACRO, and so
-;;;; this code can't appear in the build sequence until after
-;;;; SB!XC:DEFMACRO has been defined, and so this stuff is separated
-;;;; out of the main compiler/macros.lisp file (which has to appear
-;;;; earlier).
+;;;; special treatment involves bare calls to SB!XC:DEFMACRO or
+;;;; DEFMACRO-MUNDANELY and so this code can't appear in the build
+;;;; sequence until after xc DEFMACRO machinery has been set up, and
+;;;; so this stuff is separated out of the main compiler/macros.lisp
+;;;; file (which has to appear earlier).
;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
(in-package "SB!C")
-;;; Def-Boolean-Attribute Name Attribute-Name*
-;;;
-;;; Define a new class of Boolean attributes, with the attributes
-;;; having the specified ATTRIBUTE-NAMES. NAME is the name of the
-;;; class, which is used to generate some macros to manipulate sets of
-;;; the attributes:
-;;;
-;;; NAME-attributep attributes attribute-name*
-;;; Return true if any of the named attributes are present, false
-;;; otherwise. When set with SETF, updates the place Attributes
-;;; setting or clearing the specified attributes.
-;;;
-;;; NAME-attributes attribute-name*
-;;; Return a set of the named attributes.
-#+sb-xc-host
-(sb!xc:defmacro def-boolean-attribute (name &rest attribute-names)
- (let ((translations-name (symbolicate "*" name "-ATTRIBUTE-TRANSLATIONS*"))
- (test-name (symbolicate name "-ATTRIBUTEP")))
- (collect ((alist))
- (do ((mask 1 (ash mask 1))
- (names attribute-names (cdr names)))
- ((null names))
- (alist (cons (car names) mask)))
-
- `(progn
-
- (eval-when (:compile-toplevel :load-toplevel :execute)
- (defparameter ,translations-name ',(alist)))
-
- (defmacro ,test-name (attributes &rest attribute-names)
- "Automagically generated Boolean attribute test function. See
- DEF-BOOLEAN-ATTRIBUTE."
- `(logtest ,(compute-attribute-mask attribute-names
- ,translations-name)
- (the attributes ,attributes)))
-
- (define-setf-expander ,test-name (place &rest attributes
- &environment env)
- "Automagically generated Boolean attribute setter. See
- DEF-BOOLEAN-ATTRIBUTE."
- (boolean-attribute-setter--target place
- attributes
- env
- (compute-attribute-mask
- attributes
- ,translations-name
- )
- ',test-name))
-
- (defmacro ,(symbolicate name "-ATTRIBUTES") (&rest attribute-names)
- "Automagically generated Boolean attribute creation function. See
- DEF-BOOLEAN-ATTRIBUTE."
- (compute-attribute-mask attribute-names ,translations-name))))))
-
-;;; a helper function for the cross-compilation target Lisp code which
-;;; DEF-BOOLEAN-ATTRIBUTE expands into
-;;;
-;;; KLUDGE: Eventually I'd like to rewrite the mainstream DEF-BOOLEAN-ATTRIBUTE
-;;; to use code like this, to factor out some shared functionality for clarity
-;;; and for economy. But the motivation for splitting out this code here is
-;;; much weirder. In the current version of the code, the cross-compiler calls
-;;; UNCROSS on each top level form before processing it. Ordinarily, UNCROSS
-;;; isn't called on macro expansions, but since DEF-BOOLEAN-ATTRIBUTE expands
-;;; into a PROGN, the cross-compiler does end up calling UNCROSS on (the
-;;; components of) its macroexpansion, since they're separate top level forms.
-;;; In the classic CMU CL macroexpansion, the call to GET-SETF-EXPANSION is in
-;;; the macroexpansion, and even when I translate it to
-;;; SB!XC:GET-SETF-MACROEXPANSION so that it will work on target code, my
-;;; damned, damned UNCROSS kludge unconverts it before processing it. Moving
-;;; this shared logic (which includes the troublesome
-;;; SB!XC:GET-SETF-EXPANSION code) out of the macroexpansion and into this
-;;; helper function works around this problem. -- WHN 19990812
-(defun boolean-attribute-setter--target (place attributes env mask test-name)
- (multiple-value-bind (temps values stores set get)
- (sb!xc:get-setf-expansion place env)
- (when (cdr stores)
- (error "multiple store variables for ~S" place))
- (let ((newval (gensym))
- (n-place (gensym)))
- (values `(,@temps ,n-place)
- `(,@values ,get)
- `(,newval)
- `(let ((,(first stores)
- (if ,newval
- (logior ,n-place ,mask)
- (logand ,n-place ,(lognot mask)))))
- ,set
- ,newval)
- `(,test-name ,n-place ,@attributes)))))
-
#+sb-xc-host
(sb!xc:defmacro deletef-in (next place item &environment env)
(multiple-value-bind (temps vals stores store access)
(setf (,next ,(first stores)) ,access)
,store
(values))))
+
+;;; the target-code case of setting boolean attributes
+#+sb-xc-host
+(defmacro-mundanely !def-boolean-attribute-setter (test-name
+ translations-name
+ &rest attribute-names)
+ (guts-of-!def-boolean-attribute-setter test-name
+ translations-name
+ attribute-names
+ 'sb!xc:get-setf-expansion))
projects / sbcl.git / blobdiff