X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fmacros.lisp;h=2574cacd4b64dbb437dd96c2f16684c600b6515a;hb=a260738d7a71680079d972b102b4e4db4e8dc3ae;hp=46865dd7ee5c2fa19f47135b5c3dba77322512f0;hpb=cfb9e3640e34706acdfccd26236024de259f3b4f;p=sbcl.git diff --git a/src/code/macros.lisp b/src/code/macros.lisp index 46865dd..2574cac 100644 --- a/src/code/macros.lisp +++ b/src/code/macros.lisp @@ -28,11 +28,11 @@ #!+sb-doc "Signals an error if the value of test-form is nil. Continuing from this error using the CONTINUE restart will allow the user to alter the value of - some locations known to SETF, starting over with test-form. Returns nil." + some locations known to SETF, starting over with test-form. Returns NIL." `(do () (,test-form) (assert-error ',test-form ',places ,datum ,@arguments) - ,@(mapcar #'(lambda (place) - `(setf ,place (assert-prompt ',place ,place))) + ,@(mapcar (lambda (place) + `(setf ,place (assert-prompt ',place ,place))) places))) (defun assert-prompt (name value) @@ -56,94 +56,74 @@ ;;; ;;; FIXME: In reality, this restart cruft is needed hardly anywhere in ;;; the system. Write NEED and NEED-TYPE to replace ASSERT and -;;; CHECK-TYPE inside the system. +;;; CHECK-TYPE inside the system. (CL:CHECK-TYPE must still be +;;; defined, since it's specified by ANSI and it is sometimes nice for +;;; whipping up little things. But as far as I can tell it's not +;;; usually very helpful deep inside the guts of a complex system like +;;; SBCL.) ;;; ;;; CHECK-TYPE-ERROR isn't defined until a later file because it uses ;;; the macro RESTART-CASE, which isn't defined until a later file. (defmacro-mundanely check-type (place type &optional type-string) #!+sb-doc - "Signals a restartable error of type TYPE-ERROR if the value of PLACE is + "Signal a restartable error of type TYPE-ERROR if the value of PLACE is not of the specified type. If an error is signalled and the restart is - used to return, the - return if the - STORE-VALUE is invoked. It will store into PLACE and start over." + used to return, this can only return if the STORE-VALUE restart is + invoked. In that case it will store into PLACE and start over." (let ((place-value (gensym))) - `(do ((,place-value ,place)) + `(do ((,place-value ,place ,place)) ((typep ,place-value ',type)) (setf ,place (check-type-error ',place ,place-value ',type ,type-string))))) - -#!+high-security-support -(defmacro-mundanely check-type-var (place type-var &optional type-string) - #!+sb-doc - "Signals an error of type TYPE-ERROR if the contents of PLACE are not of the - specified type to which the TYPE-VAR evaluates. If an error is signaled, - this can only return if STORE-VALUE is invoked. It will store into PLACE - and start over." - (let ((place-value (gensym)) - (type-value (gensym))) - `(do ((,place-value ,place) - (,type-value ,type-var)) - ((typep ,place-value ,type-value)) - (setf ,place - (check-type-error ',place ,place-value ,type-value ,type-string))))) -;;;; DEFCONSTANT +;;;; DEFINE-SYMBOL-MACRO -(defmacro-mundanely defconstant (name value &optional documentation) - #!+sb-doc - "For defining global constants. DEFCONSTANT says that the value is - constant and may be compiled into code. If the variable already has - a value, and this is not EQL to the init, the code is not portable - (undefined behavior). The third argument is an optional documentation - string for the variable." +(defmacro-mundanely define-symbol-macro (name expansion) `(eval-when (:compile-toplevel :load-toplevel :execute) - (sb!c::%defconstant ',name ,value ',documentation))) + (sb!c::%define-symbol-macro ',name ',expansion))) -;;; the guts of DEFCONSTANT -(defun sb!c::%defconstant (name value doc) +(defun sb!c::%define-symbol-macro (name expansion) (unless (symbolp name) - (error "constant name not a symbol: ~S" name)) - (about-to-modify name) - (let ((kind (info :variable :kind name))) - (case kind - (:constant - ;; Note: This behavior (discouraging any non-EQL modification) - ;; is unpopular, but it is specified by ANSI (i.e. ANSI says a - ;; non-EQL change has undefined consequences). If people really - ;; want bindings which are constant in some sense other than - ;; EQL, I suggest either just using DEFVAR (which is usually - ;; appropriate, despite the un-mnemonic name), or defining - ;; something like SB-INT:DEFCONSTANT-EQX (which is occasionally - ;; more appropriate). -- WHN 2000-11-03 - (unless (eql value - (info :variable :constant-value name)) - (cerror "Go ahead and change the value." - "The constant ~S is being redefined." - name))) - (:global - ;; (This is OK -- undefined variables are of this kind. So we - ;; don't warn or error or anything, just fall through.) - ) - (t (warn "redefining ~(~A~) ~S to be a constant" kind name)))) - (when doc - (setf (fdocumentation name 'variable) doc)) - (setf (symbol-value name) value) - (setf (info :variable :kind name) :constant) - (setf (info :variable :constant-value name) value) + (error 'simple-type-error :datum name :expected-type 'symbol + :format-control "Symbol macro name is not a symbol: ~S." + :format-arguments (list name))) + (ecase (info :variable :kind name) + ((:macro :global nil) + (setf (info :variable :kind name) :macro) + (setf (info :variable :macro-expansion name) expansion)) + (:special + (error 'simple-program-error + :format-control "Symbol macro name already declared special: ~S." + :format-arguments (list name))) + (:constant + (error 'simple-program-error + :format-control "Symbol macro name already declared constant: ~S." + :format-arguments (list name)))) name) + ;;;; DEFINE-COMPILER-MACRO -;;; FIXME: The logic here for handling compiler macros named (SETF -;;; FOO) was added after the fork from SBCL, is not well tested, and -;;; may conflict with subtleties of the ANSI standard. E.g. section -;;; "3.2.2.1 Compiler Macros" says that creating a lexical binding for -;;; a function name shadows a compiler macro, and it's not clear that -;;; that works with this version. It should be tested. (defmacro-mundanely define-compiler-macro (name lambda-list &body body) #!+sb-doc "Define a compiler-macro for NAME." + (legal-fun-name-or-type-error name) + (when (consp name) + ;; It's fairly clear that the user intends the compiler macro to + ;; expand when he does (SETF (FOO ...) X). And that's even a + ;; useful and reasonable thing to want. Unfortunately, + ;; (SETF (FOO ...) X) macroexpands into (FUNCALL (SETF FOO) X ...), + ;; and it's not at all clear that it's valid to expand a FUNCALL form, + ;; and the ANSI standard doesn't seem to say anything else which + ;; would justify us expanding the compiler macro the way the user + ;; wants. So instead we rely on 3.2.2.1.3 "When Compiler Macros Are + ;; Used" which says they never have to be used, so by ignoring such + ;; macros we're erring on the safe side. But any user who does + ;; (DEFINE-COMPILER-MACRO (SETF FOO) ...) could easily be surprised + ;; by this way of complying with a rather screwy aspect of the ANSI + ;; spec, so at least we can warn him... + (sb!c::compiler-style-warn + "defining compiler macro of (SETF ...), which will not be expanded")) (let ((whole (gensym "WHOLE-")) (environment (gensym "ENV-"))) (multiple-value-bind (body local-decs doc) @@ -151,16 +131,11 @@ :environment environment) (let ((def `(lambda (,whole ,environment) ,@local-decs - (block ,(function-name-block-name name) + (block ,(fun-name-block-name name) ,body)))) `(sb!c::%define-compiler-macro ',name #',def ',lambda-list ,doc))))) (defun sb!c::%define-compiler-macro (name definition lambda-list doc) - ;; FIXME: Why does this have to be an interpreted function? Shouldn't - ;; it get compiled? - (assert (sb!eval:interpreted-function-p definition)) - (setf (sb!eval:interpreted-function-name definition) - (format nil "DEFINE-COMPILER-MACRO ~S" name)) - (setf (sb!eval:interpreted-function-arglist definition) lambda-list) + (declare (ignore lambda-list)) (sb!c::%%define-compiler-macro name definition doc)) (defun sb!c::%%define-compiler-macro (name definition doc) (setf (sb!xc:compiler-macro-function name) definition) @@ -198,10 +173,13 @@ (destructuring-bind (keyoid &rest forms) case (cond ((memq keyoid '(t otherwise)) (if errorp - (error 'simple-program-error - :format-control - "No default clause is allowed in ~S: ~S" - :format-arguments (list name case)) + (progn + ;; FIXME: this message could probably do with + ;; some loving pretty-printer format controls. + (style-warn "Treating bare ~A in ~A as introducing a normal-clause, not an otherwise-clause" keyoid name) + (push keyoid keys) + (push `((,test ,keyform-value ',keyoid) nil ,@forms) + clauses)) (push `(t nil ,@forms) clauses))) ((and multi-p (listp keyoid)) (setf keys (append keyoid keys)) @@ -371,7 +349,7 @@ (defmacro-mundanely nth-value (n form) #!+sb-doc - "Evaluates FORM and returns the Nth value (zero based). This involves no + "Evaluate FORM and return the Nth value (zero based). This involves no consing when N is a trivial constant integer." (if (integerp n) (let ((dummy-list nil) @@ -395,29 +373,23 @@ #!+sb-doc "DECLAIM Declaration* Do a declaration or declarations for the global environment." - #-sb-xc-host `(eval-when (:compile-toplevel :load-toplevel :execute) - ,@(mapcar #'(lambda (x) - `(sb!xc:proclaim ',x)) - specs)) - ;; KLUDGE: The definition above doesn't work in the cross-compiler, - ;; because UNCROSS translates SB!XC:PROCLAIM into CL:PROCLAIM before - ;; the form gets executed. Instead, we have to explicitly do the - ;; proclamation at macroexpansion time. -- WHN ca. 19990810 - ;; - ;; FIXME: Maybe we don't need this special treatment any more now - ;; that we're using DEFMACRO-MUNDANELY instead of DEFMACRO? - #+sb-xc-host (progn - (mapcar #'sb!xc:proclaim specs) - `(progn - ,@(mapcar #'(lambda (x) - `(sb!xc:proclaim ',x)) - specs)))) + ,@(mapcar (lambda (spec) `(sb!xc:proclaim ',spec)) + specs))) -(defmacro-mundanely print-unreadable-object ((object stream - &key type identity) +(defmacro-mundanely print-unreadable-object ((object stream &key type identity) &body body) + "Output OBJECT to STREAM with \"#<\" prefix, \">\" suffix, optionally + with object-type prefix and object-identity suffix, and executing the + code in BODY to provide possible further output." `(%print-unreadable-object ,object ,stream ,type ,identity ,(if body - `#'(lambda () ,@body) + `(lambda () ,@body) nil))) + +(defmacro-mundanely ignore-errors (&rest forms) + #!+sb-doc + "Execute FORMS handling ERROR conditions, returning the result of the last + form, or (VALUES NIL the-ERROR-that-was-caught) if an ERROR was handled." + `(handler-case (progn ,@forms) + (error (condition) (values nil condition))))