X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Flate-macros.lisp;h=d7383304ee825e03b1b2a898d391f0469b15cfa4;hb=0f3a5f2e8886d18d0b4f6485c38a42be629422ae;hp=39b53c683909954f47100bb464e0990e5111ae68;hpb=34dd23563d2f5cf05c72b971da0d0b065a09bf2a;p=sbcl.git diff --git a/src/compiler/late-macros.lisp b/src/compiler/late-macros.lisp index 39b53c6..d738330 100644 --- a/src/compiler/late-macros.lisp +++ b/src/compiler/late-macros.lisp @@ -1,10 +1,10 @@ ;;;; 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. @@ -17,96 +17,6 @@ (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) @@ -114,22 +24,22 @@ (when (cdr stores) (error "multiple store variables for ~S" place)) (let ((n-item (gensym)) - (n-place (gensym)) - (n-current (gensym)) - (n-prev (gensym))) + (n-place (gensym)) + (n-current (gensym)) + (n-prev (gensym))) `(let* (,@(mapcar #'list temps vals) - (,n-place ,access) - (,n-item ,item)) - (if (eq ,n-place ,n-item) - (let ((,(first stores) (,next ,n-place))) - ,store) - (do ((,n-prev ,n-place ,n-current) - (,n-current (,next ,n-place) - (,next ,n-current))) - ((eq ,n-current ,n-item) - (setf (,next ,n-prev) - (,next ,n-current))))) - (values))))) + (,n-place ,access) + (,n-item ,item)) + (if (eq ,n-place ,n-item) + (let ((,(first stores) (,next ,n-place))) + ,store) + (do ((,n-prev ,n-place ,n-current) + (,n-current (,next ,n-place) + (,next ,n-current))) + ((eq ,n-current ,n-item) + (setf (,next ,n-prev) + (,next ,n-current))))) + (values))))) ;;; Push ITEM onto a list linked by the accessor function NEXT that is ;;; stored in PLACE. @@ -140,7 +50,17 @@ (when (cdr stores) (error "multiple store variables for ~S" place)) `(let (,@(mapcar #'list temps vals) - (,(first stores) ,item)) + (,(first stores) ,item)) (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))