X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-format.lisp;h=a129f24ec1567c84602397dc38d53fa68917adc7;hb=a37de74b393a808825585000bb5b2b92218d46c0;hp=1ed89b0f1dca42edeb9228471e42455433aaa152;hpb=cea4896b2482b7b2b429c1631d774b4cfbc0efba;p=sbcl.git diff --git a/src/code/target-format.lisp b/src/code/target-format.lisp index 1ed89b0..a129f24 100644 --- a/src/code/target-format.lisp +++ b/src/code/target-format.lisp @@ -120,14 +120,10 @@ (defun ,defun-name (stream ,directive ,directives orig-args args) (declare (ignorable stream orig-args args)) ,@(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)) (values (progn ,@body) args))) `((declare (ignore ,directive ,directives)) @@ -171,10 +167,15 @@ (write-string string stream)) (dotimes (i minpad) (write-char padchar stream)) - (do ((chars (+ (length string) minpad) (+ chars colinc))) - ((>= chars mincol)) - (dotimes (i colinc) - (write-char padchar stream))) + ;; As of sbcl-0.6.12.34, we could end up here when someone tries to + ;; print e.g. (FORMAT T "~F" "NOTFLOAT"), in which case ANSI says + ;; we're supposed to soldier on bravely, and so we have to deal with + ;; the unsupplied-MINCOL-and-COLINC case without blowing up. + (when (and mincol colinc) + (do ((chars (+ (length string) minpad) (+ chars colinc))) + ((>= chars mincol)) + (dotimes (i colinc) + (write-char padchar stream)))) (when padleft (write-string string stream))) @@ -229,7 +230,10 @@ (cond (name (write-string (string-capitalize name) stream)) ((<= 0 (char-code char) 31) - ;; Print control characters as "^" + ;; Print control characters as "^". (This seems to be + ;; old pre-ANSI behavior, but ANSI just says that the "#^" + ;; sequence is undefined and not reserved for the user, so + ;; this behavior should be ANSI-compliant.) (write-char #\^ stream) (write-char (code-char (+ 64 (char-code char))) stream)) (t @@ -317,54 +321,50 @@ (format-print-ordinal stream (next-arg)) (format-print-cardinal stream (next-arg)))))) -(defconstant cardinal-ones +(defparameter *cardinal-ones* #(nil "one" "two" "three" "four" "five" "six" "seven" "eight" "nine")) -(defconstant cardinal-tens +(defparameter *cardinal-tens* #(nil nil "twenty" "thirty" "forty" "fifty" "sixty" "seventy" "eighty" "ninety")) -(defconstant cardinal-teens +(defparameter *cardinal-teens* #("ten" "eleven" "twelve" "thirteen" "fourteen" ;;; RAD "fifteen" "sixteen" "seventeen" "eighteen" "nineteen")) -(defconstant cardinal-periods +(defparameter *cardinal-periods* #("" " thousand" " million" " billion" " trillion" " quadrillion" " quintillion" " sextillion" " septillion" " octillion" " nonillion" " decillion" " undecillion" " duodecillion" " tredecillion" " quattuordecillion" " quindecillion" " sexdecillion" " septendecillion" " octodecillion" " novemdecillion" " vigintillion")) -(defconstant ordinal-ones +(defparameter *ordinal-ones* #(nil "first" "second" "third" "fourth" - "fifth" "sixth" "seventh" "eighth" "ninth") - #!+sb-doc - "Table of ordinal ones-place digits in English") + "fifth" "sixth" "seventh" "eighth" "ninth")) -(defconstant ordinal-tens +(defparameter *ordinal-tens* #(nil "tenth" "twentieth" "thirtieth" "fortieth" - "fiftieth" "sixtieth" "seventieth" "eightieth" "ninetieth") - #!+sb-doc - "Table of ordinal tens-place digits in English") + "fiftieth" "sixtieth" "seventieth" "eightieth" "ninetieth")) (defun format-print-small-cardinal (stream n) (multiple-value-bind (hundreds rem) (truncate n 100) (when (plusp hundreds) - (write-string (svref cardinal-ones hundreds) stream) + (write-string (svref *cardinal-ones* hundreds) stream) (write-string " hundred" stream) (when (plusp rem) (write-char #\space stream))) (when (plusp rem) (multiple-value-bind (tens ones) (truncate rem 10) (cond ((< 1 tens) - (write-string (svref cardinal-tens tens) stream) + (write-string (svref *cardinal-tens* tens) stream) (when (plusp ones) (write-char #\- stream) - (write-string (svref cardinal-ones ones) stream))) + (write-string (svref *cardinal-ones* ones) stream))) ((= tens 1) - (write-string (svref cardinal-teens ones) stream)) + (write-string (svref *cardinal-teens* ones) stream)) ((plusp ones) - (write-string (svref cardinal-ones ones) stream))))))) + (write-string (svref *cardinal-ones* ones) stream))))))) (defun format-print-cardinal (stream n) (cond ((minusp n) @@ -385,7 +385,7 @@ (unless (zerop beyond) (write-char #\space stream)) (format-print-small-cardinal stream here) - (write-string (svref cardinal-periods period) stream)))) + (write-string (svref *cardinal-periods* period) stream)))) (defun format-print-ordinal (stream n) (when (minusp n) @@ -399,16 +399,16 @@ (multiple-value-bind (tens ones) (truncate bot 10) (cond ((= bot 12) (write-string "twelfth" stream)) ((= tens 1) - (write-string (svref cardinal-teens ones) stream);;;RAD + (write-string (svref *cardinal-teens* ones) stream);;;RAD (write-string "th" stream)) ((and (zerop tens) (plusp ones)) - (write-string (svref ordinal-ones ones) stream)) + (write-string (svref *ordinal-ones* ones) stream)) ((and (zerop ones)(plusp tens)) - (write-string (svref ordinal-tens tens) stream)) + (write-string (svref *ordinal-tens* tens) stream)) ((plusp bot) - (write-string (svref cardinal-tens tens) stream) + (write-string (svref *cardinal-tens* tens) stream) (write-char #\- stream) - (write-string (svref ordinal-ones ones) stream)) + (write-string (svref *ordinal-ones* ones) stream)) ((plusp number) (write-string "th" stream)) (t @@ -1158,7 +1158,7 @@ ;;;; format interpreter and support functions for user-defined method (def-format-interpreter #\/ (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 ((args)) (dolist (param-and-offset params) (let ((param (cdr param-and-offset)))