X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fmacros.lisp;h=0843787f4ff9d3cc008ced494f96eb357d74307d;hb=67dc5cf478dfe5e3f517001febb9a8f7b922eacf;hp=b4453d12f3fac6b5e86206820fe9b8701ecfc7da;hpb=dc84ceb894fdbe315f82dd8336f3ba894435a669;p=sbcl.git diff --git a/src/code/macros.lisp b/src/code/macros.lisp index b4453d1..0843787 100644 --- a/src/code/macros.lisp +++ b/src/code/macros.lisp @@ -54,14 +54,6 @@ ;;; 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) @@ -87,6 +79,8 @@ (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) @@ -100,7 +94,6 @@ :format-control "Symbol macro name already declared constant: ~S." :format-arguments (list name)))) name) - ;;;; DEFINE-COMPILER-MACRO @@ -128,18 +121,20 @@ (error 'simple-program-error :format-control "cannot define a compiler-macro for a special operator: ~S" :format-arguments (list name))) - (let ((whole (gensym "WHOLE-")) - (environment (gensym "ENV-"))) + (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))) - (debug-name (debug-namify "DEFINE-COMPILER-MACRO ~S" name))) + ,body)) + (debug-name (sb!c::debug-namify "DEFINE-COMPILER-MACRO " name))) `(eval-when (:compile-toplevel :load-toplevel :execute) - (sb!c::%define-compiler-macro ',name #',def ',lambda-list ,doc ,debug-name)))))) + (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 @@ -167,18 +162,17 @@ lambda-list (%simple-fun-name (%closure-fun definition)) debug-name)) - ((#.sb!vm:simple-fun-header-widetag - #.sb!vm:closure-fun-header-widetag) + (#.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) - (def (:compile-toplevel) 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 @@ -197,16 +191,19 @@ (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 (progn - ;; FIXME: this message could probably do with - ;; some loving pretty-printer format controls. - (style-warn "Treating bare ~A in ~A as introducing a normal-clause, not an otherwise-clause" keyoid name) + (style-warn "~@" + keyoid name) (push keyoid keys) (push `((,test ,keyform-value ',keyoid) nil ,@forms) clauses)) @@ -315,7 +312,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)) @@ -334,7 +332,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)) @@ -359,16 +358,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) @@ -381,6 +382,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-")))