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)
- `(setf ,place (assert-prompt ',place ,place)))
+ ,@(mapcar (lambda (place)
+ `(setf ,place (assert-prompt ',place ,place)))
places)))
(defun assert-prompt (name value)
(setf ,place
(check-type-error ',place ,place-value ',type ,type-string)))))
\f
-;;;; DEFCONSTANT
+;;;; DEFINE-SYMBOL-MACRO
-(defmacro-mundanely defconstant (name value &optional documentation)
- #!+sb-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."
+(defmacro-mundanely define-symbol-macro (name expansion)
`(eval-when (:compile-toplevel :load-toplevel :execute)
- (sb!c::%defconstant ',name ,value ',documentation)))
+ (sb!c::%define-symbol-macro ',name ',expansion)))
-;;; the guts of DEFCONSTANT
-(defun sb!c::%defconstant (name value doc)
+(defun sb!c::%define-symbol-macro (name expansion)
(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))
-
- ;; 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)
+ (error 'simple-type-error :datum name :expected-type 'symbol
+ :format-control "Symbol macro name is not a symbol: ~S."
+ :format-arguments (list name)))
+ (ecase (info :variable :kind name)
+ ((:macro :global nil)
+ (setf (info :variable :kind name) :macro)
+ (setf (info :variable :macro-expansion name) expansion))
+ (:special
+ (error 'simple-program-error
+ :format-control "Symbol macro name already declared special: ~S."
+ :format-arguments (list name)))
+ (:constant
+ (error 'simple-program-error
+ :format-control "Symbol macro name already declared constant: ~S."
+ :format-arguments (list name))))
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)
+ (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)
(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)
+ `(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))))