X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Flate-format.lisp;h=998468b1ba9461c855218d696b8d9c753656ebd0;hb=09957fcf57b49ed5ae5f05d62ad12d7ddbfd8e1d;hp=d359fa30fcef2bde4782e345ecd024a96faa238f;hpb=a530bbe337109d898d5b4a001fc8f1afa3b5dc39;p=sbcl.git

diff --git a/src/code/late-format.lisp b/src/code/late-format.lisp
index d359fa3..998468b 100644
--- a/src/code/late-format.lisp
+++ b/src/code/late-format.lisp
@@ -8,9 +8,6 @@
 ;;;; files for more information.
 
 (in-package "SB!FORMAT")
-
-(file-comment
-  "$Header$")
 
 (define-condition format-error (error)
   ((complaint :reader format-error-complaint :initarg :complaint)
@@ -35,10 +32,10 @@
 	  (format-error-offset condition)))
 
 (def!struct format-directive
-  (string (required-argument) :type simple-string)
-  (start (required-argument) :type (and unsigned-byte fixnum))
-  (end (required-argument) :type (and unsigned-byte fixnum))
-  (character (required-argument) :type base-char)
+  (string (missing-arg) :type simple-string)
+  (start (missing-arg) :type (and unsigned-byte fixnum))
+  (end (missing-arg) :type (and unsigned-byte fixnum))
+  (character (missing-arg) :type base-char)
   (colonp nil :type (member t nil))
   (atsignp nil :type (member t nil))
   (params nil :type list))
@@ -266,7 +263,7 @@
 			     (error
 			      'format-error
 			      :complaint
-			      "too many parameters, expected no more than ~D"
+			      "too many parameters, expected no more than ~W"
 			      :arguments (list ,(length specs))
 			      :offset (caar ,params)))
 		       ,,@body)))
@@ -289,14 +286,10 @@
     `(progn
        (defun ,defun-name (,directive ,directives)
 	 ,@(if lambda-list
-	       `((let ,(mapcar #'(lambda (var)
-				   `(,var
-				     (,(intern (concatenate
-						'string
-						"FORMAT-DIRECTIVE-"
-						(symbol-name var))
-					       (symbol-package 'foo))
-				      ,directive)))
+	       `((let ,(mapcar (lambda (var)
+				 `(,var
+				   (,(symbolicate "FORMAT-DIRECTIVE-" var)
+				    ,directive)))
 			       (butlast lambda-list))
 		   ,@body))
 	       `((declare (ignore ,directive ,directives))
@@ -467,6 +460,7 @@
 			  :complaint "no previous argument"))
 		 (caar *simple-args*))
 		(t
+		 (/show0 "THROWing NEED-ORIG-ARGS from tilde-P")
 		 (throw 'need-orig-args nil)))))
       (if atsignp
 	  `(write-string (if (eql ,arg 1) "y" "ies") stream)
@@ -618,17 +612,19 @@
 		 "both colon and atsign modifiers used simultaneously")
 	  (expand-bind-defaults ((posn 0)) params
 	    (unless *orig-args-available*
+	      (/show0 "THROWing NEED-ORIG-ARGS from tilde-@*")
 	      (throw 'need-orig-args nil))
 	    `(if (<= 0 ,posn (length orig-args))
 		 (setf args (nthcdr ,posn orig-args))
 		 (error 'format-error
-			:complaint "Index ~D out of bounds. Should have been ~
-				    between 0 and ~D."
+			:complaint "Index ~W out of bounds. Should have been ~
+				    between 0 and ~W."
 			:arguments (list ,posn (length orig-args))
 			:offset ,(1- end)))))
       (if colonp
 	  (expand-bind-defaults ((n 1)) params
 	    (unless *orig-args-available*
+	      (/show0 "THROWing NEED-ORIG-ARGS from tilde-:*")
 	      (throw 'need-orig-args nil))
 	    `(do ((cur-posn 0 (1+ cur-posn))
 		  (arg-ptr orig-args (cdr arg-ptr)))
@@ -638,8 +634,8 @@
 			(setf args (nthcdr new-posn orig-args))
 			(error 'format-error
 			       :complaint
-			       "Index ~D is out of bounds; should have been ~
-				between 0 and ~D."
+			       "Index ~W is out of bounds; should have been ~
+				between 0 and ~W."
 			       :arguments
 			       (list new-posn (length orig-args))
 			       :offset ,(1- end)))))))
@@ -659,14 +655,14 @@
   (expand-bind-defaults () params
     `(handler-bind
 	 ((format-error
-	   #'(lambda (condition)
-	       (error 'format-error
-		      :complaint
-		      "~A~%while processing indirect format string:"
-		      :arguments (list condition)
-		      :print-banner nil
-		      :control-string ,string
-		      :offset ,(1- end)))))
+	   (lambda (condition)
+	     (error 'format-error
+		    :complaint
+		    "~A~%while processing indirect format string:"
+		    :arguments (list condition)
+		    :print-banner nil
+		    :control-string ,string
+		    :offset ,(1- end)))))
        ,(if atsignp
 	    (if *orig-args-available*
 		`(setf args (%format stream ,(expand-next-arg) orig-args args))
@@ -871,14 +867,14 @@
 		 (if *orig-args-available*
 		     `((handler-bind
 			   ((format-error
-			     #'(lambda (condition)
-				 (error 'format-error
-					:complaint
-			"~A~%while processing indirect format string:"
-					:arguments (list condition)
-					:print-banner nil
-					:control-string ,string
-					:offset ,(1- end)))))
+			     (lambda (condition)
+			       (error 'format-error
+				      :complaint
+			      "~A~%while processing indirect format string:"
+				      :arguments (list condition)
+				      :print-banner nil
+				      :control-string ,string
+				      :offset ,(1- end)))))
 			 (setf args
 			       (%format stream inside-string orig-args args))))
 		     (throw 'need-orig-args nil))
@@ -1108,10 +1104,10 @@
 		       (line-len '(or (sb!impl::line-length stream) 72)))
 		      (format-directive-params first-semi)
 		    `(setf extra-space ,extra line-len ,line-len))))
-	   ,@(mapcar #'(lambda (segment)
-			 `(push (with-output-to-string (stream)
-				  ,@(expand-directive-list segment))
-				segments))
+	   ,@(mapcar (lambda (segment)
+		       `(push (with-output-to-string (stream)
+				,@(expand-directive-list segment))
+			      segments))
 		     segments))
 	 (format-justification stream
 			       ,@(if newline-segment-p
@@ -1123,7 +1119,7 @@
 ;;;; format directive and support function for user-defined method
 
 (def-format-directive #\/ (string start end colonp atsignp params)
-  (let ((symbol (extract-user-function-name string start end)))
+  (let ((symbol (extract-user-fun-name string start end)))
     (collect ((param-names) (bindings))
       (dolist (param-and-offset params)
 	(let ((param (cdr param-and-offset)))
@@ -1138,7 +1134,7 @@
 	 (,symbol stream ,(expand-next-arg) ,colonp ,atsignp
 		  ,@(param-names))))))
 
-(defun extract-user-function-name (string start end)
+(defun extract-user-fun-name (string start end)
   (let ((slash (position #\/ string :start start :end (1- end)
 			 :from-end t)))
     (unless slash