X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fmacros.lisp;h=2bf63a644c772ac68a31dab77d2cc4b0af9b2de1;hb=a1a2c079c7654defb618baad0dddcf0eaf2ce64f;hp=46865dd7ee5c2fa19f47135b5c3dba77322512f0;hpb=cfb9e3640e34706acdfccd26236024de259f3b4f;p=sbcl.git diff --git a/src/code/macros.lisp b/src/code/macros.lisp index 46865dd..2bf63a6 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,37 +56,25 @@ ;;; ;;; 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 @@ -103,7 +91,7 @@ ;;; the guts of DEFCONSTANT (defun sb!c::%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) (let ((kind (info :variable :kind name))) (case kind @@ -128,7 +116,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) @@ -157,7 +202,7 @@ (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)) + (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)