X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fmacros.lisp;h=d4731bb79d3b52d1c17cc1dd4021cba0107630ae;hb=c8af15e61b030c8d4b0e950bc9b7618530044618;hp=8f6d38654ef95f4931b5b55cb878f64bad9dcc3c;hpb=a530bbe337109d898d5b4a001fc8f1afa3b5dc39;p=sbcl.git diff --git a/src/code/macros.lisp b/src/code/macros.lisp index 8f6d386..d4731bb 100644 --- a/src/code/macros.lisp +++ b/src/code/macros.lisp @@ -10,9 +10,6 @@ ;;;; files for more information. (in-package "SB!IMPL") - -(file-comment - "$Header$") ;;;; ASSERT and CHECK-TYPE @@ -31,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) @@ -79,9 +76,9 @@ #!+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 + "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))) @@ -93,32 +90,47 @@ ;;;; DEFCONSTANT -(defmacro-mundanely defconstant (var val &optional doc) +(defmacro-mundanely defconstant (name value &optional documentation) #!+sb-doc - "For defining global constants at top level. 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 equal to the init, an error is signalled. The third - argument is an optional documentation string for the variable." - `(sb!c::%defconstant ',var ,val ',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." + `(eval-when (:compile-toplevel :load-toplevel :execute) + (sb!c::%defconstant ',name ,value ',documentation))) -;;; These are like the other %MUMBLEs except that we currently -;;; actually do something interesting at load time, namely checking -;;; whether the constant is being redefined. +;;; the guts of DEFCONSTANT (defun sb!c::%defconstant (name value doc) - (sb!c::%%defconstant name value doc)) -#+sb-xc-host (sb!xc:proclaim '(ftype function sb!c::%%defconstant)) ; to avoid - ; undefined function warnings -(defun sb!c::%%defconstant (name value doc) + (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)) - (when (boundp name) - (unless (equalp (symbol-value name) value) - (cerror "Go ahead and change the value." - "The constant ~S is being redefined." - name))) (setf (symbol-value name) value) (setf (info :variable :kind name) :constant) - (clear-info :variable :constant-value name) + (setf (info :variable :constant-value name) value) name) ;;;; DEFINE-COMPILER-MACRO @@ -145,7 +157,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) @@ -163,19 +175,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)) @@ -183,25 +193,30 @@ (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)))) @@ -239,7 +254,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