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)))
- places)))
+ ,@(mapcar (lambda (place)
+ `(setf ,place (assert-prompt ',place ,place)))
+ places)))
(defun assert-prompt (name value)
(cond ((y-or-n-p "The old value of ~S is ~S.~
- ~%Do you want to supply a new value? "
- name value)
- (format *query-io* "~&Type a form to be evaluated:~%")
- (flet ((read-it () (eval (read *query-io*))))
- (if (symbolp name) ;help user debug lexical variables
- (progv (list name) (list value) (read-it))
- (read-it))))
- (t value)))
+ ~%Do you want to supply a new value? "
+ name value)
+ (format *query-io* "~&Type a form to be evaluated:~%")
+ (flet ((read-it () (eval (read *query-io*))))
+ (if (symbolp name) ;help user debug lexical variables
+ (progv (list name) (list value) (read-it))
+ (read-it))))
+ (t value)))
;;; CHECK-TYPE is written this way, to call CHECK-TYPE-ERROR, because
;;; of how closures are compiled. RESTART-CASE has forms with closures
;;; and some things (e.g., READ-CHAR) can't afford this excessive
;;; consing, we bend backwards a little.
;;;
-;;; 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-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
- 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."
- (let ((place-value (gensym)))
- `(do ((,place-value ,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)
+(defmacro-mundanely check-type (place type &optional type-string
+ &environment env)
#!+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)))))
+ "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, this can only return if the STORE-VALUE restart is
+invoked. In that case it will store into PLACE and start over."
+ ;; Detect a common user-error.
+ (when (and (consp type) (eq 'quote (car type)))
+ (error 'simple-reference-error
+ :format-control "Quoted type specifier in ~S: ~S"
+ :format-arguments (list 'check-type type)
+ :references (list '(:ansi-cl :macro check-type))))
+ ;; KLUDGE: We use a simpler form of expansion if PLACE is just a
+ ;; variable to work around Python's blind spot in type derivation.
+ ;; For more complex places getting the type derived should not
+ ;; matter so much anyhow.
+ (let ((expanded (%macroexpand place env)))
+ (if (symbolp expanded)
+ `(do ()
+ ((typep ,place ',type))
+ (setf ,place (check-type-error ',place ,place ',type ,type-string)))
+ (let ((value (gensym)))
+ `(do ((,value ,place ,place))
+ ((typep ,value ',type))
+ (setf ,place
+ (check-type-error ',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 (sb!c:source-location))))
-;;; the guts of DEFCONSTANT
-(defun sb!c::%defconstant (name value doc)
+(defun sb!c::%define-symbol-macro (name expansion source-location)
(unless (symbolp name)
- (error "The constant name is not a symbol: ~S" name))
- (about-to-modify name)
+ (error 'simple-type-error :datum name :expected-type 'symbol
+ :format-control "Symbol macro name is not a symbol: ~S."
+ :format-arguments (list name)))
+ (with-single-package-locked-error
+ (:symbol name "defining ~A as a symbol-macro"))
+ (sb!c:with-source-location (source-location)
+ (setf (info :source-location :symbol-macro name) source-location))
(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)
+ (ecase kind
+ ((:macro :unknown)
+ (setf (info :variable :kind name) :macro)
+ (setf (info :variable :macro-expansion name) expansion))
+ ((:special :global)
+ (error 'simple-program-error
+ :format-control "Symbol macro name already declared ~A: ~S."
+ :format-arguments (list kind name)))
+ (:constant
+ (error 'simple-program-error
+ :format-control "Symbol macro name already defined as a 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 (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)
+ (parse-defmacro lambda-list whole body name 'define-compiler-macro
+ :environment environment)
(let ((def `(lambda (,whole ,environment)
- ,@local-decs
- (block ,(function-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?
- (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)
- (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)
+ ,@local-decs
+ ,body))
+ (debug-name (sb!c::debug-name 'compiler-macro-function 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)
+ ,(when set-p
+ `(setf (%fun-doc definition) doc
+ (%fun-lambda-list definition) lambda-list
+ (%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)
+
+;;; Make this a full warning during SBCL build.
+(define-condition duplicate-case-key-warning (#-sb-xc-host style-warning #+sb-xc-host warning)
+ ((key :initarg :key
+ :reader case-warning-key)
+ (case-kind :initarg :case-kind
+ :reader case-warning-case-kind)
+ (occurrences :initarg :occurrences
+ :type list
+ :reader duplicate-case-key-warning-occurrences))
+ (:report
+ (lambda (condition stream)
+ (format stream
+ "Duplicate key ~S in ~S form, ~
+ occurring in~{~#[~; and~]~{ the ~:R clause:~%~< ~S~:>~}~^,~}."
+ (case-warning-key condition)
+ (case-warning-case-kind condition)
+ (duplicate-case-key-warning-occurrences condition)))))
;;; 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
;;; 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
+;;; case branch. When ERRORP, no OTHERWISE-CLAUSEs are recognized,
+;;; and an ERROR form is generated where control falls off the end
+;;; of the ordinary clauses. 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))
(let ((keyform-value (gensym))
- (clauses ())
- (keys ()))
- (dolist (case cases)
- (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))
- keyoid))
- nil
- ,@forms)
- clauses))
- (t
- (push keyoid keys)
- (push `((,test ,keyform-value ',keyoid)
- nil
- ,@forms)
- clauses)))))
+ (clauses ())
+ (keys ())
+ (keys-seen (make-hash-table :test #'eql)))
+ (do* ((cases cases (cdr cases))
+ (case (car cases) (car cases))
+ (case-position 1 (1+ case-position)))
+ ((null cases) nil)
+ (flet ((check-clause (case-keys)
+ (loop for k in case-keys
+ for existing = (gethash k keys-seen)
+ do (when existing
+ (let ((sb!c::*current-path*
+ (when (boundp 'sb!c::*source-paths*)
+ (or (sb!c::get-source-path case)
+ sb!c::*current-path*))))
+ (warn 'duplicate-case-key-warning
+ :key k
+ :case-kind name
+ :occurrences `(,existing (,case-position (,case)))))))
+ (let ((record (list case-position (list case))))
+ (dolist (k case-keys)
+ (setf (gethash k keys-seen) record)))))
+ (unless (list-of-length-at-least-p case 1)
+ (error "~S -- bad clause in ~S" case name))
+ (destructuring-bind (keyoid &rest forms) case
+ (cond (;; an OTHERWISE-CLAUSE
+ ;;
+ ;; By the way... The old code here tried gave
+ ;; STYLE-WARNINGs for normal-clauses which looked as
+ ;; though they might've been intended to be
+ ;; otherwise-clauses. As Tony Martinez reported on
+ ;; sbcl-devel 2004-11-09 there are sometimes good
+ ;; reasons to write clauses like that; and as I noticed
+ ;; when trying to understand the old code so I could
+ ;; understand his patch, trying to guess which clauses
+ ;; don't have good reasons is fundamentally kind of a
+ ;; mess. SBCL does issue style warnings rather
+ ;; enthusiastically, and I have often justified that by
+ ;; arguing that we're doing that to detect issues which
+ ;; are tedious for programmers to detect for by
+ ;; proofreading (like small typoes in long symbol
+ ;; names, or duplicate function definitions in large
+ ;; files). This doesn't seem to be an issue like that,
+ ;; and I can't think of a comparably good justification
+ ;; for giving STYLE-WARNINGs for legal code here, so
+ ;; now we just hope the programmer knows what he's
+ ;; doing. -- WHN 2004-11-20
+ (and (not errorp) ; possible only in CASE or TYPECASE,
+ ; not in [EC]CASE or [EC]TYPECASE
+ (memq keyoid '(t otherwise))
+ (null (cdr cases)))
+ (push `(t nil ,@forms) clauses))
+ ((and multi-p (listp keyoid))
+ (setf keys (append keyoid keys))
+ (check-clause keyoid)
+ (push `((or ,@(mapcar (lambda (key)
+ `(,test ,keyform-value ',key))
+ keyoid))
+ nil
+ ,@forms)
+ clauses))
+ (t
+ (push keyoid keys)
+ (check-clause (list keyoid))
+ (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))))
+ `(,(if multi-p 'member 'or) ,@keys))))
;;; CASE-BODY-AUX provides the expansion once CASE-BODY has groveled
;;; all the cases. Note: it is not necessary that the resulting code
;;; The CASE-BODY-ERROR function is defined later, when the
;;; RESTART-CASE macro has been defined.
(defun case-body-aux (name keyform keyform-value clauses keys
- errorp proceedp expected-type)
+ errorp proceedp expected-type)
(if proceedp
(let ((block (gensym))
- (again (gensym)))
- `(let ((,keyform-value ,keyform))
- (block ,block
- (tagbody
- ,again
- (return-from
- ,block
- (cond ,@(nreverse clauses)
- (t
- (setf ,keyform-value
- (setf ,keyform
- (case-body-error
- ',name ',keyform ,keyform-value
- ',expected-type ',keys)))
- (go ,again))))))))
+ (again (gensym)))
+ `(let ((,keyform-value ,keyform))
+ (block ,block
+ (tagbody
+ ,again
+ (return-from
+ ,block
+ (cond ,@(nreverse clauses)
+ (t
+ (setf ,keyform-value
+ (setf ,keyform
+ (case-body-error
+ ',name ',keyform ,keyform-value
+ ',expected-type ',keys)))
+ (go ,again))))))))
`(let ((,keyform-value ,keyform))
- (declare (ignorable ,keyform-value)) ; e.g. (CASE KEY (T))
- (cond
- ,@(nreverse clauses)
- ,@(if errorp
- `((t (error 'case-failure
- :name ',name
- :datum ,keyform-value
- :expected-type ',expected-type
- :possibilities ',keys))))))))
+ (declare (ignorable ,keyform-value)) ; e.g. (CASE KEY (T))
+ (cond
+ ,@(nreverse clauses)
+ ,@(if errorp
+ `((t (case-failure ',name ,keyform-value ',keys))))))))
) ; EVAL-WHEN
(defmacro-mundanely case (keyform &body cases)
;;;; 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))
- ,@decls
- (unwind-protect
- (multiple-value-prog1
- (progn ,@forms)
- (setq ,abortp nil))
- (when ,var
- (close ,var :abort ,abortp)))))))
+ (,abortp t))
+ ,@decls
+ (unwind-protect
+ (multiple-value-prog1
+ (progn ,@forms)
+ (setq ,abortp nil))
+ (when ,var
+ (close ,var :abort ,abortp)))))))
(defmacro-mundanely with-open-file ((stream filespec &rest options)
- &body body)
+ &body body)
`(with-open-stream (,stream (open ,filespec ,@options))
,@body))
(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)
+ &body forms-decls)
+ (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))
`(let ((,var
- ,(cond ((null end)
- `(make-string-input-stream ,string ,(or start 0)))
- ((symbolp end)
- `(if ,end
- (make-string-input-stream ,string
- ,(or start 0)
- ,end)
- (make-string-input-stream ,string
- ,(or start 0))))
- (t
- `(make-string-input-stream ,string
- ,(or start 0)
- ,end)))))
- ,@decls
- (unwind-protect
- (progn ,@forms)
- (close ,var)
- ,@(when index
- `((setf ,index (string-input-stream-current ,var)))))))))
+ ,(cond ((null end)
+ `(make-string-input-stream ,string ,(or start 0)))
+ ((symbolp end)
+ `(if ,end
+ (make-string-input-stream ,string
+ ,(or start 0)
+ ,end)
+ (make-string-input-stream ,string
+ ,(or start 0))))
+ (t
+ `(make-string-input-stream ,string
+ ,(or start 0)
+ ,end)))))
+ ,@decls
+ (multiple-value-prog1
+ (unwind-protect
+ (progn ,@forms)
+ (close ,var))
+ ,@(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)))
- ,@decls
- (unwind-protect
- (progn ,@forms)
- (close ,var))
- (get-output-stream-string ,var)))))
+ (let ((element-type-var (gensym)))
+ `(let ((,var (make-fill-pointer-output-stream ,string))
+ ;; ELEMENT-TYPE isn't currently used for anything
+ ;; (see FILL-POINTER-OUTPUT-STREAM FIXME in stream.lisp),
+ ;; but it still has to be evaluated for side-effects.
+ (,element-type-var ,element-type))
+ (declare (ignore ,element-type-var))
+ ,@decls
+ (unwind-protect
+ (progn ,@forms)
+ (close ,var))))
+ `(let ((,var (make-string-output-stream :element-type ,element-type)))
+ ,@decls
+ (unwind-protect
+ (progn ,@forms)
+ (close ,var))
+ (get-output-stream-string ,var)))))
\f
;;;; miscellaneous 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."
+ ;; 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-")))
- ;; We build DUMMY-LIST, a list of variables to bind to useless
- ;; values, then we explicitly IGNORE those bindings and return
- ;; KEEPER, the only thing we're really interested in right now.
- (dotimes (i n)
- (push (gensym "IGNORE-") dummy-list))
- `(multiple-value-bind (,@dummy-list ,keeper) ,form
- (declare (ignore ,@dummy-list))
- ,keeper))
+ (let ((dummy-list (make-gensym-list n))
+ (keeper (sb!xc:gensym "KEEPER")))
+ `(multiple-value-bind (,@dummy-list ,keeper) ,form
+ (declare (ignore ,@dummy-list))
+ ,keeper))
(once-only ((n n))
- `(case (the fixnum ,n)
- (0 (nth-value 0 ,form))
- (1 (nth-value 1 ,form))
- (2 (nth-value 2 ,form))
- (t (nth (the fixnum ,n) (multiple-value-list ,form)))))))
+ `(case (the fixnum ,n)
+ (0 (nth-value 0 ,form))
+ (1 (nth-value 1 ,form))
+ (2 (nth-value 2 ,form))
+ (t (nth (the fixnum ,n) (multiple-value-list ,form)))))))
(defmacro-mundanely declaim (&rest specs)
#!+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)
- &body body)
+(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)))
+ ,(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