X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fmacros.lisp;h=0b23bacb7b2f13013baa2684dc2381c8ff0e14ba;hb=69d60b456b07a0256f08df0d02484f361ce5737c;hp=0843787f4ff9d3cc008ced494f96eb357d74307d;hpb=ff92598854bf7cae8d57fe49cef4d9a98e1ab345;p=sbcl.git

diff --git a/src/code/macros.lisp b/src/code/macros.lisp
index 0843787..0b23bac 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*))))
@@ -128,13 +128,13 @@
       (let ((def `(lambda (,whole ,environment)
 		    ,@local-decs
 		    ,body))
-	    (debug-name (sb!c::debug-namify "DEFINE-COMPILER-MACRO " 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
@@ -181,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)
@@ -197,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 "~@<Treating bare ~A in ~A as introducing a ~
-                                  normal-clause, not an otherwise-clause~@:>"
-				 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)
@@ -352,9 +369,10 @@
 						 ,(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)))))))))
 
@@ -364,11 +382,17 @@
   (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 ((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 :element-type ,element-type)))
   	 ,@decls
   	 (unwind-protect