*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
(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).
(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 #\[)
;; 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]~]"
(/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))
(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))
(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))))
(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)))
(write '`(lambda (,x)) :stream s :pretty t :readably t))
"`(LAMBDA (,X))"))
\f
-;;; 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)))
(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)
;;; 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"
projects / sbcl.git / commitdiff