X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fmacros.lisp;h=559889eb78b974863c266a780097b92effa42286;hb=b5703d98da9ebfd688c87e14862ab4e26dc94d14;hp=c07cc9ea7b1a0e9dcaee6660b5fab5c9bc848bcc;hpb=95a6db7329b91dd90d165dd4057b9b5098d34aa2;p=sbcl.git diff --git a/src/code/macros.lisp b/src/code/macros.lisp index c07cc9e..559889e 100644 --- a/src/code/macros.lisp +++ b/src/code/macros.lisp @@ -28,7 +28,7 @@ #!+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) @@ -56,71 +56,57 @@ ;;; ;;; 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 (defmacro-mundanely defconstant (name value &optional documentation) #!+sb-doc - "For defining global constants. The 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))) -;;; (to avoid "undefined function" warnings when cross-compiling) -(sb!xc:proclaim '(ftype function sb!c::%defconstant)) - ;;; the guts of DEFCONSTANT (defun sb!c::%defconstant (name value doc) - (/show "doing %DEFCONSTANT" name value doc) (unless (symbolp name) - (error "constant name not a symbol: ~S" name)) + (error "The constant name is not a symbol: ~S" name)) (about-to-modify 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 1: 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 + ;; 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." @@ -133,7 +119,64 @@ (t (warn "redefining ~(~A~) ~S to be a constant" kind name)))) (when doc (setf (fdocumentation name 'variable) doc)) - (setf (symbol-value name) value) + + ;; 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 + (/show (symbol-package name)) + ;; 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) (setf (info :variable :constant-value name) value) name) @@ -160,12 +203,6 @@ ,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) (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) @@ -180,19 +217,17 @@ (eval-when (:compile-toplevel :load-toplevel :execute) -;;; CASE-BODY (interface) -;;; -;;; CASE-BODY returns code for all the standard "case" macros. Name is -;;; the macro name, and keyform is the thing to case on. Multi-p +;;; CASE-BODY returns code for all the standard "case" macros. NAME is +;;; the macro name, and KEYFORM is the thing to case on. MULTI-P ;;; indicates whether a branch may fire off a list of keys; otherwise, ;;; a key that is a list is interpreted in some way as a single key. -;;; When multi-p, test is applied to the value of keyform and each key -;;; for a given branch; otherwise, test is applied to the value of -;;; keyform and the entire first element, instead of each part, of the -;;; case branch. When errorp, no t or otherwise branch is permitted, -;;; and an ERROR form is generated. When proceedp, it is an error to -;;; omit errorp, and the ERROR form generated is executed within a -;;; RESTART-CASE allowing keyform to be set and retested. +;;; When MULTI-P, TEST is applied to the value of KEYFORM and each key +;;; for a given branch; otherwise, TEST is applied to the value of +;;; KEYFORM and the entire first element, instead of each part, of the +;;; case branch. When ERRORP, no T or OTHERWISE branch is permitted, +;;; and an ERROR form is generated. When PROCEEDP, it is an error to +;;; omit ERRORP, and the ERROR form generated is executed within a +;;; RESTART-CASE allowing KEYFORM to be set and retested. (defun case-body (name keyform cases multi-p test errorp proceedp needcasesp) (unless (or cases (not needcasesp)) (warn "no clauses in ~S" name)) @@ -200,105 +235,33 @@ (clauses ()) (keys ())) (dolist (case cases) - (cond ((atom case) - (error "~S -- Bad clause in ~S." case name)) - ((memq (car case) '(t otherwise)) - (if errorp - (error 'simple-program-error - :format-control "No default clause is allowed in ~S: ~S" - :format-arguments (list name case)) - (push `(t nil ,@(rest case)) clauses))) - ((and multi-p (listp (first case))) - (setf keys (append (first case) keys)) - (push `((or ,@(mapcar #'(lambda (key) + (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)) + (if errorp + (error 'simple-program-error + :format-control + "No default clause is allowed in ~S: ~S" + :format-arguments (list name case)) + (push `(t nil ,@forms) clauses))) + ((and multi-p (listp keyoid)) + (setf keys (append keyoid keys)) + (push `((or ,@(mapcar (lambda (key) `(,test ,keyform-value ',key)) - (first case))) - nil ,@(rest case)) - clauses)) - (t - (push (first case) keys) - (push `((,test ,keyform-value - ',(first case)) nil ,@(rest case)) clauses)))) + keyoid)) + nil + ,@forms) + clauses)) + (t + (push keyoid keys) + (push `((,test ,keyform-value ',keyoid) + nil + ,@forms) + clauses))))) (case-body-aux name keyform keyform-value clauses keys errorp proceedp `(,(if multi-p 'member 'or) ,@keys)))) - -;;; MNA: typecase-implicit-declarations patch - -;;; TYPECASE-BODY (interface) -;;; -;;; TYPECASE-BODY returns code for all the standard "typecase" macros. -;;; Name is the macro name, and keyform is the thing to case on. -;;; test is applied to the value of keyform and the entire first element, -;;; instead of each part, of the case branch. -;;; When errorp, no t or otherwise branch is permitted, -;;; and an ERROR form is generated. When proceedp, it is an error to -;;; omit errorp, and the ERROR form generated is executed within a -;;; RESTART-CASE allowing keyform to be set and retested. -(defun typecase-body (name keyform cases test errorp proceedp needcasesp) - (unless (or cases (not needcasesp)) - (warn "no clauses in ~S" name)) - (let* ((keyform-symbol-p (symbolp keyform)) - (keyform-value (unless keyform-symbol-p - (gensym))) - (clauses ()) - (keys ())) - (dolist (case cases) - (cond ((atom case) - (error "~S -- Bad clause in ~S." case name)) - ((memq (car case) '(t otherwise)) - (if errorp - (error 'simple-program-error - :format-control "No default clause is allowed in ~S: ~S" - :format-arguments (list name case)) - (push `(t nil ,@(rest case)) clauses))) - (t - (push (first case) keys) - (push (if keyform-symbol-p - `((,test ,keyform ',(first case)) nil - (locally - ;; this will cause a compiler-warning ... disabled - ;; for now. - ;; (declare (type ,(first case) ,keyform)) - ,@(rest case))) - `((,test ,keyform-value ',(first case)) nil - ,@(rest case))) - clauses)))) - (if keyform-symbol-p - (typecase-symbol-body-aux name keyform clauses keys errorp proceedp - (cons 'or keys)) - (case-body-aux name keyform keyform-value clauses keys errorp proceedp - (cons 'or keys))))) - -;;; TYPECASE-SYMBOL-BODY-AUX provides the expansion once CASE-BODY has groveled -;;; all the cases, iff keyform is a symbol. -(defun typecase-symbol-body-aux (name keyform clauses keys - errorp proceedp expected-type) - (if proceedp - (let ((block (gensym)) - (again (gensym))) - `(block ,block - (tagbody - ,again - (return-from - ,block - (cond ,@(nreverse clauses) - (t - (setf ,keyform - (case-body-error - ',name ',keyform ,keyform - ',expected-type ',keys))) - (go ,again)))))) - `(progn - (cond - ,@(nreverse clauses) - ,@(if errorp - `((t (error 'sb!conditions::case-failure - :name ',name - :datum ,keyform - :expected-type ',expected-type - :possibilities ',keys)))))))) - ;;; CASE-BODY-AUX provides the expansion once CASE-BODY has groveled ;;; all the cases. Note: it is not necessary that the resulting code ;;; signal case-failure conditions, but that's what KMP's prototype @@ -333,7 +296,7 @@ (cond ,@(nreverse clauses) ,@(if errorp - `((t (error 'sb!conditions::case-failure + `((t (error 'case-failure :name ',name :datum ,keyform-value :expected-type ',expected-type @@ -367,21 +330,21 @@ "TYPECASE Keyform {(Type Form*)}* Evaluates the Forms in the first clause for which TYPEP of Keyform and Type is true." - (typecase-body 'typecase keyform cases 'typep nil nil nil)) + (case-body 'typecase keyform cases nil 'typep nil nil nil)) (defmacro-mundanely ctypecase (keyform &body cases) #!+sb-doc "CTYPECASE Keyform {(Type Form*)}* Evaluates the Forms in the first clause for which TYPEP of Keyform and Type is true. If no form is satisfied then a correctable error is signalled." - (typecase-body 'ctypecase keyform cases 'typep t t t)) + (case-body 'ctypecase keyform cases nil 'typep t t t)) (defmacro-mundanely etypecase (keyform &body cases) #!+sb-doc "ETYPECASE Keyform {(Type Form*)}* Evaluates the Forms in the first clause for which TYPEP of Keyform and Type is true. If no form is satisfied then an error is signalled." - (typecase-body 'etypecase keyform cases 'typep t nil t)) + (case-body 'etypecase keyform cases nil 'typep t nil t)) ;;;; WITH-FOO i/o-related macros