X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fmacros.lisp;h=2a7fb523bb19bb706e39b6b0f394172c1c78e69d;hb=4ff8421d6f4590024f82ea6f6851e25b4ca3df99;hp=89b35bbfa141199de7d78cb1f0bde64fc150219d;hpb=09957fcf57b49ed5ae5f05d62ad12d7ddbfd8e1d;p=sbcl.git diff --git a/src/compiler/macros.lisp b/src/compiler/macros.lisp index 89b35bb..2a7fb52 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.) @@ -149,7 +149,7 @@ ) ; EVAL-WHEN ;;; Define a new class of boolean attributes, with the attributes -;;; having the specified Attribute-Names. Name is the name of the +;;; 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: ;;; @@ -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)))) @@ -386,13 +395,10 @@ ;;; which means efficiency notes will be generated when this ;;; transform fails even if INHIBIT-WARNINGS=SPEED (but not if ;;; INHIBIT-WARNINGS>SPEED). -;;; :WHEN {:NATIVE | :BYTE | :BOTH} -;;; - Indicates whether this transform applies to native code, -;;; byte-code or both (default :native.) (defmacro deftransform (name (lambda-list &optional (arg-types '*) (result-type '*) &key result policy node defun-only - eval-name important (when :native)) + eval-name important) &body body-decls-doc) (when (and eval-name defun-only) (error "can't specify both DEFUN-ONLY and EVAL-NAME")) @@ -433,8 +439,7 @@ `'(function ,arg-types ,result-type)) (lambda ,@stuff) ,doc - ,(if important t nil) - ,when))))))) + ,(if important t nil)))))))) ;;;; DEFKNOWN and DEFOPTIMIZER @@ -451,66 +456,28 @@ ;;; Declare the function NAME to be a known function. We construct a ;;; 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. These attributes are -;;; meaningful here: -;;; -;;; CALL -;;; May call functions that are passed as arguments. In order -;;; to determine what other effects are present, we must find -;;; the effects of all arguments that may be functions. -;;; -;;; UNSAFE -;;; May incorporate arguments in the result or somehow pass -;;; them upward. -;;; -;;; UNWIND -;;; May fail to return during correct execution. Errors -;;; are O.K. -;;; -;;; ANY -;;; The (default) worst case. Includes all the other bad -;;; things, plus any other possible bad thing. -;;; -;;; FOLDABLE -;;; May be constant-folded. The function has no side effects, -;;; but may be affected by side effects on the arguments. E.g. -;;; SVREF, MAPC. -;;; -;;; FLUSHABLE -;;; May be eliminated if value is unused. The function has -;;; no side effects except possibly CONS. If a function is -;;; defined to signal errors, then it is not flushable even -;;; if it is movable or foldable. -;;; -;;; MOVABLE -;;; May be moved with impunity. Has no side effects except -;;; possibly CONS, and is affected only by its arguments. -;;; -;;; PREDICATE -;;; A true predicate likely to be open-coded. This is a -;;; hint to IR1 conversion that it should ensure calls always -;;; appear as an IF test. Not usually specified to DEFKNOWN, -;;; since this is implementation dependent, and is usually -;;; automatically set by the DEFINE-VOP :CONDITIONAL option. -;;; -;;; 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. +;;; of boolean attributes of the function. See their description 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. (defmacro defknown (name arg-types result-type &optional (attributes '(any)) &rest keys) (when (and (intersection attributes '(any call unwind)) (intersection attributes '(movable))) (error "function cannot have both good and bad attributes: ~S" attributes)) + (when (member 'any attributes) + (setf attributes (union '(call unsafe unwind) attributes))) + (when (member 'flushable attributes) + (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) - (ir1-attributes ,@(if (member 'any attributes) - (union '(call unsafe unwind) attributes) - attributes)) + (ir1-attributes ,@attributes) ,@keys)) ;;; Create a function which parses combination args according to WHAT @@ -547,8 +514,8 @@ ,(parse-deftransform lambda-list body n-args `(return-from ,name nil)))) ,@(when (consp what) - `((setf (,(symbolicate "FUNCTION-INFO-" (second what)) - (function-info-or-lose ',(first what))) + `((setf (,(symbolicate "FUN-INFO-" (second what)) + (fun-info-or-lose ',(first what))) #',name))))))) ;;;; IR groveling macros @@ -694,8 +661,8 @@ ;;; Bind the hashtables used for keeping track of global variables, ;;; functions, etc. Also establish condition handlers. (defmacro with-ir1-namespace (&body forms) - `(let ((*free-variables* (make-hash-table :test 'eq)) - (*free-functions* (make-hash-table :test 'equal)) + `(let ((*free-vars* (make-hash-table :test 'eq)) + (*free-funs* (make-hash-table :test 'equal)) (*constants* (make-hash-table :test 'equal)) (*source-paths* (make-hash-table :test 'eq))) (handler-bind ((compiler-error #'compiler-error-handler) @@ -708,11 +675,18 @@ ;;; :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) (values nil nil)))) + +;;; +(defmacro with-continuation-type-assertion ((cont ctype context) &body body) + `(let ((*lexenv* (ir1ize-the-or-values ,ctype ,cont *lexenv* ,context))) + ,@body)) ;;;; the EVENT statistics/trace utility @@ -782,8 +756,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. @@ -802,7 +776,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 @@ -837,10 +811,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 @@ -848,7 +822,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 @@ -861,16 +836,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 @@ -885,14 +861,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 ..)