X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fmacros.lisp;h=4ef3dc0a749993e3f7f7ad6db16dacf4e60a5db2;hb=c41cb4c87eae7b04f844dca5f7edb5086c5d2d68;hp=adceea0222929580e8a68b8a115b2766fe7cf9d4;hpb=8731c1a7c1a585d190151fa881050fb5e14c0616;p=sbcl.git diff --git a/src/code/macros.lisp b/src/code/macros.lisp index adceea0..4ef3dc0 100644 --- a/src/code/macros.lisp +++ b/src/code/macros.lisp @@ -100,44 +100,86 @@ :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 ,(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))) ;;;; 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 @@ -156,16 +198,22 @@ (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 "~@" + 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)) @@ -271,7 +319,8 @@ ;;;; 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)) @@ -290,7 +339,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)) @@ -315,16 +365,18 @@ ,@(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) @@ -337,6 +389,13 @@ #!+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-")))