X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fmacros.lisp;h=5ee726a7434809d448789f3a8f5fadc0c4ff2e35;hb=86210c4e406c1b2ff10cc3bac0e71435867db48b;hp=d94900ca494a0ff3d12d28fba57c6fe673ba7424;hpb=3bd7a97d1b11a2b0aee086ef211cae807f3dfc35;p=sbcl.git diff --git a/src/code/macros.lisp b/src/code/macros.lisp index d94900c..5ee726a 100644 --- a/src/code/macros.lisp +++ b/src/code/macros.lisp @@ -31,8 +31,8 @@ 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) @@ -80,11 +80,10 @@ (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." + "Define a global constant, saying 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 new value, the code is not portable (undefined behavior). The + third argument is an optional documentation string for the variable." `(eval-when (:compile-toplevel :load-toplevel :execute) (sb!c::%defconstant ',name ,value ',documentation))) @@ -92,7 +91,7 @@ (defun sb!c::%defconstant (name value doc) (unless (symbolp name) (error "The constant name is not a symbol: ~S" name)) - (about-to-modify name) + (about-to-modify-symbol-value name) (when (looks-like-name-of-special-var-p name) (style-warn "defining ~S as a constant, even though the name follows~@ the usual naming convention (names like *FOO*) for special variables" @@ -106,8 +105,8 @@ the usual naming convention (names like *FOO*) for special variables" ;; 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 + ;; something like the DEFCONSTANT-EQX macro used in SBCL (which + ;; is occasionally more appropriate). -- WHN 2001-12-21 (unless (eql value (info :variable :constant-value name)) (cerror "Go ahead and change the value." @@ -129,7 +128,6 @@ the usual naming convention (names like *FOO*) for special variables" ;; will be cross-compiled correctly. #-sb-xc-host (setf (symbol-value name) value) #+sb-xc-host (progn - (/show (symbol-package name)) ;; Redefining our cross-compilation host's CL symbols ;; would be poor form. ;; @@ -178,10 +176,36 @@ the usual naming convention (names like *FOO*) for special variables" ;; 2001-03-24 (eval `(defconstant ,name ',value)))) - (setf (info :variable :kind name) :constant) - (setf (info :variable :constant-value name) value) + (setf (info :variable :kind name) :constant + (info :variable :constant-value name) value) name) +;;;; DEFINE-SYMBOL-MACRO + +(defmacro-mundanely define-symbol-macro (name expansion) + `(eval-when (:compile-toplevel :load-toplevel :execute) + (sb!c::%define-symbol-macro ',name ',expansion))) + +(defun sb!c::%define-symbol-macro (name expansion) + (unless (symbolp name) + (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 @@ -200,16 +224,11 @@ the usual naming convention (names like *FOO*) for special variables" :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? - (aver (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) @@ -420,7 +439,7 @@ the usual naming convention (names like *FOO*) for special variables" (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) @@ -444,29 +463,23 @@ the usual naming convention (names like *FOO*) for special variables" #!+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))))