From 230cb2168dc6b9956a4b137b4083340c5be96249 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Micha=C5=82=20=22phoe=22=20Herda?= Date: Wed, 30 Oct 2019 13:14:11 +0100 Subject: [PATCH 1/9] Fix ANSI-TEST SHIFTF.7 The failing test's description: ;;; Test that SHIFTF returns a single value, even though the first ;;; place has multiple values. The form: (let ((x 'a) (y 'b)) (values (multiple-value-list (shiftf (values x y) (floor 10 3))) x y)) Was expected to return the following three values: (A) 3 1 But instead evaluated to: (A B) 3 1 --- lib/setf.lisp | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/lib/setf.lisp b/lib/setf.lisp index 9a8f0e3d6..b64b80142 100644 --- a/lib/setf.lisp +++ b/lib/setf.lisp @@ -643,10 +643,10 @@ decremented by the second argument, DELTA, which defaults to 1." last-getter getter))) (if last-let-list `(let* ,(nreverse last-let-list) - (multiple-value-prog1 ,last-getter - ,body)) - `(multiple-value-prog1 ,last-getter - ,body)))) + (values (multiple-value-prog1 ,last-getter + ,body))) + `(values (multiple-value-prog1 ,last-getter + ,body))))) ;(shiftf (car x)(cadr x) 3) From 2230e6a932078c45ee9edcf02f2d60b19d9937e3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Micha=C5=82=20=22phoe=22=20Herda?= Date: Thu, 31 Oct 2019 00:58:34 +0100 Subject: [PATCH 2/9] Fix ANSI-TEST MACROLET.36 The failing test's description: ;;; &whole is followed by a destructuring pattern (see 3.4.4.1.2) The form: (macrolet ((%m (&whole (m a b) c d) `(quote (,m ,a ,b ,c ,d)))) (%m 1 2) Was expected to return the following value: (%M 1 2 1 2) But instead signaled an error, as MACROLET did not expect &WHOLE to be followed by a destructuring pattern. --- lib/level-2.lisp | 16 ++++++++++------ 1 file changed, 10 insertions(+), 6 deletions(-) diff --git a/lib/level-2.lisp b/lib/level-2.lisp index 7991d3ecd..fbd838918 100644 --- a/lib/level-2.lisp +++ b/lib/level-2.lisp @@ -77,16 +77,20 @@ :default-initial-value default-initial-value) (when environment (setq bindings (nconc bindings (list `(,environment ,env-var))))) - (when whole - (setq bindings (nconc bindings (list `(,whole ,whole-var))))) (values `(lambda (,whole-var ,env-var) (declare (ignorable ,whole-var ,env-var)) (block ,name - (let* ,(nreverse bindings) - ,@(when binding-decls `((declare ,@binding-decls))) - ,@local-decs - ,@body))) + (,@(cond ((null whole) + `(progn)) + ((symbolp whole) + `(let ((,whole ,whole-var)))) + (t + `(destructuring-bind ,whole ,whole-var))) + (let* ,(nreverse bindings) + ,@(when binding-decls `((declare ,@binding-decls))) + ,@local-decs + ,@body)))) doc)))))) (defun lambda-list-bounds (lambda-list) From cb3bf347cfc7d112a9b106cf5ce183df66d30ea3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Micha=C5=82=20=22phoe=22=20Herda?= Date: Sat, 2 Nov 2019 17:10:03 +0100 Subject: [PATCH 3/9] Fix ANSI-TEST SYNTAX.SHARP-COLON.ERROR.1 The failing test's description: ;;; Uninterned symbols must not contain a package prefix (see CLHS 2.4.8.5) The form: (read-from-string "#:a:b") Was expected to signal a READER-ERROR, but signaled a SIMPLE-ERROR instead. --- level-1/l1-reader.lisp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/level-1/l1-reader.lisp b/level-1/l1-reader.lisp index 37587f76a..5408b87d8 100644 --- a/level-1/l1-reader.lisp +++ b/level-1/l1-reader.lisp @@ -2823,7 +2823,7 @@ initially NIL.") (or explicit-package (and (not escapes) (%token-to-number tb (%validate-radix *read-base*)))))) - (%err-disp $XBADSYM) + (signal-reader-error stream "Invalid reader syntax.") (%string-from-token tb))))) (set-dispatch-macro-character From 90b2be7690eb4750b819c9f0bfd1c341f81acec8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Micha=C5=82=20=22phoe=22=20Herda?= Date: Sun, 17 Nov 2019 12:42:59 +0100 Subject: [PATCH 4/9] Fix ANSI-TEST COMPILE-FILE.16 The body of the failing test: (deftest compile-file.16 (let* ((file #p"compile-file-test-file-5.lsp") (target-pathname (compile-file-pathname file)) (*compile-print* nil) (*compile-verbose* nil)) (when (probe-file target-pathname) (delete-file target-pathname)) (compile-file file) (load target-pathname) (values (equalpt-or-report (truename file) (funcall 'compile-file-test-fun.5)) (equalpt-or-report (pathname (merge-pathnames file)) (funcall 'compile-file-test-fun.5a)))) t t) Contents of file `compile-file-test-file-5.lsp`: (in-package "CL-TEST") (defun compile-file-test-fun.5 () '#.*compile-file-truename*) (defun compile-file-test-fun.5a () '#.*compile-file-pathname*) This rest is supposed to return VALUES T T but instead returns: T (#P"/home/phoe/Projects/Git/ansi-test/sandbox/compile-file-test-file-5.lsp" #P"home:Projects;Git;ansi-test;sandbox;compile-file-test-file-5.lsp.newest") The spec says: The value of *COMPILE-FILE-PATHNAME* must always be a pathname or nil. So *COMPILE-FILE-PATHNAME* is allowed to be a physical OR a logical pathname, BUT: During a call to COMPILE-FILE, *COMPILE-FILE-PATHNAME* is bound to the pathname denoted by the first argument to COMPILE-FILE, merged against the defaults; that is, it is bound to (PATHNAME (MERGE-PATHNAMES INPUT-FILE)). The spec says on MERGE-PATHNAMES: MERGE-PATHNAMES returns a logical pathname if and only if its first arcument is a logical pathname, or its first argument is a logical pathname namestring with an explicit host, or its first argument does not specify a host and the default-pathname is a logical pathname. First argument is #p"compile-file-test-file-5.lsp" and therefore has no host. The defaults for me are`#P"/home/phoe/Projects/Git/ansi-test/sandbox/"` - a physical pathname. So the first call MERGE-PATHNAMES properly returns a physical pathname. And therefore, inside the compiled file, the value of *COMPILE-FILE-PATHNAME* is incorrect. We solve this by modifying CCL::%COMPILE-FILE and removing an explicit but unnecessary (and non-conforming) call to CCL::BACK-TRANSLATE-PATHNAME that modifies the value that is then bound to *COMPILE-FILE-PATHNAME* inside the compiled file. --- lib/nfcomp.lisp | 2 -- 1 file changed, 2 deletions(-) diff --git a/lib/nfcomp.lisp b/lib/nfcomp.lisp index c02fac5a4..3b440c942 100644 --- a/lib/nfcomp.lisp +++ b/lib/nfcomp.lisp @@ -199,8 +199,6 @@ Will differ from *compiling-file* during an INCLUDE") orig-src)) ;; This should not be necessary, but it is. (setq output-file (namestring output-file)) - (when (physical-pathname-p orig-src) ; only back-translate to things likely to exist at load time - (setq orig-src (back-translate-pathname orig-src '("home" "ccl")))) (when (and (not force) (probe-file output-file) (not (fasl-file-p output-file))) From 1b9cc8966ac664beaa7b3f5cf080405d07e928dd Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Micha=C5=82=20phoe=20Herda?= Date: Tue, 19 Nov 2019 15:57:00 +0100 Subject: [PATCH 5/9] Fix SUBTYPEP.CONS.43 The body of the failing test: (deftest subtypep.cons.43 (let* ((n -3.926510009989861d7) (t1 '(not (cons float t))) (t2 `(or (not (cons (eql 0) (real ,n ,n))) (not (cons t (eql 0)))))) (multiple-value-bind (sub1 good1) (subtypep* t1 t2) (multiple-value-bind (sub2 good2) (subtypep* `(not ,t2) `(not ,t1)) (or (not good1) (not good2) (and sub1 sub2) (and (not sub1) (not sub2)))))) t) We are only interested in a part of this test. After simplifying: (let* ((t1 '(not (cons float t))) (t2 `(or (not (cons (eql 0) (real -3.5d0 -3.5d0))) (not (cons t (eql 0)))))) (subtypep t1 t2)) This evaluates to (VALUES NIL T), even though T2 is equivalent to T and therefore the valid results are (VALUES T T) and (VALUES NIL NIL). After trying to find a smaller reproducible test case, I have found that the error is triggered with the following two types: CCL> (csubtypep (specifier-type '(CONS (NOT FLOAT) T)) (specifier-type `(OR (CONS (INTEGER 0 0) (OR (REAL * (-3.5D0)) (INTEGER * -1) (NOT INTEGER) (REAL (-3.5D0)))) (CONS (OR (NOT INTEGER) (INTEGER * -1) (INTEGER 1)) T)))) ;=> NIL, T Simplifying again: CCL> (specifier-type '(OR (REAL * (-3.5D0)) (NOT INTEGER) (REAL (-3.5D0)))) The above type is equivalent to T, but CCL fails to infer that fact. We fix this issue by modifying CCL::SIMPLIFY-UNIONS and introducing a special case for merging numeric types that are neighboring and have a common exclusive bound (one lower, one higher) in presence of other types that might contain that exclusive bound. This causes CCL to correctly simplify the above type into T. --- level-1/l1-typesys.lisp | 57 +++++++++++++++++++++++++++++++++-------- 1 file changed, 47 insertions(+), 10 deletions(-) diff --git a/level-1/l1-typesys.lisp b/level-1/l1-typesys.lisp index fdaca18c4..bd6df9e7b 100644 --- a/level-1/l1-typesys.lisp +++ b/level-1/l1-typesys.lisp @@ -1190,16 +1190,53 @@ (defun simplify-unions (types) (when types - (multiple-value-bind (first rest) - (if (union-ctype-p (car types)) - (values (car (union-ctype-types (car types))) - (append (cdr (union-ctype-types (car types))) - (cdr types))) - (values (car types) (cdr types))) - (let ((rest (simplify-unions rest)) u) - (dolist (r rest (cons first rest)) - (when (setq u (type-union2 first r)) - (return (simplify-unions (nsubstitute u r rest))))))))) + (let ((types (%simplify-range-unions types))) + (multiple-value-bind (first rest) + (if (union-ctype-p (car types)) + (values (car (union-ctype-types (car types))) + (append (cdr (union-ctype-types (car types))) + (cdr types))) + (values (car types) (cdr types))) + (let ((rest (simplify-unions rest))) + (dolist (ctype rest (cons first rest)) + (let ((found-union (type-union2 first ctype))) + (when found-union + (return (simplify-unions (nsubstitute found-union ctype rest))))))))))) + +(defun %simplify-range-unions (types) + (when types + ;; Special case for merging numeric types that are neighboring and have + ;; a common exclusive bound (one lower, one higher) in presence of other types + ;; that might contain that exclusive bound. Example: + ;; '(OR (REAL * (-3.5d0)) (REAL (-3.5d0)) (NOT INTEGER)) + ;; In the above type, (REAL -3.5d0) is hidden inside the (NOT INTEGER) + ;; type, but the type system is unable to deduce that without this special case + ;; and therefore is unable to simplify this type into T. + (let* ((result (copy-list types))) + (dolist (ctype types result) + (flet ((ctype-copy (high low) + (make-numeric-ctype + :high high :low low + :class (numeric-ctype-class ctype) + :format (numeric-ctype-format ctype) + :complexp (numeric-ctype-complexp ctype) + :enumerable (ctype-enumerable ctype) + :predicate (numeric-ctype-predicate ctype)))) + (when (and (numeric-ctype-p ctype) + (numeric-ctype-high ctype) + (listp (numeric-ctype-high ctype))) + (let* ((bound-ctype + ;; We copy the ctype fully, except for the bounds - + ;; this type must include only the number in question. + (ctype-copy (car (numeric-ctype-high ctype)) + (car (numeric-ctype-high ctype))))) + (when (find-if (lambda (x) (csubtypep bound-ctype x)) types) + (let ((result-ctype + ;; We copy the ctype fully, except for the upper bound - + ;; we make it inclusive instead of exclusive. + (ctype-copy (car (numeric-ctype-high ctype)) + (numeric-ctype-low ctype)))) + (setf result (cons result-ctype (delete ctype result :count 1)))))))))))) (defun type-union2 (type1 type2) (declare (type ctype type1 type2)) From 2559e1debff6986abf7d773f3f4d34c520c6eb2f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Micha=C5=82=20=22phoe=22=20Herda?= Date: Sun, 17 Nov 2019 13:28:28 +0100 Subject: [PATCH 6/9] Fix ANSI-TEST MAP.ERROR.11 MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit The test in question is: (deftest map.error.11 (let ((type '(or (vector t 5) (vector t 10)))) (if (subtypep type 'vector) (eval `(signals-error (map ',type #'identity '(1 2 3 4 5 6)) type-error)) t)) t) This fails because (coerce '(1 2 3 4 5 6) '(or (vector t 5) (vector t 10))) does not signal an error in safe code. We "fix" this issue by following SBCL's lead in the matter and signaling an error whenever an OR type is passed to COERCE and the expected type is a subtype of VECTOR; a proper fix is not in place due to the amount of work required to perform the typecheck. This in turn causes ANSI-TEST MAP.48 to break. It expects the following form (map '(or (vector t 10) (vector t 5)) #'identity '(1 2 3 4 5)) to return #(1 2 3 4 5). We work around this issue by disabling note :RESULT-TYPE-ELEMENT-TYPE-BY-SUBTYPE in ANSI-TEST. Signed-off-by: Michał phoe Herda --- lib/sequences.lisp | 49 ++++++++++++++++++++++++++++------------------ 1 file changed, 30 insertions(+), 19 deletions(-) diff --git a/lib/sequences.lisp b/lib/sequences.lisp index d27a571a3..5e0475707 100644 --- a/lib/sequences.lisp +++ b/lib/sequences.lisp @@ -76,11 +76,11 @@ (defun simplify-vector-ctype (ctype) (typecase ctype (array-ctype - (make-array-ctype :complexp nil - :element-type (array-ctype-element-type ctype) - :specialized-element-type (array-ctype-specialized-element-type ctype) - :dimensions '(*))) - + (make-array-ctype + :complexp nil + :element-type (array-ctype-element-type ctype) + :specialized-element-type (array-ctype-specialized-element-type ctype) + :dimensions '(*))) (named-ctype ctype) (member-ctype (apply #'type-intersection (mapcar #'(lambda (x) @@ -88,8 +88,9 @@ (ctype-of x))) (member-ctype-members ctype)))) (union-ctype - (apply #'type-intersection (mapcar #'simplify-vector-ctype (union-ctype-types ctype)))))) - + (apply #'type-intersection + (mapcar #'simplify-vector-ctype (union-ctype-types ctype)))))) + (defun make-sequence (type length &key (initial-element nil initial-element-p)) "Return a sequence of the given TYPE and LENGTH, with elements initialized to INITIAL-ELEMENT." @@ -845,9 +846,16 @@ (defun coerce (object output-type-spec) "Coerce the Object to an object of type Output-Type-Spec." (let* ((type (specifier-type output-type-spec))) - (if (%typep object type) - object + (macrolet ((check-union-ctype (type) + `(when (union-ctype-p ,type) + (error 'simple-type-error + :format-control "CTYPE too hairy for COERCE: ~S" + :format-arguments (list ,type) + :datum ,type + :expected-type '(not union-ctype))))) (cond + ((%typep object type) + object) ((csubtypep type (specifier-type 'character)) (character object)) ((eq output-type-spec 'standard-char) @@ -865,12 +873,14 @@ ((csubtypep type (specifier-type 'list)) (coerce-to-list object)) ((csubtypep type (specifier-type 'string)) + (check-union-ctype type) (let ((length (array-ctype-length type))) (if (and length (neq length (length object))) (report-bad-arg (make-string length) `(string ,(length object))))) (coerce-to-uarray object #.(type-keyword-code :simple-string) t)) ((csubtypep type (specifier-type 'vector)) + (check-union-ctype type) (let ((length (array-ctype-length type))) (if (and length (neq length (length object))) (error 'invalid-subtype-error @@ -888,21 +898,22 @@ ((csubtypep type (specifier-type 'array)) (let* ((dims (array-ctype-dimensions type))) (when (consp dims) - (when (not (null (cdr dims)))(error "~s is not a sequence type." output-type-spec)))) + (when (not (null (cdr dims))) + (error "~s is not a sequence type." output-type-spec)))) (let ((length (array-ctype-length type))) (if (and length (neq length (length object))) (error "Length of ~s is not ~s." object length))) - (coerce-to-uarray object (element-type-subtype (type-specifier - (array-ctype-element-type type))) t)) + (let ((subtype (element-type-subtype (type-specifier (array-ctype-element-type type))))) + (coerce-to-uarray object subtype t))) ((numberp object) (let ((res - (cond - ((csubtypep type (specifier-type 'double-float)) - (float object 1.0d0)) - ((csubtypep type (specifier-type 'float)) - (float object 1.0s0)) - ((csubtypep type (specifier-type 'complex)) - (coerce-to-complex object (type-specifier type)))))) + (cond + ((csubtypep type (specifier-type 'double-float)) + (float object 1.0d0)) + ((csubtypep type (specifier-type 'float)) + (float object 1.0s0)) + ((csubtypep type (specifier-type 'complex)) + (coerce-to-complex object (type-specifier type)))))) (unless res ;(and res (%typep res type)) (error "~S can't be coerced to type ~S." object output-type-spec)) res)) From 892d1c92ba150002d299ced0f69873121f12adb2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Micha=C5=82=20phoe=20Herda?= Date: Wed, 20 Nov 2019 17:41:45 +0100 Subject: [PATCH 7/9] Replace FORMAT ~F implemenation with SBCL's This commit removes CCL's implementation of ~F FORMAT control and the CCL copy of FLONUM-TO-STRING, replacing these with their respective SBCL counter parts. This was made in order to make all ANSI-TESTs from the FORMAT.F.* group to pass. This commit additionally modifies the internals of PRINT-OBJECT method for floats in order to account for the modified FLONUM-TO-STRING. --- level-1/l1-io.lisp | 30 ++- lib/format.lisp | 472 ++++++++++++++++++++++++--------------------- 2 files changed, 266 insertions(+), 236 deletions(-) diff --git a/level-1/l1-io.lisp b/level-1/l1-io.lisp index d62813bb6..772a02306 100644 --- a/level-1/l1-io.lisp +++ b/level-1/l1-io.lisp @@ -722,23 +722,19 @@ printed using \"#:\" syntax. NIL means no prefix is printed.") (declare (fixnum before-pt)) (let ((strlen (length string))) (declare (fixnum strlen)) - (cond ((zerop strlen) - (stream-write-entire-string stream "0.0")) - ((> before-pt 0) - (cond ((> strlen before-pt) - (write-string string stream :start 0 :end before-pt) - (stream-write-char stream #\.) - (write-string string stream :start before-pt :end strlen)) - (t ; 0's after - (stream-write-entire-string stream string) - (dotimes (i (- before-pt strlen)) - (stream-write-char stream #\0)) - (stream-write-entire-string stream ".0")))) - (t - (stream-write-entire-string stream "0.") - (dotimes (i (- before-pt)) - (stream-write-char stream #\0)) - (stream-write-entire-string stream string))))) + (cond ((<= before-pt 0) + (stream-write-string stream "0") + (dotimes (i (- before-pt)) + (stream-write-char stream #\0)) + (stream-write-string stream string)) + ((> strlen (1+ before-pt)) + (write-string string stream :start 0 :end before-pt) + (write-string string stream :start before-pt :end strlen)) + (t + (stream-write-string stream string) + (dotimes (i (- before-pt strlen)) + (stream-write-char stream #\0)) + (stream-write-string stream "0"))))) (defun print-float-free-form (float stream) (setq stream (%real-print-stream stream)) diff --git a/lib/format.lisp b/lib/format.lisp index 4a66ca044..564653af2 100644 --- a/lib/format.lisp +++ b/lib/format.lisp @@ -1107,7 +1107,6 @@ and (nthcdr *format-arguments-variance* *format-arguments*)") ;;; decimal point. ;;; POINT-POS - The position of the digit preceding the decimal ;;; point. Zero indicates point before first digit. -;;; NZEROS - number of zeros after point ;;; ;;; WARNING: For efficiency, there is a single string object *digit-string* ;;; which is modified destructively and returned as the value of @@ -1141,138 +1140,219 @@ and (nthcdr *format-arguments-variance* *format-arguments*)") Gay: http://citeseer.ist.psu.edu/viewdoc/summary?doi=10.1.1.31.4049 |# -(defun flonum-to-string (n &optional width fdigits scale) - (let ((*print-radix* nil)) - (cond ((zerop n)(values "" 0 0)) - ((and (not (or width fdigits scale)) - (double-float-p n) - ; cheat for the only (?) number that fails to be aesthetically pleasing - (= n 1e23)) - (values "1" 24 23)) - (t (let ((string (make-array 12 :element-type 'base-char - :fill-pointer 0 :adjustable t))) - (multiple-value-bind (sig exp)(integer-decode-float n) - (float-string string sig exp (integer-length sig) width fdigits scale))))))) - -;;; if width given and fdigits nil then if exponent is >= 0 returns at -;;; most width-1 digits if exponent is < 0 returns (- width (- exp) 1) -;;; digits if fdigits given width is ignored, returns fdigits after -;;; (implied) point The Steele/White algorithm can produce a leading -;;; zero for 1e23 which lies exactly between two double floats - -;;; rounding picks the float whose rational is -;;; 99999999999999991611392. This guy wants to print as -;;; 9.999999999999999E+22. The untweaked algorithm generates a leading -;;; zero in this case. (actually wants to print as 1e23!) If we -;;; choose s such that r < s - m/2, and r = s/10 - m/2 (which it does -;;; in this case) then r * 10 < s => first digit is zero and -;;; (remainder (* r 10) s) is r * 10 = new-r, 10 * m = new-m new-r = s -;;; - new-m/2 so high will be false and she won't round up we do r * -;;; (expt 2 (- e (- scale))) and s * (expt 5 (- scale)) i.e. both less -;;; by (expt 2 (- scale)) - -(defun float-string (string f e p &optional width fdigits scale) - (macrolet ((nth-digit (n) `(%code-char (%i+ ,n (%char-code #\0))))) - (let ((r f)(s 1)(m- 1)(m+ 1)(k 0) cutoff roundup (mm nil)) - (when (= f (if (eql p 53) #.(ash 1 52) (ash 1 (1- p)))) - (setq mm t)) - (when (or (null scale)(zerop scale)) - ; approximate k - (let ((fudge 0)) - (setq fudge (truncate (* (%i+ e p) .301))) - (when (neq fudge 0) - (setq k fudge) - (setq scale (- k))))) - (when (and scale (not (eql scale 0))) - (if (minusp scale) - (setq s (* s (5-to-e (- scale)))) - (let ((scale-factor (5-to-e scale))) - (setq r (* r scale-factor)) - (setq m+ scale-factor) - (when mm (setq m- scale-factor))))) - (let ((shift (- e (if scale (- scale) 0)))) - (declare (fixnum shift)) - ;(print (list e scale shift)) - (cond ((> shift 0) - (setq r (ash f shift)) - (setq m+ (ash m+ shift)) - (when mm (setq m- (ash m- shift)))) - ((< shift 0) - (setq s (ash s (- shift)))))) - (when mm - (setq m+ (+ m+ m+)) - (setq r (+ r r)) - (setq s (+ s s))) - (let ((ceil (ceiling s 10))(fudge 1)) - (while (< r ceil) - (setq k (1- k)) - (setq r (* r 10)) - (setq fudge (* fudge 10))) - (when (> fudge 1) - (setq m+ (* m+ fudge)) - (when mm (setq m- (* m- fudge))))) - (let ((2r (+ r r))) - (loop - (let ((2rm+ (+ 2r m+))) - (while - (if (not roundup) ; guarantee no leading zero - (> 2rm+ (+ s s)) - (>= 2rm+ (+ s s))) - (setq s (* s 10)) - (setq k (1+ k)))) - (when (not (or fdigits width))(return)) - (cond - (fdigits (setq cutoff (- fdigits))) - (width - (setq cutoff - (if (< k 0) (- 1 width)(1+ (- k width)))) - ;(if (and fmin (> cutoff (- fmin))) (setq cutoff (- fmin))) - )) - (let ((a (if cutoff (- cutoff k) 0)) - (y s)) - (DECLARE (FIXNUM A)) - (if (>= a 0) - (when (> a 0)(setq y (* y (10-to-e a)))) - (setq y (ceiling y (10-to-e (the fixnum (- a)))))) - (when mm (setq m- (max y m-))) - (setq m+ (max y m+)) - (when (= m+ y) (setq roundup t))) - (when (if (not roundup) ; tweak as above - (<= (+ 2r m+)(+ s s)) - (< (+ 2r m+)(+ s s))) - (return)))) - (let* ((h k) - (half-m+ (* m+ 5)) ; 10 * m+/2 - (half-m- (if mm (* m- 5))) - u high low - ) - ;(print (list r s m+ roundup)) - (unless (and fdigits (>= (- k) fdigits)) - (loop - (setq k (1- k)) - (multiple-value-setq (u r) (truncate (* r 10) s)) - (setq low (< r (if mm half-m- half-m+))) - (setq high - (if (not roundup) - (> r (- s half-m+)) - (>= r (- s half-m+)))) - (if (or low high) - (return) - (progn - (vector-push-extend (nth-digit u) string))) - (when mm (setq half-m- (* half-m- 10) )) - (setq half-m+ (* half-m+ 10))) - ;(print (list r s high low h k)) - (vector-push-extend - (nth-digit (cond - ((and low (not high)) u) - ((and high (not low))(+ u 1)) - - (t ;(and high low) - (if (<= (+ r r) s) u (1+ u))))) - string)) - ; second value is exponent, third is exponent - # digits generated - (values string h k))))) +(defun flonum-to-string (x &optional width fdigits scale fmin) + ;; Wrapper around %FLONUM-TO-STRING, which is a version of FLONUM-TO-STRING adapted + ;; from SBCL. %FLONUM-TO-STRING returns five values. + ;; DIGIT-STRING - The decimal representation of X, with decimal point. + ;; DIGIT-LENGTH - The length of the string DIGIT-STRING. + ;; LEADING-POINT - True if the first character of DIGIT-STRING is the decimal point. + ;; TRAILING-POINT - True if the last character of DIGIT-STRING is the decimal point. + ;; POINT-POS - The position of the digit preceding the decimal + ;; point. Zero indicates point before first digit. + (multiple-value-bind (digit-string digit-length leading-point trailing-point point-pos) + (%flonum-to-string x width fdigits scale fmin) + (declare (ignore trailing-point leading-point)) + (let ((before-pt point-pos) + (after-pt (- (+ 1 point-pos) digit-length))) + (values digit-string before-pt after-pt)))) +(defconstant single-float-min-e + (- 2 ccl::ieee-single-float-bias ccl::ieee-single-float-digits)) +(defconstant double-float-min-e + (- 2 ccl::ieee-double-float-bias ccl::ieee-double-float-digits)) + +(declaim (inline %flonum-to-digits)) +(defun %flonum-to-digits (char-fun + prologue-fun + epilogue-fun + float &optional position relativep) + (let ((print-base 10) ; B + (float-radix 2) ; b + (float-digits (float-digits float)) ; p + (min-e + (etypecase float + (single-float single-float-min-e) + (double-float double-float-min-e)))) + (multiple-value-bind (f e) + (integer-decode-float float) + (let ( ;; FIXME: these even tests assume normal IEEE rounding + ;; mode. I wonder if we should cater for non-normal? + (high-ok (evenp f)) + (low-ok (evenp f))) + (labels ((scale (r s m+ m-) + (do ((r+m+ (+ r m+)) + (k 0 (1+ k)) + (s s (* s print-base))) + ((not (or (> r+m+ s) + (and high-ok (= r+m+ s)))) + (do ((k k (1- k)) + (r r (* r print-base)) + (m+ m+ (* m+ print-base)) + (m- m- (* m- print-base))) + ((not (and (> r m-) ; Extension to handle zero + (let ((x (* (+ r m+) print-base))) + (or (< x s) + (and (not high-ok) + (= x s)))))) + (funcall prologue-fun k) + (generate r s m+ m-) + (funcall epilogue-fun k)))))) + (generate (r s m+ m-) + (let (d tc1 tc2) + (tagbody + loop + (setf (values d r) (truncate (* r print-base) s)) + (setf m+ (* m+ print-base)) + (setf m- (* m- print-base)) + (setf tc1 (or (< r m-) (and low-ok (= r m-)))) + (setf tc2 (let ((r+m+ (+ r m+))) + (or (> r+m+ s) + (and high-ok (= r+m+ s))))) + (when (or tc1 tc2) + (go end)) + (funcall char-fun d) + (go loop) + end + (let ((d (cond + ((and (not tc1) tc2) (1+ d)) + ((and tc1 (not tc2)) d) + ((< (* r 2) s) + d) + (t + (1+ d))))) + (funcall char-fun d))))) + (initialize () + (let (r s m+ m-) + (cond ((>= e 0) + (let ((be (expt float-radix e))) + (if (/= f (expt float-radix (1- float-digits))) + ;; multiply F by 2 first, avoding consing two bignums + (setf r (* f 2 be) + s 2 + m+ be + m- be) + (setf m- be + m+ (* be float-radix) + r (* f 2 m+) + s (* float-radix 2))))) + ((or (= e min-e) + (/= f (expt float-radix (1- float-digits)))) + (setf r (* f 2) + s (expt float-radix (- 1 e)) + m+ 1 + m- 1)) + (t + (setf r (* f float-radix 2) + s (expt float-radix (- 2 e)) + m+ float-radix + m- 1))) + (when position + (when relativep + (do ((k 0 (1+ k)) + ;; running out of letters here + (l 1 (* l print-base))) + ((>= (* s l) (+ r m+)) + ;; k is now \hat{k} + (if (< (+ r (* s (/ (expt print-base (- k position)) 2))) + (* s l)) + (setf position (- k position)) + (setf position (- k position 1)))))) + (let* ((x (/ (* s (expt print-base position)) 2)) + (low (max m- x)) + (high (max m+ x))) + (when (<= m- low) + (setf m- low) + (setf low-ok t)) + (when (<= m+ high) + (setf m+ high) + (setf high-ok t)))) + (values r s m+ m-)))) + (multiple-value-bind (r s m+ m-) (initialize) + (scale r s m+ m-))))))) + +(defun flonum-to-digits (float &optional position relativep) + (let ((digit-characters "0123456789")) + (let* ((result-size 28) + (result-string (make-array result-size :element-type 'base-char)) + (pointer 0)) + (declare (type (integer 0 #.array-dimension-limit) result-size) + (type (integer 0 #.(1- array-dimension-limit)) pointer) + (type (simple-array base-char (*)) result-string)) + (flet ((push-char (char) + (when (= pointer result-size) + (let ((old result-string)) + (setf result-size (* 2 (+ result-size 2)) + result-string + (make-array result-size :element-type 'base-char)) + (replace result-string old))) + (setf (char result-string pointer) char) + (incf pointer)) + (get-pushed-string nil + (let ((string result-string) (size pointer)) + (setf result-size 0 pointer 0 result-string "") + (ccl::shrink-vector string size) + string))) + (%flonum-to-digits + (lambda (d) (push-char (char digit-characters d))) + (lambda (k) k) + (lambda (k) (values k (get-pushed-string))) + float + position + relativep))))) + +(defun %flonum-to-string (x &optional width fdigits scale fmin) + (declare (type float x)) + (multiple-value-bind (e string) + (if fdigits + (flonum-to-digits x (min (- (+ fdigits (or scale 0))) + (- (or fmin 0)))) + (if (and width (> width 1)) + (let ((w (multiple-value-list + (flonum-to-digits x + (max 1 + (+ (1- width) + (if (and scale (minusp scale)) + scale 0))) + t))) + (f (multiple-value-list + (flonum-to-digits x (- (+ 1 (or fmin 0) + (if scale scale 0))))))) + (if (>= (length (cadr w)) (length (cadr f))) + (values-list w) + (values-list f))) + (flonum-to-digits x))) + (let ((e (if (zerop x) + e + (+ e (or scale 0)))) + (stream (make-string-output-stream))) + (if (plusp e) + (progn + (write-string string stream :end (min (length string) e)) + (dotimes (i (- e (length string))) + (write-char #\0 stream)) + (write-char #\. stream) + (write-string string stream :start (min (length string) e)) + (when fdigits + (dotimes (i (- fdigits + (- (length string) + (min (length string) e)))) + (write-char #\0 stream)))) + (progn + (write-string "." stream) + (dotimes (i (- e)) + (write-char #\0 stream)) + (write-string string stream :end (when fdigits + (min (length string) + (max (or fmin 0) + (+ fdigits e))))) + (when fdigits + (dotimes (i (+ fdigits e (- (length string)))) + (write-char #\0 stream))))) + (let ((string (get-output-stream-string stream))) + (values string (length string) + (char= (char string 0) #\.) + (char= (char string (1- (length string))) #\.) + (position #\. string)))))) (defparameter integer-powers-of-10 (make-array (+ 12 (floor 324 12)))) @@ -1820,96 +1900,50 @@ and (nthcdr *format-arguments-variance* *format-arguments*)") (let ((*print-base* 10)) (format-write-field stream (princ-to-string number) w 1 0 #\space t))))))) -; do something ad hoc if d > w - happens if (format nil "~15g" (- 2.3 .1)) -; called with w = 11 d = 16 - dont do it after all. - (defun format-fixed-aux (stream number w d k ovf pad atsign) - (and w (<= w 0) (setq w nil)) ; if width is unreasonable, ignore it. - (if (and (not k) - (not (or w d))) - (print-float-free-form number stream) - (let ((spaceleft w) - (abs-number (abs number)) - strlen zsuppress flonum-to-string-width) - (when (and w (or atsign (minusp number))) + (declare (type float number)) + (if (ccl::nan-or-infinity-p number) + (prin1 number stream) + (let ((spaceleft w)) + (when (and w (or atsign (minusp (float-sign number)))) (decf spaceleft)) - (when (and d w (<= w (+ 1 d (if atsign 1 0)))) - (setq zsuppress t)) - (when (and d (minusp d)) - (format-error "Illegal value for d")) - (setq flonum-to-string-width - (and w - (if (and (< abs-number 1) (not zsuppress)) - (1- spaceleft) ; room for leading 0 - spaceleft))) - (when (and w (not (plusp flonum-to-string-width))) - (if ovf - (progn - (dotimes (i w) (write-char ovf stream)) - (return-from format-fixed-aux)) - (setq spaceleft nil w nil flonum-to-string-width nil))) - (multiple-value-bind (str before-pt after-pt) - (flonum-to-string abs-number - flonum-to-string-width - d k) - (setq strlen (length str)) - (cond (w (decf spaceleft (+ (max before-pt 0) 1)) - (when (and (< before-pt 1) (not zsuppress)) - (decf spaceleft)) - (if d - (decf spaceleft d) - (setq d (max (min spaceleft (- after-pt)) - (if (> spaceleft 0) 1 0)) - spaceleft (- spaceleft d)))) - ((null d) (setq d (max (- after-pt) 1)))) + (multiple-value-bind (str len lpoint tpoint) + (%flonum-to-string (abs number) spaceleft d k) + ;; if caller specifically requested no fraction digits, suppress the + ;; optional trailing zero + (when (and d (zerop d)) + (setq tpoint nil)) + (when w + (decf spaceleft len) + ;; optional leading zero + (when lpoint + (if (or (> spaceleft 0) tpoint) ;force at least one digit + (decf spaceleft) + (setq lpoint nil))) + ;; optional trailing zero + (when tpoint + (if (or t (> spaceleft 0)) + (decf spaceleft) + (setq tpoint nil)))) (cond ((and w (< spaceleft 0) ovf) - ;;field width overflow - (dotimes (i w) (declare (fixnum i)) (write-char ovf stream))) - (t (when w (dotimes (i spaceleft) (declare (fixnum i)) (write-char pad stream))) - (if (minusp (float-sign number)) ; 5/25 - (write-char #\- stream) - (if atsign (write-char #\+ stream))) - (cond - ((> before-pt 0) - (cond ((> strlen before-pt) - (write-string str stream :start 0 :end before-pt) - (write-char #\. stream) - (write-string str stream :start before-pt :end strlen) - (dotimes (i (- d (- strlen before-pt))) - (write-char #\0 stream))) - (t ; 0's after - (stream-write-entire-string stream str) - (dotimes (i (- before-pt strlen)) - (write-char #\0 stream)) - (write-char #\. stream) - (dotimes (i d) - (write-char #\0 stream))))) - (t (unless zsuppress (write-char #\0 stream)) - (write-char #\. stream) - (dotimes (i (- before-pt)) - (write-char #\0 stream)) - (stream-write-entire-string stream str) - (dotimes (i (+ d after-pt)) - (write-char #\0 stream)))))))))) -#| -; (format t "~7,3,-2f" 8.88) -; (format t "~10,5,2f" 8.88) -; (format t "~10,5,-2f" 8.88) -; (format t "~10,5,2f" 0.0) -; (format t "~10,5,2f" 9.999999999) -; (format t "~7,,,-2e" 8.88) s.b. .009e+3 ?? -; (format t "~10,,2f" 8.88) -; (format t "~10,,-2f" 8.88) -; (format t "~10,,2f" 0.0) -; (format t "~10,,2f" 0.123454) -; (format t "~10,,2f" 9.9999999) - (defun foo (x) - (format nil "~6,2f|~6,2,1,'*f|~6,2,,'?f|~6f|~,2f|~F" - x x x x x x)) - -|# - - + ;; field width overflow + (dotimes (i w) + (write-char ovf stream)) + t) + (t + (when w + (dotimes (i spaceleft) + (write-char pad stream))) + (if (minusp (float-sign number)) + (write-char #\- stream) + (when atsign + (write-char #\+ stream))) + (when lpoint + (write-char #\0 stream)) + (write-string str stream) + (when tpoint + (write-char #\0 stream)) + nil)))))) ;;; Exponential-format floating point ~E From 1ec5441276e7f35175683e49f61d27b3ac454016 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Micha=C5=82=20phoe=20Herda?= Date: Thu, 21 Nov 2019 15:32:54 +0100 Subject: [PATCH 8/9] Fix ANSI-TEST FORMAT.F.45 CCL incorrectly formatted (format nil "~2f ~2f" 1.1 1.9) - the proper result is "1.0 2.0" due to the reasoning provided in ANSI-TEST: Rationale for FORMAT.F.45: CLHS 22.3.3.1 states that "d is the number of digits to print after the decimal point;" AND that the number is printed "rounded to d fractional digits". If we want to print 1.1 in a field of width 0, then we compute D to be W, minus the number of digits to be printed before the decimal point, minus 1 for the decimal point. So, in this case, D = W - 1 - 1 = 0. This means that we must print exactly 0 digits after the decimal point and that we must round the number to 0 fractional digits. The latter is doable and we round 1.1 to 1.0, BUT the first contradicts the first paragraph of 22.3.3.1 which states, "arg is printed as a float". "1." is not a float in Common Lisp, since it is read as the integer 1 in base 10. Therefore, in order to work around this corner case, we explicitly print one decimal digit so that the resulting number is recognizable as a float. Since the number was rounded to 0 decimal digits, then this digit is 0. This way, we get "1." concatenated with "0" that gives us "1.0". --- lib/format.lisp | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/lib/format.lisp b/lib/format.lisp index 564653af2..98fc38271 100644 --- a/lib/format.lisp +++ b/lib/format.lisp @@ -1317,7 +1317,8 @@ and (nthcdr *format-arguments-variance* *format-arguments*)") (f (multiple-value-list (flonum-to-digits x (- (+ 1 (or fmin 0) (if scale scale 0))))))) - (if (>= (length (cadr w)) (length (cadr f))) + (if (or (>= (length (cadr w)) (length (cadr f))) + (>= (length (cadr f)) width)) (values-list w) (values-list f))) (flonum-to-digits x))) From a732bb90b5beb8839676982d482ca985fc6f8961 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Micha=C5=82=20phoe=20Herda?= Date: Thu, 21 Nov 2019 16:32:47 +0100 Subject: [PATCH 9/9] Fix ANSI-TEST FORMAT.F.46 CCL incorrectly printed 0.01 with ~1f and ~0f as ".01", where the correct value is ".0". This commit fixes this bug. --- lib/format.lisp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/format.lisp b/lib/format.lisp index 98fc38271..b4c282143 100644 --- a/lib/format.lisp +++ b/lib/format.lisp @@ -1306,7 +1306,7 @@ and (nthcdr *format-arguments-variance* *format-arguments*)") (if fdigits (flonum-to-digits x (min (- (+ fdigits (or scale 0))) (- (or fmin 0)))) - (if (and width (> width 1)) + (if width (let ((w (multiple-value-list (flonum-to-digits x (max 1