#!+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)
- `(setf ,place (assert-prompt ',place ,place)))
+ ,@(mapcar (lambda (place)
+ `(setf ,place (assert-prompt ',place ,place)))
places)))
(defun assert-prompt (name value)
;;;
;;; 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
+;;;; DEFINE-SYMBOL-MACRO
-(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."
+(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)))
-;;; (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)
+(defun sb!c::%define-symbol-macro (name expansion)
(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 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
- (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))
- (setf (symbol-value 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
-;;; FIXME: The logic here for handling compiler macros named (SETF
-;;; FOO) was added after the fork from SBCL, is not well tested, and
-;;; may conflict with subtleties of the ANSI standard. E.g. section
-;;; "3.2.2.1 Compiler Macros" says that creating a lexical binding for
-;;; a function name shadows a compiler macro, and it's not clear that
-;;; that works with this version. It should be tested.
(defmacro-mundanely define-compiler-macro (name lambda-list &body body)
#!+sb-doc
"Define a compiler-macro for NAME."
+ (legal-fun-name-or-type-error name)
+ (when (consp name)
+ ;; It's fairly clear that the user intends the compiler macro to
+ ;; expand when he does (SETF (FOO ...) X). And that's even a
+ ;; useful and reasonable thing to want. Unfortunately,
+ ;; (SETF (FOO ...) X) macroexpands into (FUNCALL (SETF FOO) X ...),
+ ;; and it's not at all clear that it's valid to expand a FUNCALL form,
+ ;; and the ANSI standard doesn't seem to say anything else which
+ ;; would justify us expanding the compiler macro the way the user
+ ;; wants. So instead we rely on 3.2.2.1.3 "When Compiler Macros Are
+ ;; Used" which says they never have to be used, so by ignoring such
+ ;; macros we're erring on the safe side. But any user who does
+ ;; (DEFINE-COMPILER-MACRO (SETF FOO) ...) could easily be surprised
+ ;; by this way of complying with a rather screwy aspect of the ANSI
+ ;; spec, so at least we can warn him...
+ (compiler-style-warn
+ "defining compiler macro of (SETF ...), which will not be expanded"))
(let ((whole (gensym "WHOLE-"))
(environment (gensym "ENV-")))
(multiple-value-bind (body local-decs doc)
: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)
(cond
,@(nreverse clauses)
,@(if errorp
- `((t (error 'sb!conditions::case-failure
+ `((t (error 'case-failure
:name ',name
:datum ,keyform-value
:expected-type ',expected-type
(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))))
projects / sbcl.git / blobdiff