X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fmacros.lisp;h=f6e4fb0b5f511f48ad4ad191da2b348e4a83ba0a;hb=98a76d4426660876dec6649b1e228d2e5b47f579;hp=197ffbed9235a0a3a50000cf40331716c37c1a37;hpb=b8fe7c0afeb9901091ce781ba351d0513f2ee86d;p=sbcl.git diff --git a/src/compiler/macros.lisp b/src/compiler/macros.lisp index 197ffbe..f6e4fb0 100644 --- a/src/compiler/macros.lisp +++ b/src/compiler/macros.lisp @@ -78,8 +78,8 @@ `((setf (symbol-function ',name) (lambda (&rest rest) (declare (ignore rest)) - (error "can't FUNCALL the SYMBOL-FUNCTION of ~ - special forms"))))))))) + (error 'special-form-function + :name ',name))))))))) ;;; (This is similar to DEF-IR1-TRANSLATOR, except that we pass if the ;;; syntax is invalid.) @@ -160,71 +160,80 @@ ;;; ;;; NAME-attributes attribute-name* ;;; Return a set of the named attributes. -;;; -;;; KLUDGE: This is expanded out twice, by cut-and-paste, in a -;;; (DEF!MACRO FOO (..) .. CL:GET-SETF-EXPANSION ..) -;;; #+SB-XC-HOST -;;; (SB!XC:DEFMACRO FOO (..) .. SB!XC:GET-SETF-EXPANSION ..) -;;; arrangement, in order to get it to work in cross-compilation. This -;;; duplication should be removed, perhaps by rewriting the macro in a -;;; more cross-compiler-friendly way, or perhaps just by using some -;;; (MACROLET ((FROB ..)) .. FROB .. FROB) form, but I don't want to -;;; do it now, because the system isn't running yet, so it'd be too -;;; hard to check that my changes were correct -- WHN 19990806 -(def!macro 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." - #-sb-xc-host (declare (type sb!c::lexenv env)) - ;; FIXME: It would be better if &ENVIRONMENT arguments - ;; were automatically declared to have type LEXENV by the - ;; hairy-argument-handling code. - (multiple-value-bind (temps values stores set get) - (get-setf-expansion place env) - (when (cdr stores) - (error "multiple store variables for ~S" place)) - (let ((newval (gensym)) - (n-place (gensym)) - (mask (compute-attribute-mask attributes - ,translations-name))) - (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))))) - - (defmacro ,(symbolicate name "-ATTRIBUTES") (&rest attribute-names) - "Automagically generated boolean attribute creation function. See - Def-Boolean-Attribute." - (compute-attribute-mask attribute-names ,translations-name)))))) -;;; #+SB-XC-HOST SB!XC:DEFMACRO version is in late-macros.lisp. -- WHN 19990806 +#+sb-xc-host +(progn + (def!macro !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 ,(symbolicate name "-ATTRIBUTES") (&rest attribute-names) + "Automagically generated boolean attribute creation function. + See !DEF-BOOLEAN-ATTRIBUTE." + (compute-attribute-mask attribute-names ,translations-name)) + (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))) + ;; This definition transforms strangely under UNCROSS, in a + ;; way that DEF!MACRO doesn't understand, so we delegate it + ;; to a submacro then define the submacro differently when + ;; building the xc and when building the target compiler. + (!def-boolean-attribute-setter ,test-name + ,translations-name + ,@attribute-names))))) + + ;; It seems to be difficult to express in DEF!MACRO machinery what + ;; to do with target-vs-host GET-SETF-EXPANSION in here, so we just + ;; hack it by hand, passing a different GET-SETF-EXPANSION-FUN-NAME + ;; in the host DEFMACRO and target DEFMACRO-MUNDANELY cases. + (defun guts-of-!def-boolean-attribute-setter (test-name + translations-name + attribute-names + get-setf-expansion-fun-name) + `(define-setf-expander ,test-name (place &rest attributes + &environment env) + "Automagically generated boolean attribute setter. See + !DEF-BOOLEAN-ATTRIBUTE." + #-sb-xc-host (declare (type sb!c::lexenv env)) + ;; FIXME: It would be better if &ENVIRONMENT arguments were + ;; automatically declared to have type LEXENV by the + ;; hairy-argument-handling code. + (multiple-value-bind (temps values stores set get) + (,get-setf-expansion-fun-name place env) + (when (cdr stores) + (error "multiple store variables for ~S" place)) + (let ((newval (gensym)) + (n-place (gensym)) + (mask (compute-attribute-mask attributes ,translations-name))) + (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)))))) + ;; We define the host version here, and the just-like-it-but-different + ;; target version later, after DEFMACRO-MUNDANELY has been defined. + (defmacro !def-boolean-attribute-setter (test-name + translations-name + &rest attribute-names) + (guts-of-!def-boolean-attribute-setter test-name + translations-name + attribute-names + 'get-setf-expansion))) ;;; And now for some gratuitous pseudo-abstraction... ;;; @@ -234,9 +243,9 @@ ;;; ATTRIBUTES-INTERSECTION ;;; Return the intersection of all the sets of boolean attributes which ;;; are its arguments. -;;; ATTRIBUTES= -;;; True if the attributes present in Attr1 are identical to -;;; those in Attr2. +;;; ATTRIBUTES +;;; True if the attributes present in ATTR1 are identical to +;;; those in ATTR2. (defmacro attributes-union (&rest attributes) `(the attributes (logior ,@(mapcar (lambda (x) `(the attributes ,x)) attributes)))) @@ -448,7 +457,7 @@ ;;; type specifier for the function by wrapping (FUNCTION ...) around ;;; the ARG-TYPES and RESULT-TYPE. ATTRIBUTES is an unevaluated list ;;; of boolean attributes of the function. See their description in -;;; (DEF-BOOLEAN-ATTRIBUTE IR1). NAME may also be a list of names, in +;;; (!DEF-BOOLEAN-ATTRIBUTE IR1). NAME may also be a list of names, in ;;; which case the same information is given to all the names. The ;;; keywords specify the initial values for various optimizers that ;;; the function might have. @@ -464,7 +473,7 @@ (pushnew 'unsafely-flushable attributes)) `(%defknown ',(if (and (consp name) - (not (eq (car name) 'setf))) + (not (legal-fun-name-p name))) name (list name)) '(function ,arg-types ,result-type) @@ -666,7 +675,9 @@ ;;; :TEST keyword may be used to determine the name equality ;;; predicate. (defmacro lexenv-find (name slot &key test) - (once-only ((n-res `(assoc ,name (,(symbolicate "LEXENV-" slot) *lexenv*) + (once-only ((n-res `(assoc ,name (,(let ((*package* (symbol-package 'lexenv-funs))) + (symbolicate "LEXENV-" slot)) + *lexenv*) :test ,(or test '#'eq)))) `(if ,n-res (values (cdr ,n-res) t) @@ -676,6 +687,19 @@ (defmacro with-continuation-type-assertion ((cont ctype context) &body body) `(let ((*lexenv* (ir1ize-the-or-values ,ctype ,cont *lexenv* ,context))) ,@body)) + +(defmacro with-component-last-block ((component block) &body body) + (let ((old-last-block (gensym "OLD-LAST-BLOCK"))) + (once-only ((component component) + (block block)) + `(let ((,old-last-block (component-last-block ,component))) + (unwind-protect + (progn (setf (component-last-block ,component) + ,block) + ,@body) + (setf (component-last-block ,component) + ,old-last-block)))))) + ;;;; the EVENT statistics/trace utility @@ -745,8 +769,8 @@ new-value)) (defsetf event-level %set-event-level) -;;; Define a new kind of event. Name is a symbol which names the event -;;; and Description is a string which describes the event. Level +;;; Define a new kind of event. NAME is a symbol which names the event +;;; and DESCRIPTION is a string which describes the event. Level ;;; (default 0) is the level of significance associated with this ;;; event; it is used to determine whether to print a Note when the ;;; event happens. @@ -765,7 +789,7 @@ (declaim (type unsigned-byte *event-note-threshold*)) (defvar *event-note-threshold* 1) -;;; Note that the event with the specified Name has happened. Node is +;;; Note that the event with the specified NAME has happened. NODE is ;;; evaluated to determine the node to which the event happened. (defmacro event (name &optional node) ;; Increment the counter and do any action. Mumble about the event if @@ -800,10 +824,10 @@ ;;;; functions on directly-linked lists (linked through specialized ;;;; NEXT operations) -#!-sb-fluid (declaim (inline find-in position-in map-in)) +#!-sb-fluid (declaim (inline find-in position-in)) -;;; Find Element in a null-terminated List linked by the accessor -;;; function Next. Key, Test and Test-Not are the same as for generic +;;; Find ELEMENT in a null-terminated LIST linked by the accessor +;;; function NEXT. KEY, TEST and TEST-NOT are the same as for generic ;;; sequence functions. (defun find-in (next element @@ -811,7 +835,8 @@ &key (key #'identity) (test #'eql test-p) - (test-not nil not-p)) + (test-not #'eql not-p)) + (declare (type function next key test test-not)) (when (and test-p not-p) (error "It's silly to supply both :TEST and :TEST-NOT arguments.")) (if not-p @@ -824,16 +849,17 @@ (when (funcall test (funcall key current) element) (return current))))) -;;; Return the position of Element (or NIL if absent) in a -;;; null-terminated List linked by the accessor function Next. Key, -;;; Test and Test-Not are the same as for generic sequence functions. +;;; Return the position of ELEMENT (or NIL if absent) in a +;;; null-terminated LIST linked by the accessor function NEXT. KEY, +;;; TEST and TEST-NOT are the same as for generic sequence functions. (defun position-in (next element list &key (key #'identity) (test #'eql test-p) - (test-not nil not-p)) + (test-not #'eql not-p)) + (declare (type function next key test test-not)) (when (and test-p not-p) (error "It's silly to supply both :TEST and :TEST-NOT arguments.")) (if not-p @@ -848,14 +874,6 @@ (when (funcall test (funcall key current) element) (return i))))) -;;; Map FUNCTION over the elements in a null-terminated LIST linked by the -;;; accessor function NEXT, returning an ordinary list of the results. -(defun map-in (next function list) - (collect ((res)) - (do ((current list (funcall next current))) - ((null current)) - (res (funcall function current))) - (res))) ;;; KLUDGE: This is expanded out twice, by cut-and-paste, in a ;;; (DEF!MACRO FOO (..) .. CL:GET-SETF-EXPANSION ..)