From: Alexey Dejneka Date: Sun, 9 May 2004 17:12:13 +0000 (+0000) Subject: 0.8.10.15: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=c0ea1cc4a9f928184b7a7ee65c396b79f1b9ff45;p=sbcl.git 0.8.10.15: * Fix bug MISC.110A: pathwise CAST remover forgot to mark LVARs for reoptimization; * merge patch by Nikodemus Siivola: SET-PPRINT-DISPATCH does not immediately resolves function names; * fix bug reported by Thomas F. Burdick: compile-time format string checker failed when ~{ did not have the corresponding ~}. --- diff --git a/NEWS b/NEWS index 6be01de..1ded01c 100644 --- a/NEWS +++ b/NEWS @@ -2418,12 +2418,17 @@ changes in sbcl-0.8.11 relative to sbcl-0.8.10: *PRINT-READABLY* is true, signal PRINT-NOT-READABLE if the string does not have array-element-type equal to the most general string type. + * fixed bug: SET-PPRINT-DISPATCH does not immediately resolve + function name. (thanks to Nikodemus Siivola) + * fixed bug:: compile-time format string checker failed on + non-closed ~{. (reported by Thomas F Burdick) * optimization: rearranged the expansion of various defining macros so that each expands into only one top-level form in a :LOAD-TOPLEVEL context; this appears to decrease fasl sizes by approximately 10%. * fixed some bugs revealed by Paul Dietz' test suite: ** FILE-POSITION works as specified on BROADCAST-STREAMs. + ** CAST optimizer forgot to flush argument derived type. planned incompatible changes in 0.8.x: * (not done yet, but planned:) When the profiling interface settles diff --git a/src/code/late-format.lisp b/src/code/late-format.lisp index bd61b58..7d4095e 100644 --- a/src/code/late-format.lisp +++ b/src/code/late-format.lisp @@ -1269,7 +1269,9 @@ (let ((*default-format-error-offset* (1- (format-directive-end iteration)))) (let* ((close (find-directive directives #\} nil)) - (posn (position close directives)) + (posn (or (position close directives) + (error 'format-error + :complaint "no corresponding close brace"))) (remaining (nthcdr (1+ posn) directives))) ;; FIXME: if POSN is zero, the next argument must be ;; a format control (either a function or a string). @@ -1298,6 +1300,7 @@ (unless (format-directive-colonp directive) (incf-both))) ((or (find c "IT%&|_();>") (char= c #\Newline))) + ;; FIXME: check correspondence of ~( and ~) ((char= c #\<) (walk-complex-directive walk-justification)) ((char= c #\[) diff --git a/src/code/pprint.lisp b/src/code/pprint.lisp index b9beee2..bc3dc84 100644 --- a/src/code/pprint.lisp +++ b/src/code/pprint.lisp @@ -806,7 +806,7 @@ ;; T iff one of the original entries. (initial-p *building-initial-table* :type (member t nil)) ;; and the associated function - (fun (missing-arg) :type function)) + (fun (missing-arg) :type callable)) (def!method print-object ((entry pprint-dispatch-entry) stream) (print-unreadable-object (entry stream :type t) (format stream "type=~S, priority=~S~@[ [initial]~]" @@ -924,37 +924,32 @@ (/show0 "entering SET-PPRINT-DISPATCH, TYPE=...") (/hexstr type) (if function - ;; KLUDGE: this impairs debuggability, and probably isn't even - ;; conforming -- maybe we should not coerce to function, but - ;; cater downstream (in PPRINT-DISPATCH-ENTRY) for having - ;; callables here. - (let ((function (%coerce-callable-to-fun function))) - (if (cons-type-specifier-p type) - (setf (gethash (second (second type)) - (pprint-dispatch-table-cons-entries table)) - (make-pprint-dispatch-entry :type type - :priority priority - :fun function)) - (let ((list (delete type (pprint-dispatch-table-entries table) - :key #'pprint-dispatch-entry-type - :test #'equal)) - (entry (make-pprint-dispatch-entry - :type type - :test-fn (compute-test-fn type) - :priority priority - :fun function))) - (do ((prev nil next) - (next list (cdr next))) - ((null next) - (if prev - (setf (cdr prev) (list entry)) - (setf list (list entry)))) - (when (entry< (car next) entry) - (if prev - (setf (cdr prev) (cons entry next)) - (setf list (cons entry next))) - (return))) - (setf (pprint-dispatch-table-entries table) list)))) + (if (cons-type-specifier-p type) + (setf (gethash (second (second type)) + (pprint-dispatch-table-cons-entries table)) + (make-pprint-dispatch-entry :type type + :priority priority + :fun function)) + (let ((list (delete type (pprint-dispatch-table-entries table) + :key #'pprint-dispatch-entry-type + :test #'equal)) + (entry (make-pprint-dispatch-entry + :type type + :test-fn (compute-test-fn type) + :priority priority + :fun function))) + (do ((prev nil next) + (next list (cdr next))) + ((null next) + (if prev + (setf (cdr prev) (list entry)) + (setf list (list entry)))) + (when (entry< (car next) entry) + (if prev + (setf (cdr prev) (cons entry next)) + (setf list (cons entry next))) + (return))) + (setf (pprint-dispatch-table-entries table) list))) (if (cons-type-specifier-p type) (remhash (second (second type)) (pprint-dispatch-table-cons-entries table)) diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp index 988348d..3a5b8f1 100644 --- a/src/compiler/ir1opt.lisp +++ b/src/compiler/ir1opt.lisp @@ -1752,7 +1752,9 @@ (unless next-block (when ctran (ensure-block-start ctran)) (setq next-block (first (block-succ (node-block cast)))) - (ensure-block-start (node-prev cast))) + (ensure-block-start (node-prev cast)) + (reoptimize-lvar lvar) + (setf (lvar-%derived-type value) nil)) (%delete-lvar-use use) (add-lvar-use use lvar) (unlink-blocks (node-block use) (node-block cast)) diff --git a/src/compiler/ltn.lisp b/src/compiler/ltn.lisp index 552f50d..751d204 100644 --- a/src/compiler/ltn.lisp +++ b/src/compiler/ltn.lisp @@ -313,8 +313,7 @@ (setf (node-tail-p call) nil)) (t (setf (basic-combination-info call) :full) - (annotate-fun-lvar (basic-combination-fun call) - nil) + (annotate-fun-lvar (basic-combination-fun call) nil) (dolist (arg (reverse args)) (annotate-unknown-values-lvar arg)) (flush-full-call-tail-transfer call)))) diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp index a0715b7..dcf5fb5 100644 --- a/tests/compiler.pure.lisp +++ b/tests/compiler.pure.lisp @@ -1329,3 +1329,21 @@ (debug 3) (compilation-speed 3))) (flet ((%f () (multiple-value-prog1 0 (return-from %f 0)))) (complex (%f) 0))))))) + +;;; MISC.110A: CAST optimizer forgot to flush LVAR derived type +(assert (zerop (funcall + (compile + nil + '(lambda (a c) + (declare (type (integer -1294746569 1640996137) a)) + (declare (type (integer -807801310 3) c)) + (declare (optimize (speed 3) (space 3) (safety 0) (debug 0) (compilation-speed 3))) + (catch 'ct7 + (if + (logbitp 0 + (if (/= 0 a) + c + (ignore-errors + (progn (if (ldb-test (byte 0 0) (rational (throw 'ct7 0))) 0 0) 0)))) + 0 0)))) + 391833530 -32785211))) diff --git a/tests/pprint.impure.lisp b/tests/pprint.impure.lisp index a88e54a..5317d7a 100644 --- a/tests/pprint.impure.lisp +++ b/tests/pprint.impure.lisp @@ -136,10 +136,11 @@ (write '`(lambda (,x)) :stream s :pretty t :readably t)) "`(LAMBDA (,X))")) -;;; SET-PPRINT-DISPATCH should accept function name arguments +;;; SET-PPRINT-DISPATCH should accept function name arguments, and not +;;; rush to coerce them to functions. +(set-pprint-dispatch '(cons (eql frob)) 'ppd-function-name) (defun ppd-function-name (s o) (print (length o) s)) -(set-pprint-dispatch '(cons (eql frob)) 'ppd-function-name) (let ((s (with-output-to-string (s) (pprint '(frob a b) s)))) (assert (position #\3 s))) diff --git a/tests/print.impure.lisp b/tests/print.impure.lisp index 510a6b1..2ccd7ff 100644 --- a/tests/print.impure.lisp +++ b/tests/print.impure.lisp @@ -213,5 +213,12 @@ (let ((answer (write-to-string '(bar foo :boo 1) :pretty t :escape t))) (assert (string= answer "(?BAR? ?FOO? ?:BOO? ?1?)"))))) +;;; FORMAT string compile-time checker failure, reported by Thomas +;;; F. Burdick +(multiple-value-bind (f w-p f-p) + (compile nil '(lambda () (format nil "~{"))) + (assert (and w-p f-p)) + (assert (nth-value 1 (ignore-errors (funcall f))))) + ;;; success (quit :unix-status 104) diff --git a/version.lisp-expr b/version.lisp-expr index 8800525..252a5da 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.8.10.14" +"0.8.10.15"