X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fmacros.lisp;h=3cbc7af50326381dd80c43efca7a4ed108c5dc28;hb=4ba392170e98744f0ef0b8e08a5d42b988f1d0c9;hp=006459d961a76091e50903e5b8cc1aed975a7a91;hpb=31361af9eb64344f521abbb245ea784c76c746e5;p=sbcl.git diff --git a/src/code/macros.lisp b/src/code/macros.lisp index 006459d..3cbc7af 100644 --- a/src/code/macros.lisp +++ b/src/code/macros.lisp @@ -24,27 +24,75 @@ ;;; ;;; ASSERT-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 assert (test-form &optional places datum &rest arguments) +(defmacro-mundanely assert (test-form &optional places datum &rest arguments + &environment env) #!+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." - `(do () (,test-form) - (assert-error ',test-form ',places ,datum ,@arguments) - ,@(mapcar #'(lambda (place) - `(setf ,place (assert-prompt ',place ,place))) - places))) + "Signals an error if the value of TEST-FORM is NIL. Returns NIL. + + Optional DATUM and ARGUMENTS can be used to change the signaled + error condition and are interpreted as in (APPLY #'ERROR DATUM + ARGUMENTS). + + Continuing from the signaled error using the CONTINUE restart will + allow the user to alter the values of the SETFable locations + specified in PLACES and then start over with TEST-FORM. + + If TEST-FORM is of the form + + (FUNCTION ARG*) + + where FUNCTION is a function (but not a special operator like + CL:OR, CL:AND, etc.) the results of evaluating the ARGs will be + included in the error report if the assertion fails." + (collect ((bindings) (infos)) + (let ((new-test + (flet ((process-place (place) + (if (sb!xc:constantp place env) + place + (with-unique-names (temp) + (bindings `(,temp ,place)) + (infos `(list ',place ,temp)) + temp)))) + (cond + ;; TEST-FORM looks like a function call. We do not + ;; attempt this if TEST-FORM is the application of a + ;; special operator because of argument evaluation + ;; order issues. + ((and (typep test-form '(cons symbol list)) + (eq (info :function :kind (first test-form)) :function)) + (let ((name (first test-form)) + (args (mapcar #'process-place (rest test-form)))) + `(,name ,@args))) + ;; For all other cases, just evaluate TEST-FORM and do + ;; not report any details if the assertion fails. + (t + test-form))))) + ;; If TEST-FORM, potentially using values from BINDINGS, does not + ;; hold, enter a loop which reports the assertion error, + ;; potentially changes PLACES, and retries TEST-FORM. + `(tagbody + :try + (let ,(bindings) + (when ,new-test + (go :done)) + (assert-error ',test-form (list ,@(infos)) + ',places ,datum ,@arguments)) + ,@(mapcar (lambda (place) + `(setf ,place (assert-prompt ',place ,place))) + places) + (go :try) + :done)))) (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 @@ -54,173 +102,134 @@ ;;; 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. (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) +(defmacro-mundanely check-type (place type &optional type-string + &environment env) #!+sb-doc - "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." - (let ((place-value (gensym))) - `(do ((,place-value ,place ,place)) - ((typep ,place-value ',type)) - (setf ,place - (check-type-error ',place ,place-value ',type ,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))))))) -;;;; 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) - (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)) + (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) ;;;; 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) - #!+sb-interpreter (setf (sb!eval:interpreted-function-name definition) - (format nil "DEFINE-COMPILER-MACRO ~S" name)) - #!+sb-interpreter (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))) ;;;; 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 @@ -229,43 +238,96 @@ the usual naming convention (names like *FOO*) for special variables" ;;; 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 + (when (and (eq name 'case) + (cdr cases) + (memq keyoid '(t otherwise))) + (error 'simple-reference-error + :format-control + "~@<~IBad ~S clause:~:@_ ~S~:@_~S allowed as the key ~ + designator only in the final otherwise-clause, not in a ~ + normal-clause. Use (~S) instead, or move the clause the ~ + correct position.~:@>" + :format-arguments (list 'case case keyoid keyoid) + :references `((:ansi-cl :macro case)))) + (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 @@ -278,34 +340,30 @@ the usual naming convention (names like *FOO*) for special variables" ;;; 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) @@ -354,117 +412,128 @@ the usual naming convention (names like *FOO*) for special variables" ;;;; 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))))))))) - -(defmacro-mundanely with-output-to-string ((var &optional string) - &body forms-decls) - (multiple-value-bind (forms decls) (parse-body forms-decls nil) + ,(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 &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 + ;; CHARACTER is the default element-type of + ;; string-ouput-stream, save a few bytes when passing it + ,@(and (not (equal element-type ''character)) + `(:element-type ,element-type))))) + ,@decls + (unwind-protect + (progn ,@forms) + (close ,var)) + (get-output-stream-string ,var))))) ;;;; 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)))) - -(defmacro-mundanely print-unreadable-object ((object stream - &key type identity) - &body body) + ,@(mapcar (lambda (spec) `(sb!xc:proclaim ',spec)) + specs))) + +(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))))