X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fmacros.lisp;h=45bc48a44c64fd317233e4fdb32cff1df162e974;hb=5bad55941fafc315116f6fcf2c8c2cce8af7ed9a;hp=9159bfb28f442dcd74ac52336576e43b27f90a6d;hpb=47da3aec921176b189868519273b5bddb8bcc737;p=sbcl.git diff --git a/src/code/macros.lisp b/src/code/macros.lisp index 9159bfb..45bc48a 100644 --- a/src/code/macros.lisp +++ b/src/code/macros.lisp @@ -37,7 +37,7 @@ (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,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) @@ -134,13 +128,13 @@ (let ((def `(lambda (,whole ,environment) ,@local-decs ,body)) - (debug-name (debug-namify "DEFINE-COMPILER-MACRO ~S" name))) + (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)))))) + (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 @@ -168,8 +162,7 @@ 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)))) @@ -188,8 +181,9 @@ ;;; 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) @@ -204,17 +198,33 @@ (unless (list-of-length-at-least-p case 1) (error "~S -- bad clause in ~S" case name)) (destructuring-bind (keyoid &rest forms) case - (cond ((and (memq keyoid '(t otherwise)) + (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))) - (if errorp - (progn - (style-warn "~@" - keyoid name) - (push keyoid keys) - (push `((,test ,keyform-value ',keyoid) nil ,@forms) - clauses)) - (push `(t nil ,@forms) clauses))) + (push `(t nil ,@forms) clauses)) ((and multi-p (listp keyoid)) (setf keys (append keyoid keys)) (push `((or ,@(mapcar (lambda (key) @@ -319,7 +329,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)) @@ -338,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)) @@ -357,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)