X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fmacros.lisp;h=f14e8e28bc0481eba5c53aa2e53a1478f68535e8;hb=0f2ae6ebc3520494b665a9dbf32c36c671334d36;hp=5ee726a7434809d448789f3a8f5fadc0c4ff2e35;hpb=4d5c5d322dcca0753474496cde44a9dbfe627496;p=sbcl.git diff --git a/src/code/macros.lisp b/src/code/macros.lisp index 5ee726a..f14e8e2 100644 --- a/src/code/macros.lisp +++ b/src/code/macros.lisp @@ -76,110 +76,6 @@ (setf ,place (check-type-error ',place ,place-value ',type ,type-string))))) -;;;; DEFCONSTANT - -(defmacro-mundanely defconstant (name value &optional documentation) - #!+sb-doc - "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))) - -;;; the guts of DEFCONSTANT -(defun sb!c::%defconstant (name value doc) - (unless (symbolp name) - (error "The constant name is not a symbol: ~S" 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" - 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 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." - "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)) - - ;; We want to set the cross-compilation host's symbol value, not just - ;; the cross-compiler's (INFO :VARIABLE :CONSTANT-VALUE NAME), so - ;; that code like - ;; (defconstant max-entries 61) - ;; (deftype entry-index () `(mod ,max-entries)) - ;; will be cross-compiled correctly. - #-sb-xc-host (setf (symbol-value name) value) - #+sb-xc-host (progn - ;; Redefining our cross-compilation host's CL symbols - ;; would be poor form. - ;; - ;; FIXME: Having to check this and then not treat it - ;; as a fatal error seems like a symptom of things - ;; being pretty broken. It's also a problem in and of - ;; itself, since it makes it too easy for cases of - ;; using the cross-compilation host Lisp's CL - ;; constant values in the target Lisp to slip by. I - ;; got backed into this because the cross-compiler - ;; translates DEFCONSTANT SB!XC:FOO into DEFCONSTANT - ;; CL:FOO. It would be good to unscrew the - ;; cross-compilation package hacks so that that - ;; translation doesn't happen. Perhaps: - ;; * Replace SB-XC with SB-CL. SB-CL exports all the - ;; symbols which ANSI requires to be exported from CL. - ;; * Make a nickname SB!CL which behaves like SB!XC. - ;; * Go through the loaded-on-the-host code making - ;; every target definition be in SB-CL. E.g. - ;; DEFMACRO-MUNDANELY DEFCONSTANT becomes - ;; DEFMACRO-MUNDANELY SB!CL:DEFCONSTANT. - ;; * Make IN-TARGET-COMPILATION-MODE do - ;; UNUSE-PACKAGE CL and USE-PACKAGE SB-CL in each - ;; of the target packages (then undo it on exit). - ;; * Make the cross-compiler's implementation of - ;; EVAL-WHEN (:COMPILE-TOPLEVEL) do UNCROSS. - ;; (This may not require any change.) - ;; * Hack GENESIS as necessary so that it outputs - ;; SB-CL stuff as COMMON-LISP stuff. - ;; * Now the code here can assert that the symbol - ;; being defined isn't in the cross-compilation - ;; host's CL package. - (unless (eql (find-symbol (symbol-name name) :cl) name) - ;; KLUDGE: In the cross-compiler, we use the - ;; cross-compilation host's DEFCONSTANT macro - ;; instead of just (SETF SYMBOL-VALUE), in order to - ;; get whatever blessing the cross-compilation host - ;; may expect for a global (SETF SYMBOL-VALUE). - ;; (CMU CL, at least around 2.4.19, generated full - ;; WARNINGs for code -- e.g. DEFTYPE expanders -- - ;; which referred to symbols which had been set by - ;; (SETF SYMBOL-VALUE). I doubt such warnings are - ;; ANSI-compliant, but I'm not sure, so I've - ;; written this in a way that CMU CL will tolerate - ;; and which ought to work elsewhere too.) -- WHN - ;; 2001-03-24 - (eval `(defconstant ,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) @@ -208,15 +104,30 @@ the usual naming convention (names like *FOO*) for special variables" ;;;; 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")) + (when (and (symbolp name) (special-operator-p name)) + (error 'simple-program-error + :format-control "cannot define a compiler-macro for a special operator: ~S" + :format-arguments (list name))) (let ((whole (gensym "WHOLE-")) (environment (gensym "ENV-"))) (multiple-value-bind (body local-decs doc) @@ -225,19 +136,45 @@ the usual naming convention (names like *FOO*) for special variables" (let ((def `(lambda (,whole ,environment) ,@local-decs (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) - (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) - ;; FIXME: Add support for (SETF FDOCUMENTATION) when object is a list - ;; and type is COMPILER-MACRO. (Until then, we have to discard any - ;; compiler macro documentation for (SETF FOO).) - (unless (listp name) - (setf (fdocumentation name 'compiler-macro) doc)) - name) + ,body))) + (debug-name (debug-namify "DEFINE-COMPILER-MACRO ~S" name))) + `(eval-when (:compile-toplevel :load-toplevel :execute) + (sb!c::%define-compiler-macro ',name #',def ',lambda-list ,doc ,debug-name)))))) + +;;; FIXME: This will look remarkably similar to those who have already +;;; seen the code for %DEFMACRO in src/code/defmacro.lisp. Various +;;; bits of logic should be shared (notably arglist setting). +(macrolet + ((def (times set-p) + `(eval-when (,@times) + (defun sb!c::%define-compiler-macro + (name definition lambda-list doc debug-name) + ,@(unless set-p + '((declare (ignore lambda-list debug-name)))) + ;; FIXME: warn about incompatible lambda list with + ;; respect to parent function? + (setf (sb!xc:compiler-macro-function name) definition) + ;; FIXME: Add support for (SETF FDOCUMENTATION) when + ;; object is a list and type is COMPILER-MACRO. (Until + ;; then, we have to discard any compiler macro + ;; documentation for (SETF FOO).) + (unless (listp name) + (setf (fdocumentation name 'compiler-macro) doc)) + ,(when set-p + `(case (widetag-of definition) + (#.sb!vm:closure-header-widetag + (setf (%simple-fun-arglist (%closure-fun definition)) + lambda-list + (%simple-fun-name (%closure-fun definition)) + debug-name)) + ((#.sb!vm:simple-fun-header-widetag + #.sb!vm:closure-fun-header-widetag) + (setf (%simple-fun-arglist definition) lambda-list + (%simple-fun-name definition) debug-name)))) + name)))) + (progn + (def (:load-toplevel :execute) #-sb-xc-host t #+sb-xc-host nil) + (def (:compile-toplevel) nil))) ;;;; CASE, TYPECASE, and friends @@ -260,16 +197,22 @@ the usual naming convention (names like *FOO*) for special variables" (let ((keyform-value (gensym)) (clauses ()) (keys ())) - (dolist (case cases) + (do* ((cases cases (cdr cases)) + (case (car cases) (car cases))) + ((null cases) nil) (unless (list-of-length-at-least-p case 1) (error "~S -- bad clause in ~S" case name)) (destructuring-bind (keyoid &rest forms) case - (cond ((memq keyoid '(t otherwise)) + (cond ((and (memq keyoid '(t otherwise)) + (null (cdr cases))) (if errorp - (error 'simple-program-error - :format-control - "No default clause is allowed in ~S: ~S" - :format-arguments (list name case)) + (progn + (style-warn "~@" + 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))