X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Flate-format.lisp;h=d758b0dee341bf873ac1de0d0be08b2815c253e5;hb=cb79d726de3e18c660f84c58a43f00d22b459037;hp=c365bb82632d0c48d2bfbd36d09e9f952f56def0;hpb=1f0efb731e8427080690f8ecaf9a56fc287a9d88;p=sbcl.git diff --git a/src/code/late-format.lisp b/src/code/late-format.lisp index c365bb8..d758b0d 100644 --- a/src/code/late-format.lisp +++ b/src/code/late-format.lisp @@ -39,7 +39,7 @@ (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) + (character (missing-arg) :type character) (colonp nil :type (member t nil)) (atsignp nil :type (member t nil)) (params nil :type list)) @@ -270,8 +270,11 @@ (etypecase directive (format-directive (let ((expander - (aref *format-directive-expanders* - (char-code (format-directive-character directive)))) + (let ((char (format-directive-character directive))) + (typecase char + (base-char + (aref *format-directive-expanders* (char-code char))) + (character nil)))) (*default-format-error-offset* (1- (format-directive-end directive)))) (declare (type (or null function) expander)) @@ -490,21 +493,23 @@ (expand-format-integer 16 colonp atsignp params)) (def-format-directive #\R (colonp atsignp params) - (if params - (expand-bind-defaults - ((base 10) (mincol 0) (padchar #\space) (commachar #\,) - (commainterval 3)) - params - `(format-print-integer stream ,(expand-next-arg) ,colonp ,atsignp - ,base ,mincol - ,padchar ,commachar ,commainterval)) - (if atsignp - (if colonp - `(format-print-old-roman stream ,(expand-next-arg)) - `(format-print-roman stream ,(expand-next-arg))) - (if colonp - `(format-print-ordinal stream ,(expand-next-arg)) - `(format-print-cardinal stream ,(expand-next-arg)))))) + (expand-bind-defaults + ((base nil) (mincol 0) (padchar #\space) (commachar #\,) + (commainterval 3)) + params + (let ((n-arg (gensym))) + `(let ((,n-arg ,(expand-next-arg))) + (if ,base + (format-print-integer stream ,n-arg ,colonp ,atsignp + ,base ,mincol + ,padchar ,commachar ,commainterval) + ,(if atsignp + (if colonp + `(format-print-old-roman stream ,n-arg) + `(format-print-roman stream ,n-arg)) + (if colonp + `(format-print-ordinal stream ,n-arg) + `(format-print-cardinal stream ,n-arg)))))))) ;;;; format directive for pluralization @@ -685,7 +690,7 @@ (setf args (nthcdr ,posn orig-args)) (error 'format-error :complaint "Index ~W out of bounds. Should have been ~ - between 0 and ~W." + between 0 and ~W." :args (list ,posn (length orig-args)) :offset ,(1- end))))) (if colonp @@ -702,7 +707,7 @@ (error 'format-error :complaint "Index ~W is out of bounds; should have been ~ - between 0 and ~W." + between 0 and ~W." :args (list new-posn (length orig-args)) :offset ,(1- end))))))) (if params @@ -831,7 +836,7 @@ (let ((*simple-args* *simple-args*)) (values (expand-directive-list sublist) *simple-args*)) - (cond ((eq *simple-args* (cdr new-args)) + (cond ((and new-args (eq *simple-args* (cdr new-args))) (setf *simple-args* new-args) `(when ,(caar new-args) ,@guts)) @@ -902,18 +907,15 @@ (when (and colonp (not *up-up-and-out-allowed*)) (error 'format-error :complaint "attempt to use ~~:^ outside a ~~:{...~~} construct")) - `(when ,(case (length params) - (0 (if colonp - '(null outside-args) - (progn - (setf *only-simple-args* nil) - '(null args)))) - (1 (expand-bind-defaults ((count 0)) params - `(zerop ,count))) - (2 (expand-bind-defaults ((arg1 0) (arg2 0)) params - `(= ,arg1 ,arg2))) - (t (expand-bind-defaults ((arg1 0) (arg2 0) (arg3 0)) params - `(<= ,arg1 ,arg2 ,arg3)))) + `(when ,(expand-bind-defaults ((arg1 nil) (arg2 nil) (arg3 nil)) params + `(cond (,arg3 (<= ,arg1 ,arg2 ,arg3)) + (,arg2 (eql ,arg1 ,arg2)) + (,arg1 (eql ,arg1 0)) + (t ,(if colonp + '(null outside-args) + (progn + (setf *only-simple-args* nil) + '(null args)))))) ,(if colonp '(return-from outside-loop nil) '(return)))) @@ -946,7 +948,7 @@ (throw 'need-orig-args nil)) (let ((*up-up-and-out-allowed* colonp)) (expand-directive-list (subseq directives 0 posn))))) - (compute-loop-aux (count) + (compute-loop (count) (when atsignp (setf *only-simple-args* nil)) `(loop @@ -970,30 +972,31 @@ ,@(when closed-with-colon '((when (null args) (return)))))) - (compute-loop () - (if params - (expand-bind-defaults ((count nil)) params - (compute-loop-aux count)) - (compute-loop-aux nil))) - (compute-block () + (compute-block (count) (if colonp `(block outside-loop - ,(compute-loop)) - (compute-loop))) - (compute-bindings () + ,(compute-loop count)) + (compute-loop count))) + (compute-bindings (count) (if atsignp - (compute-block) - `(let* ((orig-args ,(expand-next-arg)) - (args orig-args)) - (declare (ignorable orig-args args)) - ,(let ((*expander-next-arg-macro* 'expander-next-arg) - (*only-simple-args* nil) - (*orig-args-available* t)) - (compute-block)))))) - (values (if (zerop posn) - `(let ((inside-string ,(expand-next-arg))) - ,(compute-bindings)) - (compute-bindings)) + (compute-block count) + `(let* ((orig-args ,(expand-next-arg)) + (args orig-args)) + (declare (ignorable orig-args args)) + ,(let ((*expander-next-arg-macro* 'expander-next-arg) + (*only-simple-args* nil) + (*orig-args-available* t)) + (compute-block count)))))) + (values (if params + (expand-bind-defaults ((count nil)) params + (if (zerop posn) + `(let ((inside-string ,(expand-next-arg))) + ,(compute-bindings count)) + (compute-bindings count))) + (if (zerop posn) + `(let ((inside-string ,(expand-next-arg))) + ,(compute-bindings nil)) + (compute-bindings nil))) (nthcdr (1+ posn) directives)))))) (def-complex-format-directive #\} () @@ -1059,8 +1062,8 @@ (if directive (error 'format-error :complaint - "cannot include format directives inside the ~ - ~:[suffix~;prefix~] segment of ~~<...~~:>" + "cannot include format directives inside the ~ + ~:[suffix~;prefix~] segment of ~~<...~~:>" :args (list prefix-p) :offset (1- (format-directive-end directive)) :references @@ -1374,7 +1377,7 @@ ((char= c #\P) (unless (format-directive-colonp directive) (incf-both))) - ((or (find c "IT%&|_();>") (char= c #\Newline))) + ((or (find c "IT%&|_();>~") (char= c #\Newline))) ;; FIXME: check correspondence of ~( and ~) ((char= c #\<) (walk-complex-directive walk-justification))