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
- "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."
+(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-symbol-value 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 the DEFCONSTANT-EQX macro used in SBCL (which
- ;; is occasionally more appropriate). -- WHN 2001-12-21
- (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
- ;; 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)
+ (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."
- (let ((whole (gensym "WHOLE-"))
- (environment (gensym "ENV-")))
+ (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...
+ (sb!c::compiler-style-warn
+ "defining compiler macro of (SETF ...), which will not be expanded"))
+ (when (and (symbolp name) (special-operator-p name))
+ (error 'simple-program-error
+ :format-control "cannot define a compiler-macro for a special operator: ~S"
+ :format-arguments (list name)))
+ (with-unique-names (whole environment)
(multiple-value-bind (body local-decs doc)
(parse-defmacro lambda-list whole body name 'define-compiler-macro
:environment environment)
(let ((def `(lambda (,whole ,environment)
,@local-decs
- (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)
- ;; FIXME: Add support for (SETF FDOCUMENTATION) when object is a list
- ;; and type is COMPILER-MACRO. (Until then, we have to discard any
- ;; compiler macro documentation for (SETF FOO).)
- (unless (listp name)
- (setf (fdocumentation name 'compiler-macro) doc))
- name)
+ ,body))
+ (debug-name (debug-namify "DEFINE-COMPILER-MACRO ~S" name)))
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ (sb!c::%define-compiler-macro ',name
+ #',def
+ ',lambda-list
+ ,doc
+ ,debug-name))))))
+
+;;; FIXME: This will look remarkably similar to those who have already
+;;; seen the code for %DEFMACRO in src/code/defmacro.lisp. Various
+;;; bits of logic should be shared (notably arglist setting).
+(macrolet
+ ((def (times set-p)
+ `(eval-when (,@times)
+ (defun sb!c::%define-compiler-macro
+ (name definition lambda-list doc debug-name)
+ ,@(unless set-p
+ '((declare (ignore lambda-list debug-name))))
+ ;; FIXME: warn about incompatible lambda list with
+ ;; respect to parent function?
+ (setf (sb!xc:compiler-macro-function name) definition)
+ ;; FIXME: Add support for (SETF FDOCUMENTATION) when
+ ;; object is a list and type is COMPILER-MACRO. (Until
+ ;; then, we have to discard any compiler macro
+ ;; documentation for (SETF FOO).)
+ (unless (listp name)
+ (setf (fdocumentation name 'compiler-macro) doc))
+ ,(when set-p
+ `(case (widetag-of definition)
+ (#.sb!vm:closure-header-widetag
+ (setf (%simple-fun-arglist (%closure-fun definition))
+ lambda-list
+ (%simple-fun-name (%closure-fun definition))
+ debug-name))
+ ((#.sb!vm:simple-fun-header-widetag
+ #.sb!vm:closure-fun-header-widetag)
+ (setf (%simple-fun-arglist definition) lambda-list
+ (%simple-fun-name definition) debug-name))))
+ name))))
+ (progn
+ (def (:load-toplevel :execute) #-sb-xc-host t #+sb-xc-host nil)
+ #-sb-xc (def (:compile-toplevel) nil)))
\f
;;;; CASE, TYPECASE, and friends
-(eval-when (:compile-toplevel :load-toplevel :execute)
+(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
;;; 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
(let ((keyform-value (gensym))
(clauses ())
(keys ()))
- (dolist (case cases)
+ (do* ((cases cases (cdr cases))
+ (case (car cases) (car cases)))
+ ((null cases) nil)
(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))
+ (cond ((and (memq keyoid '(t otherwise))
+ (null (cdr cases)))
(if errorp
- (error 'simple-program-error
- :format-control
- "No default clause is allowed in ~S: ~S"
- :format-arguments (list name case))
+ (progn
+ (style-warn "~@<Treating bare ~A in ~A as introducing a ~
+ normal-clause, not an otherwise-clause~@:>"
+ keyoid name)
+ (push keyoid keys)
+ (push `((,test ,keyform-value ',keyoid) nil ,@forms)
+ clauses))
(push `(t nil ,@forms) clauses)))
((and multi-p (listp keyoid))
(setf keys (append keyoid keys))
;;;; WITH-FOO i/o-related macros
(defmacro-mundanely with-open-stream ((var stream) &body forms-decls)
- (multiple-value-bind (forms decls) (parse-body forms-decls nil)
+ (multiple-value-bind (forms decls)
+ (parse-body forms-decls :doc-string-allowed nil)
(let ((abortp (gensym)))
`(let ((,var ,stream)
(,abortp t))
(defmacro-mundanely with-input-from-string ((var string &key index start end)
&body forms-decls)
- (multiple-value-bind (forms decls) (parse-body forms-decls nil)
+ (multiple-value-bind (forms decls)
+ (parse-body forms-decls :doc-string-allowed nil)
;; The ONCE-ONLY inhibits compiler note for unreachable code when
;; END is true.
(once-only ((string string))
,@(when index
`((setf ,index (string-input-stream-current ,var)))))))))
-(defmacro-mundanely with-output-to-string ((var &optional string)
- &body forms-decls)
- (multiple-value-bind (forms decls) (parse-body forms-decls nil)
+(defmacro-mundanely with-output-to-string
+ ((var &optional string &key (element-type ''character))
+ &body forms-decls)
+ (multiple-value-bind (forms decls)
+ (parse-body forms-decls :doc-string-allowed nil)
(if string
`(let ((,var (make-fill-pointer-output-stream ,string)))
,@decls
(unwind-protect
(progn ,@forms)
(close ,var)))
- `(let ((,var (make-string-output-stream)))
+ `(let ((,var (make-string-output-stream :element-type ,element-type)))
,@decls
(unwind-protect
(progn ,@forms)
#!+sb-doc
"Evaluate FORM and return the Nth value (zero based). This involves no
consing when N is a trivial constant integer."
+ ;; FIXME: The above is true, if slightly misleading. The
+ ;; MULTIPLE-VALUE-BIND idiom [ as opposed to MULTIPLE-VALUE-CALL
+ ;; (LAMBDA (&REST VALUES) (NTH N VALUES)) ] does indeed not cons at
+ ;; runtime. However, for large N (say N = 200), COMPILE on such a
+ ;; form will take longer than can be described as adequate, as the
+ ;; optional dispatch mechanism for the M-V-B gets increasingly
+ ;; hairy.
(if (integerp n)
(let ((dummy-list nil)
(keeper (gensym "KEEPER-")))
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)
projects / sbcl.git / blobdiff