X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fmacros.lisp;h=45bc48a44c64fd317233e4fdb32cff1df162e974;hb=5bad55941fafc315116f6fcf2c8c2cce8af7ed9a;hp=362bce1a3afe6b60fdd4c2c7e98f41440bc0d0a8;hpb=5eb97830eca716fef626c6e12429c99c9b97e3c8;p=sbcl.git diff --git a/src/code/macros.lisp b/src/code/macros.lisp index 362bce1..45bc48a 100644 --- a/src/code/macros.lisp +++ b/src/code/macros.lisp @@ -28,16 +28,16 @@ #!+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) (cond ((y-or-n-p "The old value of ~S is ~S.~ - ~%Do you want to supply a new 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*)))) @@ -54,231 +54,194 @@ ;;; 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 + "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))))) -;;;; DEFCONSTANT +;;;; DEFINE-SYMBOL-MACRO -(defmacro-mundanely defconstant (var val &optional doc) - #!+sb-doc - "For defining global constants at top level. 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 equal to the init, an error is signalled. The third - argument is an optional documentation string for the variable." - `(sb!c::%defconstant ',var ,val ',doc)) +(defmacro-mundanely define-symbol-macro (name expansion) + `(eval-when (:compile-toplevel :load-toplevel :execute) + (sb!c::%define-symbol-macro ',name ',expansion))) -;;; These are like the other %MUMBLEs except that we currently -;;; actually do something interesting at load time, namely checking -;;; whether the constant is being redefined. -(defun sb!c::%defconstant (name value doc) - (sb!c::%%defconstant name value doc)) -#+sb-xc-host (sb!xc:proclaim '(ftype function sb!c::%%defconstant)) ; to avoid - ; undefined function warnings -(defun sb!c::%%defconstant (name value doc) - (when doc - (setf (fdocumentation name 'variable) doc)) - (when (boundp name) - (unless (equalp (symbol-value name) value) - (cerror "Go ahead and change the value." - "The constant ~S is being redefined." - name))) - (setf (symbol-value name) value) - (setf (info :variable :kind name) :constant) - (clear-info :variable :constant-value name) +(defun sb!c::%define-symbol-macro (name expansion) + (unless (symbolp 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")) + (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) ;;;; 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 ,(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? - (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) - (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 (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) + ;; 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 + (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))) ;;;; CASE, TYPECASE, and friends -(eval-when (:compile-toplevel :load-toplevel :execute) +(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute) -;;; CASE-BODY (interface) -;;; -;;; 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 +;;; 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 ;;; indicates whether a branch may fire off a list of keys; otherwise, ;;; a key that is a list is interpreted in some way as a single key. -;;; 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 -;;; omit errorp, and the ERROR form generated is executed within a -;;; RESTART-CASE allowing keyform to be set and retested. +;;; 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 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) - (cond ((atom case) - (error "~S -- Bad clause in ~S." case name)) - ((memq (car case) '(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 ,@(rest case)) clauses))) - ((and multi-p (listp (first case))) - (setf keys (append (first case) keys)) - (push `((or ,@(mapcar #'(lambda (key) + (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 (;; 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)) + (push `((or ,@(mapcar (lambda (key) `(,test ,keyform-value ',key)) - (first case))) - nil ,@(rest case)) - clauses)) - (t - (push (first case) keys) - (push `((,test ,keyform-value - ',(first case)) nil ,@(rest case)) clauses)))) + keyoid)) + nil + ,@forms) + clauses)) + (t + (push keyoid keys) + (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)))) - -;;; MNA: typecase-implicit-declarations patch - -;;; TYPECASE-BODY (interface) -;;; -;;; TYPECASE-BODY returns code for all the standard "typecase" macros. -;;; Name is the macro name, and keyform is the thing to case on. -;;; 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 -;;; omit errorp, and the ERROR form generated is executed within a -;;; RESTART-CASE allowing keyform to be set and retested. -(defun typecase-body (name keyform cases test errorp proceedp needcasesp) - (unless (or cases (not needcasesp)) - (warn "no clauses in ~S" name)) - (let* ((keyform-symbol-p (symbolp keyform)) - (keyform-value (unless keyform-symbol-p - (gensym))) - (clauses ()) - (keys ())) - (dolist (case cases) - (cond ((atom case) - (error "~S -- Bad clause in ~S." case name)) - ((memq (car case) '(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 ,@(rest case)) clauses))) - (t - (push (first case) keys) - (push (if keyform-symbol-p - `((,test ,keyform ',(first case)) nil - (locally - ;; this will cause a compiler-warning ... disabled - ;; for now. - ;; (declare (type ,(first case) ,keyform)) - ,@(rest case))) - `((,test ,keyform-value ',(first case)) nil - ,@(rest case))) - clauses)))) - (if keyform-symbol-p - (typecase-symbol-body-aux name keyform clauses keys errorp proceedp - (cons 'or keys)) - (case-body-aux name keyform keyform-value clauses keys errorp proceedp - (cons 'or keys))))) - -;;; TYPECASE-SYMBOL-BODY-AUX provides the expansion once CASE-BODY has groveled -;;; all the cases, iff keyform is a symbol. -(defun typecase-symbol-body-aux (name keyform clauses keys - errorp proceedp expected-type) - (if proceedp - (let ((block (gensym)) - (again (gensym))) - `(block ,block - (tagbody - ,again - (return-from - ,block - (cond ,@(nreverse clauses) - (t - (setf ,keyform - (case-body-error - ',name ',keyform ,keyform - ',expected-type ',keys))) - (go ,again)))))) - `(progn - (cond - ,@(nreverse clauses) - ,@(if errorp - `((t (error 'sb!conditions::case-failure - :name ',name - :datum ,keyform - :expected-type ',expected-type - :possibilities ',keys)))))))) - ;;; CASE-BODY-AUX provides the expansion once CASE-BODY has groveled ;;; all the cases. Note: it is not necessary that the resulting code ;;; signal case-failure conditions, but that's what KMP's prototype @@ -313,7 +276,7 @@ (cond ,@(nreverse clauses) ,@(if errorp - `((t (error 'sb!conditions::case-failure + `((t (error 'case-failure :name ',name :datum ,keyform-value :expected-type ',expected-type @@ -347,26 +310,27 @@ "TYPECASE Keyform {(Type Form*)}* Evaluates the Forms in the first clause for which TYPEP of Keyform and Type is true." - (typecase-body 'typecase keyform cases 'typep nil nil nil)) + (case-body 'typecase keyform cases nil 'typep nil nil nil)) (defmacro-mundanely ctypecase (keyform &body cases) #!+sb-doc "CTYPECASE Keyform {(Type Form*)}* Evaluates the Forms in the first clause for which TYPEP of Keyform and Type is true. If no form is satisfied then a correctable error is signalled." - (typecase-body 'ctypecase keyform cases 'typep t t t)) + (case-body 'ctypecase keyform cases nil 'typep t t t)) (defmacro-mundanely etypecase (keyform &body cases) #!+sb-doc "ETYPECASE Keyform {(Type Form*)}* Evaluates the Forms in the first clause for which TYPEP of Keyform and Type is true. If no form is satisfied then an error is signalled." - (typecase-body 'etypecase keyform cases 'typep t nil t)) + (case-body 'etypecase keyform cases nil 'typep t nil t)) ;;;; 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)) @@ -385,7 +349,8 @@ (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)) @@ -404,22 +369,25 @@ ,(or start 0) ,end))))) ,@decls - (unwind-protect - (progn ,@forms) - (close ,var) + (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))) + `(let ((,var (make-string-output-stream :element-type ,element-type))) ,@decls (unwind-protect (progn ,@forms) @@ -430,8 +398,15 @@ (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-"))) @@ -454,29 +429,23 @@ #!+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))))