#!+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)
;;;
;;; 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)))))
\f
;;;; 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))
+ "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)))
-;;; 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 "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: 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)
+
+ ;; 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)
\f
;;;; DEFINE-COMPILER-MACRO
: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?
- (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)
+ (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)
(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))
(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
(cond
,@(nreverse clauses)
,@(if errorp
- `((t (error 'sb!conditions::case-failure
+ `((t (error 'case-failure
:name ',name
:datum ,keyform-value
:expected-type ',expected-type
"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))
\f
;;;; WITH-FOO i/o-related macros
(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)
#!+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)
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))))
projects / sbcl.git / blobdiff