:SB-PROPAGATE-FUN-TYPE are no longer considered to be optional
features. Instead, the code that they used to control is always
built into the system.
-?? minor incompatible change: The debugger prompt sequence now goes
+* minor incompatible change: The debugger prompt sequence now goes
"5]", "5[2]", "5[3]", etc. as you get deeper into recursive calls
to the debugger command loop, instead of the old "5]", "5]]",
"5]]]" sequence. (I was motivated to do this when squabbles between
favor of new corresponding names DEFINE-FOO, for consistency with
the naming convention used in the ANSI standard (DEFSTRUCT, DEFVAR,
DEFINE-CONDITION, DEFINE-MODIFY-MACRO..). This mostly affects
- internal symbols, but a few external symbols like
+ internal symbols, but a few supported extensions like
SB-ALIEN:DEF-ALIEN-FUNCTION are also affected.
* minor incompatible change: DEFINE-ALIEN-FUNCTION (also known by
the old deprecated name DEF-ALIEN-FUNCTION) now does DECLAIM FTYPE
EVAL/EVAL-WHEN/%COMPILE/DEFUN/DEFSTRUCT cleanup:
** made inlining DEFUN inside MACROLET work again
* incompatible changes listed in NEWS:
- ** changed debugger prompt to "5]", "5[2]", "5[3]", etc.
** changed default output representation of *PRINT-ESCAPE*-ed
unprintable ASCII characters to #\Nul, #\Soh, etc.
-* some easy FIXMEs with high disruptive potential:
- ** Search lists go away.
- ** Grep for ~D and and change most of them to ~S.
* more renaming in global external names:
** used DEFINE-THE-FOO-THING and DEFFOO style consistently (and
deprecated supported extensions named in the DEF-FOO
(error "can't specify both :INITIAL-ELEMENT and ~
:INITIAL-CONTENTS"))
(unless (= length (length initial-contents))
- (error "There are ~D elements in the :INITIAL-CONTENTS, but ~
- the vector length is ~D."
+ (error "There are ~W elements in the :INITIAL-CONTENTS, but ~
+ the vector length is ~W."
(length initial-contents)
length))
(replace array initial-contents))
(unless (and (fixnump fill-pointer)
(>= fill-pointer 0)
(<= fill-pointer length))
- (error "invalid fill-pointer ~D"
- fill-pointer))
+ ;; FIXME: should be TYPE-ERROR?
+ (error "invalid fill-pointer ~W"
+ fill-pointer))
fill-pointer))))
(setf (%array-fill-pointer-p array) t))
(t
(t
(unless (typep contents 'sequence)
(error "malformed :INITIAL-CONTENTS: ~S is not a ~
- sequence, but ~D more layer~:P needed."
+ sequence, but ~W more layer~:P needed."
contents
(- (length dimensions) axis)))
(unless (= (length contents) (car dims))
(error "malformed :INITIAL-CONTENTS: Dimension of ~
- axis ~D is ~D, but ~S is ~D long."
+ axis ~W is ~W, but ~S is ~W long."
axis (car dims) contents (length contents)))
(if (listp contents)
(dolist (content contents)
(list subscripts))
(let ((rank (array-rank array)))
(unless (= rank (length subscripts))
- (error "wrong number of subscripts, ~D, for array of rank ~D"
+ (error "wrong number of subscripts, ~W, for array of rank ~W"
(length subscripts) rank))
(if (array-header-p array)
(do ((subs (nreverse subscripts) (cdr subs))
(declare (fixnum index dim))
(unless (< -1 index dim)
(if invalid-index-error-p
- (error "invalid index ~D~[~;~:; on axis ~:*~D~] in ~S"
+ (error "invalid index ~W~[~;~:; on axis ~:*~W~] in ~S"
index axis array)
(return-from %array-row-major-index nil)))
(incf result (* chunk-size index))
(let ((index (first subscripts)))
(unless (< -1 index (length (the (simple-array * (*)) array)))
(if invalid-index-error-p
- (error "invalid index ~D in ~S" index array)
+ (error "invalid index ~W in ~S" index array)
(return-from %array-row-major-index nil)))
index))))
(error "Vector axis is not zero: ~S" axis-number))
(length (the (simple-array * (*)) array)))
((>= axis-number (%array-rank array))
- (error "~D is too big; ~S only has ~D dimension~:P."
+ (error "Axis number ~W is too big; ~S only has ~D dimension~:P."
axis-number array (%array-rank array)))
(t
(%array-dimension array axis-number))))
(let ((old-length (layout-length old-layout)))
(unless (= old-length length)
(warn "change in instance length of class ~S:~% ~
- ~A length: ~D~% ~
- ~A length: ~D"
+ ~A length: ~W~% ~
+ ~A length: ~W"
name
old-context old-length
context length)
(:report
(lambda (condition stream)
(let ((error-stream (stream-error-stream condition)))
- (format stream "READER-ERROR ~@[at ~D ~]on ~S:~%~?"
+ (format stream "READER-ERROR ~@[at ~W ~]on ~S:~%~?"
(file-position error-stream) error-stream
(reader-error-format-control condition)
(reader-error-format-arguments condition))))))
(def!method print-object ((debug-var debug-var) stream)
(print-unreadable-object (debug-var stream :type t :identity t)
(format stream
- "~S ~D"
+ "~S ~W"
(debug-var-symbol debug-var)
(debug-var-id debug-var))))
(defun assign-minimal-var-names (vars)
(declare (simple-vector vars))
(let* ((len (length vars))
- (width (length (format nil "~D" (1- len)))))
+ (width (length (format nil "~W" (1- len)))))
(dotimes (i len)
(setf (compiled-debug-var-symbol (svref vars i))
(intern (format nil "ARG-~V,'0D" width i)
(do-debug-fun-blocks (block debug-fun)
(do-debug-block-locations (loc block)
(fill-in-code-location loc)
- (format t "~S code location at ~D"
+ (format t "~S code location at ~W"
(compiled-code-location-kind loc)
(compiled-code-location-pc loc))
(sb!debug::print-code-location-source-form loc 0)
"Should the debugger display beginner-oriented help messages?")
(defun debug-prompt (stream)
-
- ;; old behavior, will probably go away in sbcl-0.7.x
- (format stream "~%~D" (sb!di:frame-number *current-frame*))
- (dotimes (i *debug-command-level*)
- (write-char #\] stream))
- (write-char #\space stream)
-
- ;; planned new behavior, delayed since it will break ILISP
- #+nil
(format stream
- "~%~D~:[~;[~D~]] "
+ "~%~W~:[~;[~W~]] "
(sb!di:frame-number *current-frame*)
(> *debug-command-level* 1)
*debug-command-level*))
(let ((level *debug-command-level*)
(restart-commands (make-restart-commands)))
(with-simple-restart (abort
- "Reduce debugger level (to debug level ~D)."
+ "Reduce debugger level (to debug level ~W)."
level)
(debug-prompt *debug-io*)
(force-output *debug-io*)
(let ((v (find id vars :key #'sb!di:debug-var-id)))
(unless v
(error
- "invalid variable ID, ~D: should have been one of ~S"
+ "invalid variable ID, ~W: should have been one of ~S"
id
(mapcar #'sb!di:debug-var-id vars)))
,(ecase ref-or-set
(let* ((name
(if (symbolp form)
(symbol-name form)
- (format nil "~D" form)))
+ (format nil "~W" form)))
(len (length name))
(res nil))
(declare (simple-string name)
#'(lambda ()
(/show0 "in restart-command closure, about to i-r-i")
(invoke-restart-interactively restart))))
- (push (cons (format nil "~d" num) restart-fun) commands)
+ (push (cons (prin1-to-string num) restart-fun) commands)
(unless (or (null (restart-name restart))
(find name commands :key #'car :test #'string=))
(push (cons name restart-fun) commands))))
(setf any-p t)
(when (eq (sb!di:debug-var-validity v location) :valid)
(setf any-valid-p t)
- (format t "~S~:[#~D~;~*~] = ~S~%"
+ (format t "~S~:[#~W~;~*~] = ~S~%"
(sb!di:debug-var-symbol v)
(zerop (sb!di:debug-var-id v))
(sb!di:debug-var-id v)
(when prev-location
(let ((this-num (1- this-num)))
(if (= prev-num this-num)
- (format t "~&~D: " prev-num)
- (format t "~&~D-~D: " prev-num this-num)))
+ (format t "~&~W: " prev-num)
+ (format t "~&~W-~W: " prev-num this-num)))
(print-code-location-source-form prev-location 0)
(when *print-location-kind*
(format t "~S " (sb!di:code-location-kind prev-location)))
cost)
total-cost))
(when (zerop (decf counter))
- (format t "[End of top ~D]~%" cut-off))))))
+ (format t "[End of top ~W]~%" cut-off))))))
;;; Divide SORTED into two lists, the first CUT-OFF elements long. Any VOP
;;; names that match one of the report strings are moved into the REPORT list
(n-cache (gensym)))
(unless (= (length default-values) values)
- (error "The number of default values ~S differs from :VALUES ~D."
+ (error "The number of default values ~S differs from :VALUES ~W."
default values))
(collect ((inlines)
input-buffer-p
(name (if file
(format nil "file ~S" file)
- (format nil "descriptor ~D" fd)))
+ (format nil "descriptor ~W" fd)))
auto-close)
(declare (type index fd) (type (or index null) timeout)
(type (member :none :line :full) buffering))
(lambda ()
(sb!unix:unix-close fd)
#!+sb-show
- (format *terminal-io* "** closed file descriptor ~D **~%"
+ (format *terminal-io* "** closed file descriptor ~W **~%"
fd))))
stream))
(declare (ignorable arg))
#!+sb-show
(when *show-fop-nop4-p*
- (format *debug-io* "~&/FOP-NOP4 ARG=~D=#X~X~%" arg arg))))
+ (format *debug-io* "~&/FOP-NOP4 ARG=~W=#X~X~%" arg arg))))
(define-fop (fop-nop 0 :nope))
(define-fop (fop-pop 1 nil) (push-fop-table (pop-stack)))
*soft-heap-limit*)))
(when soft-heap-limit-exceeded?
(cerror "Continue with GC."
- "soft heap limit exceeded (temporary new limit=~D)"
+ "soft heap limit exceeded (temporary new limit=~W)"
*soft-heap-limit*))
(when (and *gc-trigger* (> pre-gc-dynamic-usage *gc-trigger*))
(setf *need-to-collect-garbage* t))
#!+alpha (64 'sap-ref-64)))))
(if ref-fun
`(,ref-fun ,sap (/ ,offset sb!vm:n-byte-bits))
- (error "cannot extract ~D bit integers"
+ (error "cannot extract ~W-bit integers"
(alien-integer-type-bits type)))))
\f
;;;; the BOOLEAN type
(format s "~%The object contains nothing to inspect.~%")
(return-from %inspect (reread)))
(t
- (format s "~%Enter a valid index (~:[0-~D~;0~]).~%"
+ (format s "~%Enter a valid index (~:[0-~W~;0~]).~%"
(= elements-length 1) (1- elements-length))
(return-from %inspect (reread))))))
(symbol
(defmethod inspected-parts ((object vector))
(values (format nil
- "The object is a ~:[~;displaced ~]VECTOR of length ~D.~%"
+ "The object is a ~:[~;displaced ~]VECTOR of length ~W.~%"
(and (array-header-p object)
(%array-displaced-p object))
(length object))
(multiple-value-bind (q r) (floor index dim)
(setq index q)
(push r list)))
- (format nil "[~D~{,~D~}]" (car list) (cdr list)))))
+ (format nil "[~W~{,~W~}]" (car list) (cdr list)))))
(defmethod inspected-parts ((object array))
(let* ((length (min (array-total-size object) *inspect-length*))
(deferr invalid-array-index-error (array bound index)
(error 'simple-error
:format-control
- "invalid array index ~D for ~S (should be nonnegative and <~D)"
+ "invalid array index ~W for ~S (should be nonnegative and <~W)"
:format-arguments (list index array bound)))
(deferr object-not-simple-array-error (object)
(cond ((null handler)
(error 'simple-error
:format-control
- "unknown internal error, ~D? args=~S"
+ "unknown internal error, ~D, args=~S"
:format-arguments
(list error-number
(mapcar #'(lambda (sc-offset)
(error
'format-error
:complaint
- "too many parameters, expected no more than ~D"
+ "too many parameters, expected no more than ~W"
:arguments (list ,(length specs))
:offset (caar ,params)))
,,@body)))
`(if (<= 0 ,posn (length orig-args))
(setf args (nthcdr ,posn orig-args))
(error 'format-error
- :complaint "Index ~D out of bounds. Should have been ~
- between 0 and ~D."
+ :complaint "Index ~W out of bounds. Should have been ~
+ between 0 and ~W."
:arguments (list ,posn (length orig-args))
:offset ,(1- end)))))
(if colonp
(setf args (nthcdr new-posn orig-args))
(error 'format-error
:complaint
- "Index ~D is out of bounds; should have been ~
- between 0 and ~D."
+ "Index ~W is out of bounds; should have been ~
+ between 0 and ~W."
:arguments
(list new-posn (length orig-args))
:offset ,(1- end)))))))
(flet ((check-version (variant possible-implementation needed-version)
(when (string= possible-implementation implementation)
(unless (= version needed-version)
- (error "~@<~S is in ~A fasl file format version ~D, ~
+ (error "~@<~S is in ~A fasl file format version ~W, ~
but this version of SBCL uses ~
- format version ~D.~:@>"
+ format version ~W.~:@>"
stream
variant
version
(dolist (entry *traced-entries*)
(when (cdr entry) (incf depth)))
(format t
- "~@V,0T~D: "
+ "~@V,0T~W: "
(+ (mod (* depth *trace-indentation-step*)
(- *max-trace-indentation* *trace-indentation-step*))
*trace-indentation-step*)
(arg-count-error-argument condition)
(arg-count-error-lambda-list condition))
(cond ((null (arg-count-error-maximum condition))
- (format stream "at least ~D expected"
+ (format stream "at least ~W expected"
(arg-count-error-minimum condition)))
((= (arg-count-error-minimum condition)
(arg-count-error-maximum condition))
- (format stream "exactly ~D expected"
+ (format stream "exactly ~W expected"
(arg-count-error-minimum condition)))
(t
- (format stream "between ~D and ~D expected"
+ (format stream "between ~W and ~W expected"
(arg-count-error-minimum condition)
(arg-count-error-maximum condition))))
- (format stream ", but ~D found"
+ (format stream ", but ~W found"
(length (arg-count-error-argument condition))))))
(define-condition defmacro-ll-broken-key-list-error
(format t "~%~A:~% ~:D bytes, ~:D object~:P"
name total-bytes total-objects)
(dolist (space (spaces))
- (format t ", ~D% ~(~A~)"
+ (format t ", ~W% ~(~A~)"
(round (* (cdr space) 100) total-bytes)
(car space)))
(format t ".~%")
#.instance-header-widetag)
(incf descriptor-words (truncate size n-word-bytes)))
(t
- (error "bogus type: ~D" type))))
+ (error "bogus widetag: ~W" type))))
space))
(format t "~:D words allocated for descriptor objects.~%"
descriptor-words)
;;; TOP-N types with largest usage.
(defun instance-usage (space &key (top-n 15))
(declare (type spaces space) (type (or fixnum null) top-n))
- (format t "~2&~@[Top ~D ~]~(~A~) instance types:~%" top-n space)
+ (format t "~2&~@[Top ~W ~]~(~A~) instance types:~%" top-n space)
(let ((totals (make-hash-table :test 'eq))
(total-objects 0)
(total-bytes 0))
(objects (cadr what)))
(incf printed-bytes bytes)
(incf printed-objects objects)
- (format t " ~A: ~:D bytes, ~D object~:P.~%" (car what)
+ (format t " ~A: ~:D bytes, ~:D object~:P.~%" (car what)
bytes objects)))
(let ((residual-objects (- total-objects printed-objects))
(residual-bytes (- total-bytes printed-bytes)))
(unless (zerop residual-objects)
- (format t " Other types: ~:D bytes, ~D object~:P.~%"
+ (format t " Other types: ~:D bytes, ~:D object~:P.~%"
residual-bytes residual-objects))))
(format t " ~:(~A~) instance total: ~:D bytes, ~:D object~:P.~%"
(setf start-addr (sb!di::get-lisp-obj-address object)
total-bytes bytes))
(when start-addr
- (format t "~D bytes at #X~X~%" total-bytes start-addr)
+ (format t "~:D bytes at #X~X~%" total-bytes start-addr)
(setf start-addr nil))))
space)
(when start-addr
- (format t "~D bytes at #X~X~%" total-bytes start-addr))))
+ (format t "~:D bytes at #X~X~%" total-bytes start-addr))))
(values))
\f
;;;; PRINT-ALLOCATED-OBJECTS
;; FIXME: What is this? (ERROR "Argh..")? or
;; a warning? or code that can be removed
;; once the system is stable? or what?
- (format stream "~2&**** Page ~D, address ~X:~%"
+ (format stream "~2&**** Page ~W, address ~X:~%"
pages-so-far addr))
(setq last-page this-page)
(incf pages-so-far))))
(defmethod print-object ((process process) stream)
(print-unreadable-object (process stream :type t)
(format stream
- "~D ~S"
+ "~W ~S"
(process-pid process)
(process-status process)))
process)
(when (streamp pty)
(multiple-value-bind (new-fd errno) (sb-unix:unix-dup master)
(unless new-fd
- (error "couldn't SB-UNIX:UNIX-DUP ~D: ~A" master (strerror errno)))
+ (error "couldn't SB-UNIX:UNIX-DUP ~W: ~A" master (strerror errno)))
(push new-fd *close-on-error*)
(copy-descriptor-to-stream new-fd pty cookie)))
(values name
:datum vector
:expected-type `(vector ,declared-length)
:format-control
- "Vector length (~D) doesn't match declared length (~D)."
+ "Vector length (~W) doesn't match declared length (~W)."
:format-arguments (list actual-length declared-length))))
vector)
(defun sequence-of-checked-length-given-type (sequence result-type)
(def!method print-object ((handler handler) stream)
(print-unreadable-object (handler stream :type t)
(format stream
- "~A on ~:[~;BOGUS ~]descriptor ~D: ~S"
+ "~A on ~:[~;BOGUS ~]descriptor ~W: ~S"
(handler-direction handler)
(handler-bogus handler)
(handler-descriptor handler)
;;; FIXME: Is it standard to ignore numeric args instead of raising errors?
(defun ignore-numarg (sub-char numarg)
(when numarg
- (warn "A numeric argument was ignored in #~D~A." numarg sub-char)))
+ (warn "A numeric argument was ignored in #~W~A." numarg sub-char)))
\f
;;;; reading arrays and vectors: the #(, #*, and #A readmacros
(make-array (dims) :initial-contents contents))
(unless (typep seq 'sequence)
(%reader-error stream
- "#~DA axis ~D is not a sequence:~% ~S"
+ "#~WA axis ~W is not a sequence:~% ~S"
dimensions axis seq))
(let ((len (length seq)))
(dims len)
(unless (= axis (1- dimensions))
(when (zerop len)
(%reader-error stream
- "#~DA axis ~D is empty, but is not ~
+ "#~WA axis ~W is empty, but is not ~
the last dimension."
dimensions axis))
(setq seq (elt seq 0))))))))
((not radix)
(%reader-error stream "radix missing in #R"))
((not (<= 2 radix 36))
- (%reader-error stream "illegal radix for #R: ~D" radix))
+ (%reader-error stream "illegal radix for #R: ~D." radix))
(t
(let ((res (let ((*read-base* radix))
(read stream t nil t))))
(unless (typep res 'rational)
(%reader-error stream
- "#~A (base ~D) value is not a rational: ~S."
+ "#~A (base ~D.) value is not a rational: ~S."
sub-char
radix
res))
(etypecase type
(alien-pointer-type
(when (cdr indices)
- (error "too many indices when derefing ~S: ~D"
+ (error "too many indices when DEREF'ing ~S: ~W"
type
(length indices)))
(let ((element-type (alien-pointer-type-to type)))
0))))
(alien-array-type
(unless (= (length indices) (length (alien-array-type-dimensions type)))
- (error "incorrect number of indices when derefing ~S: ~D"
+ (error "incorrect number of indices when DEREF'ing ~S: ~W"
type (length indices)))
(labels ((frob (dims indices offset)
(if (null dims)
(alien-fun-type
(unless (= (length (alien-fun-type-arg-types type))
(length args))
- (error "wrong number of arguments for ~S~%expected ~D, got ~D"
+ (error "wrong number of arguments for ~S~%expected ~W, got ~W"
type
(length (alien-fun-type-arg-types type))
(length args)))
generally expand into additional text to be output, usually consuming one
or more of the FORMAT-ARGUMENTS in the process. A few useful directives
are:
- ~A or ~nA Prints one argument as if by PRINC
- ~S or ~nS Prints one argument as if by PRIN1
- ~D or ~nD Prints one argument as a decimal integer
- ~% Does a TERPRI
- ~& Does a FRESH-LINE
-
- where n is the width of the field in which the object is printed.
+ ~A or ~nA Prints one argument as if by PRINC
+ ~S or ~nS Prints one argument as if by PRIN1
+ ~D or ~nD Prints one argument as a decimal integer
+ ~% Does a TERPRI
+ ~& Does a FRESH-LINE
+ where n is the width of the field in which the object is printed.
DESTINATION controls where the result will go. If DESTINATION is T, then
the output is sent to the standard output stream. If it is NIL, then the
(when ,params
(error 'format-error
:complaint
- "too many parameters, expected no more than ~D"
+ "too many parameters, expected no more than ~W"
:arguments (list ,(length specs))
:offset (caar ,params)))
,@body))))
(if (<= 0 posn (length orig-args))
(setf args (nthcdr posn orig-args))
(error 'format-error
- :complaint "Index ~D is out of bounds. (It should ~
- have been between 0 and ~D.)"
+ :complaint "Index ~W is out of bounds. (It should ~
+ have been between 0 and ~W.)"
:arguments (list posn (length orig-args))))))
(if colonp
(interpret-bind-defaults ((n 1)) params
(setf args (nthcdr new-posn orig-args))
(error 'format-error
:complaint
- "Index ~D is out of bounds. (It should
- have been between 0 and ~D.)"
+ "Index ~W is out of bounds. (It should
+ have been between 0 and ~W.)"
:arguments
(list new-posn (length orig-args))))))))
(interpret-bind-defaults ((n 1)) params
;;; (unless (string= (gethash hash ht) string)
;;; (format t "collision: ~S ~S~%" string (gethash hash ht)))
;;; (setf (gethash hash ht) string))))
-;;; (format t "final count=~D~%" (hash-table-count ht)))
+;;; (format t "final count=~W~%" (hash-table-count ht)))
(defun %sxhash-simple-string (x)
(declare (optimize speed))
(typecase alien-type
(alien-pointer-type
(when (cdr indices)
- (abort-ir1-transform "too many indices for pointer deref: ~D"
+ (abort-ir1-transform "too many indices for pointer deref: ~W"
(length indices)))
(let ((element-type (alien-pointer-type-to alien-type)))
(if indices
(let ((arg-types (alien-fun-type-arg-types alien-type)))
(unless (= (length args) (length arg-types))
(abort-ir1-transform
- "wrong number of arguments; expected ~D, got ~D"
+ "wrong number of arguments; expected ~W, got ~W"
(length arg-types)
(length args)))
(collect ((params) (deports))
(defparameter float-reg-symbols
(coerce
- (loop for n from 0 to 31 collect (make-symbol (format nil "~d" n)))
+ (loop for n from 0 to 31 collect (make-symbol (format nil "~D" n)))
'vector))
(sb!disassem:define-argument-type fp-reg
(assert (and (<= num-args register-arg-count)
(<= num-results register-arg-count))
(num-args num-results)
- "Either too many args (~D) or too many results (~D). Max = ~D"
+ "Either too many args (~W) or too many results (~W). Max = ~W"
num-args num-results register-arg-count)
(let ((num-temps (max num-args num-results)))
(collect ((temp-names) (temps) (arg-names) (args) (result-names) (results))
(give-up-ir1-transform
"The array dimensions are unknown; must call ARRAY-DIMENSION at runtime."))
(unless (> (length dims) axis)
- (abort-ir1-transform "The array has dimensions ~S, ~D is too large."
+ (abort-ir1-transform "The array has dimensions ~S, ~W is too large."
dims
axis))
(let ((dim (nth axis dims)))
(cond (,end
(unless (or ,unsafe? (<= ,end ,size))
,(if fail-inline?
- `(error "End ~D is greater than total size ~D."
+ `(error "End ~W is greater than total size ~W."
,end ,size)
`(failed-%with-array-data ,array ,start ,end)))
,end)
(t ,size))))
(unless (or ,unsafe? (<= ,start ,defaulted-end))
,(if fail-inline?
- `(error "Start ~D is greater than end ~D." ,start ,defaulted-end)
+ `(error "Start ~W is greater than end ~W." ,start ,defaulted-end)
`(failed-%with-array-data ,array ,start ,end)))
(do ((,data ,array (%array-data-vector ,data))
(,cumulative-offset 0
name)
'<flushed>)))
(when (inst-depth inst)
- (format stream ", depth=~D" (inst-depth inst)))))
+ (format stream ", depth=~W" (inst-depth inst)))))
#!+sb-show-assem
(defun reset-inst-ids ()
(multiple-value-bind (loc-num size)
(sb!c:location-number read)
#!+sb-show-assem (format *trace-output*
- "~&~S reads ~S[~D for ~D]~%"
+ "~&~S reads ~S[~W for ~W]~%"
inst read loc-num size)
(when loc-num
;; Iterate over all the locations for this TN.
(multiple-value-bind (loc-num size)
(sb!c:location-number write)
#!+sb-show-assem (format *trace-output*
- "~&~S writes ~S[~D for ~D]~%"
+ "~&~S writes ~S[~W for ~W]~%"
inst write loc-num size)
(when loc-num
;; Iterate over all the locations for this TN.
(chooser-index note)))
(old-size (chooser-size note)))
(when (> new-size old-size)
- (error "~S emitted ~D bytes, but claimed its max was ~D."
+ (error "~S emitted ~W bytes, but claimed its max was ~W."
note new-size old-size))
(let ((additional-delta (- old-size new-size)))
(when (< (find-alignment additional-delta)
(chooser-alignment note))
- (error "~S shrunk by ~D bytes, but claimed that it ~
- preserve ~D bits of alignment."
+ (error "~S shrunk by ~W bytes, but claimed that it ~
+ preserves ~W bits of alignment."
note additional-delta (chooser-alignment note)))
(incf delta additional-delta)
(emit-filler segment additional-delta))
;; The chooser passed on shrinking. Make sure it didn't emit
;; anything.
(unless (= (segment-current-index segment) (chooser-index note))
- (error "Chooser ~S passed, but not before emitting ~D bytes."
+ (error "Chooser ~S passed, but not before emitting ~W bytes."
note
(- (segment-current-index segment)
(chooser-index note))))
(old-size (alignment-size note))
(additional-delta (- old-size size)))
(when (minusp additional-delta)
- (error "Alignment ~S needs more space now? It was ~D, ~
- and is ~D now."
+ (error "Alignment ~S needs more space now? It was ~W, ~
+ and is ~W now."
note old-size size))
(when (plusp additional-delta)
(emit-filler segment additional-delta)
(funcall function segment posn)
(let ((new-size (- (segment-current-index segment) index)))
(unless (= new-size old-size)
- (error "~S emitted ~D bytes, but claimed it was ~D."
+ (error "~S emitted ~W bytes, but claimed it was ~W."
note new-size old-size)))
(let ((tail (segment-last-annotation segment)))
(if tail
(num-bytes (multiple-value-bind (quo rem)
(truncate total-bits assembly-unit-bits)
(unless (zerop rem)
- (error "~D isn't an even multiple of ~D."
+ (error "~W isn't an even multiple of ~W."
total-bits assembly-unit-bits))
quo))
(bytes (make-array num-bytes :initial-element nil))
(:report
(lambda (condition stream)
(format stream
- "~@<~S failure in ~S~@[ at character ~D~]: ~2I~_~A~:>"
+ "~@<~S failure in ~S~@[ at character ~W~]: ~2I~_~A~:>"
'read
'compile-file
(input-error-in-compile-file-position condition)
(frob-leaf leaf (leaf-info leaf) gensym-p))))
(frob-lambda fun t)
(when (>= level 2)
- (dolist (x (ir2-physenv-environment
- (physenv-info (lambda-physenv fun))))
+ (dolist (x (ir2-physenv-closure (physenv-info (lambda-physenv fun))))
(let ((thing (car x)))
(when (lambda-var-p thing)
(frob-leaf thing (cdr x) (= level 3)))))
(num 0 (1+ num)))
((null ref)
(when (< num count)
- (barf "There should be at least ~D ~A in ~S, but are only ~D."
+ (barf "There should be at least ~W ~A in ~S, but there are only ~W."
count what vop num))
(when (and (not more-p) (> num count))
- (barf "There should be ~D ~A in ~S, but are ~D."
+ (barf "There should be ~W ~A in ~S, but are ~W."
count what vop num)))
(unless (eq (tn-ref-vop ref) vop)
(barf "VOP is ~S isn't ~S." ref vop))
(incf const))
(format stream
- "~%TNs: ~D local, ~D temps, ~D constant, ~D env, ~D comp, ~D global.~@
- Wired: ~D, Unused: ~D. ~D block~:P, ~D global conflict~:P.~%"
+ "~%TNs: ~W local, ~W temps, ~W constant, ~W env, ~W comp, ~W global.~@
+ Wired: ~W, Unused: ~W. ~W block~:P, ~W global conflict~:P.~%"
local temps const environment comp global wired unused
(ir2-block-count component)
confs))
(barf "strange TN ~S in LTN map for ~S" tn block)))))))
;;; All TNs live at the beginning of an environment must be passing
-;;; locations associated with that environment. We make an exception for wired
-;;; TNs in XEP functions, since we randomly reference wired TNs to access the
-;;; full call passing locations.
+;;; locations associated with that environment. We make an exception
+;;; for wired TNs in XEP functions, since we randomly reference wired
+;;; TNs to access the full call passing locations.
(defun check-environment-lifetimes (component)
(dolist (fun (component-lambdas component))
(let* ((env (lambda-physenv fun))
(2env (physenv-info env))
(vars (lambda-vars fun))
- (closure (ir2-physenv-environment 2env))
+ (closure (ir2-physenv-closure 2env))
(pc (ir2-physenv-return-pc-pass 2env))
(fp (ir2-physenv-old-fp 2env))
(2block (block-info (lambda-block (physenv-lambda env)))))
(barf "strange TN live at head of ~S: ~S" env tn))))))
(values))
-;;; Check for some basic sanity in the TN conflict data structures, and also
-;;; check that no TNs are unexpectedly live at environment entry.
+;;; Check for some basic sanity in the TN conflict data structures,
+;;; and also check that no TNs are unexpectedly live at environment
+;;; entry.
(defun check-life-consistency (component)
(check-tn-conflicts component)
(check-block-conflicts component)
(vop-next vop))
(number 0 (1+ number)))
((null vop))
- (format t "~D: " number)
+ (format t "~W: " number)
(print-vop vop)))
;;; This is like PRINT-NODES, but dumps the IR2 representation of the
format-length)
(error "~@<in arg ~S: ~3I~:_~
The field ~S doesn't fit in an ~
- instruction-format ~D bits wide.~:>"
+ instruction-format ~W bits wide.~:>"
arg-name
bytespec
format-length))
(multiple-value-bind (bytes rbits)
(truncate bits sb!vm:n-byte-bits)
(when (not (zerop rbits))
- (error "~D bits is not a byte-multiple." bits))
+ (error "~W bits is not a byte-multiple." bits))
bytes))
(defun sign-extend (int size)
;; argument and the number of bytes actually written. I added this
;; assertion while trying to debug portable genesis. -- WHN 19990902
(unless (= code-length nwritten)
- (error "internal error, code-length=~D, nwritten=~D"
+ (error "internal error, code-length=~W, nwritten=~W"
code-length
nwritten)))
(values))
(ash (descriptor-low des)
(- 1 sb!vm:n-lowtag-bits)))))
(format stream
- "for fixnum: ~D"
+ "for fixnum: ~W"
(if (> unsigned #x1FFFFFFF)
(- unsigned #x40000000)
unsigned))))
(defun make-fixnum-descriptor (num)
(when (>= (integer-length num)
(1+ (- sb!vm:n-word-bits sb!vm:n-lowtag-bits)))
- (error "~D is too big for a fixnum." num))
+ (error "~W is too big for a fixnum." num))
(make-random-descriptor (ash num (1- sb!vm:n-lowtag-bits))))
(defun make-other-immediate-descriptor (data type)
((> index words)
(unless (zerop (integer-length remainder))
;; FIXME: Shouldn't this be a fatal error?
- (warn "~D words of ~D were written, but ~D bits were left over."
+ (warn "~W words of ~W were written, but ~W bits were left over."
words n remainder)))
(let ((word (ldb (byte sb!vm:n-word-bits 0) remainder)))
(write-wordindexed handle index
(descriptor-low *nil-descriptor*))))
(unless (= offset-wanted offset-found)
;; FIXME: should be fatal
- (warn "Offset from ~S to ~S is ~D, not ~D"
+ (warn "Offset from ~S to ~S is ~W, not ~W"
symbol
nil
offset-found
(desired (sb!vm:static-fun-offset sym)))
(unless (= offset desired)
;; FIXME: should be fatal
- (warn "Offset from FDEFN ~S to ~S is ~D, not ~D."
+ (warn "Offset from FDEFN ~S to ~S is ~W, not ~W."
sym nil offset desired))))))
(defun list-all-fdefn-objects ()
(8 sb!vm:simple-array-unsigned-byte-8-widetag)
(16 sb!vm:simple-array-unsigned-byte-16-widetag)
(32 sb!vm:simple-array-unsigned-byte-32-widetag)
- (t (error "losing element size: ~D" sizebits))))
+ (t (error "losing element size: ~W" sizebits))))
(result (allocate-vector-object *dynamic* sizebits len type))
(start (+ (descriptor-byte-offset result)
(ash sb!vm:vector-data-offset sb!vm:word-shift)))
#!+sb-show
(when *show-pre-fixup-code-p*
(format *trace-output*
- "~&/raw code from code-fop ~D ~D:~%"
+ "~&/raw code from code-fop ~W ~W:~%"
nconst
code-size)
(do ((i start (+ i sb!vm:n-word-bytes)))
(defun fixnumize (num)
(if (<= #x-20000000 num #x1fffffff)
(ash num 2)
- (error "~D is too big for a fixnum." num)))
+ (error "~W is too big for a fixnum." num)))
\f
;;;; routines for dealing with static symbols
(- (pad-data-block (1- symbol-size))))
(pad-data-block symbol-size))
(unless (and (zerop rem) (<= 0 n (1- (length *static-symbols*))))
- (error "The byte offset ~D is not valid." offset))
+ (error "The byte offset ~W is not valid." offset))
(elt *static-symbols* n))))
;;; Return the (byte) offset from NIL to the start of the fdefn object
(:print-object (lambda (x s)
(print-unreadable-object (x s)
(format s
- "~S ~S, Number = ~D"
+ "~S ~S, Number = ~W"
(class-info-name (type-info-class x))
(type-info-name x)
(type-info-number x)))))
reversed-ir2-physenv-alist)))
(let ((res (make-ir2-physenv
- :environment (nreverse reversed-ir2-physenv-alist)
+ :closure (nreverse reversed-ir2-physenv-alist)
:return-pc-pass (make-return-pc-passing-location
(external-entry-point-p clambda)))))
(setf (physenv-info lambda-physenv) res)
(cond ((= *last-message-count* 1)
(when terpri (terpri *error-output*)))
((> *last-message-count* 1)
- (format *error-output* "~&; [Last message occurs ~D times.]~2%"
+ (format *error-output* "~&; [Last message occurs ~W times.]~2%"
*last-message-count*)))
(setq *last-message-count* 0))
;; compiler to be able to use WITH-COMPILATION-UNIT on
;; arbitrarily huge blocks of code. -- WHN)
(let ((*compiler-error-context* node))
- (compiler-note "*INLINE-EXPANSION-LIMIT* (~D) was exceeded, ~
+ (compiler-note "*INLINE-EXPANSION-LIMIT* (~W) was exceeded, ~
probably trying to~% ~
inline a recursive function."
*inline-expansion-limit*))
(declaim (ftype (function ((or nlx-info lambda-var) physenv) tn)
find-in-physenv))
(defun find-in-physenv (thing physenv)
- (or (cdr (assoc thing (ir2-physenv-environment (physenv-info physenv))))
+ (or (cdr (assoc thing (ir2-physenv-closure (physenv-info physenv))))
(etypecase thing
(lambda-var
;; I think that a failure of this assertion means that we're
(locs loc))))
(when old-fp
- (dolist (thing (ir2-physenv-environment called-env))
+ (dolist (thing (ir2-physenv-closure called-env))
(temps (find-in-physenv (car thing) this-1env))
(locs (cdr thing)))
(t
;; No more args, so normal entry.
(vop xep-allocate-frame node block start-label nil)))
- (if (ir2-physenv-environment env)
+ (if (ir2-physenv-closure env)
(let ((closure (make-normal-tn *backend-t-primitive-type*)))
(vop setup-closure-environment node block start-label closure)
(when (getf (functional-plist ef) :fin-function)
(vop funcallable-instance-lexenv node block closure closure))
(let ((n -1))
- (dolist (loc (ir2-physenv-environment env))
+ (dolist (loc (ir2-physenv-closure env))
(vop closure-ref node block closure (incf n) (cdr loc)))))
(vop setup-environment node block start-label)))
(valid (valid-function-use call type))
(strict-valid (valid-function-use call type
:strict-result t)))
- (frob "unable to do ~A (cost ~D) because:"
+ (frob "unable to do ~A (cost ~W) because:"
(or (template-note loser) (template-name loser))
(template-cost loser))
(cond
(let ((*compiler-error-context* call))
(compiler-note "~{~?~^~&~6T~}"
(if template
- `("forced to do ~A (cost ~D)"
+ `("forced to do ~A (cost ~W)"
(,(or (template-note template)
(template-name template))
,(template-cost template))
(when (and warnings (> undefined-warning-count warn-count))
(let ((more (- undefined-warning-count warn-count)))
(compiler-style-warning
- "~D more use~:P of undefined ~(~A~) ~S"
+ "~W more use~:P of undefined ~(~A~) ~S"
more kind name))))))
(dolist (kind '(:variable :function :type))
(format *error-output* "~&")
(pprint-logical-block (*error-output* nil :per-line-prefix "; ")
(compiler-mumble "compilation unit ~:[finished~;aborted~]~
- ~[~:;~:*~& caught ~D fatal ERROR condition~:P~]~
- ~[~:;~:*~& caught ~D ERROR condition~:P~]~
- ~[~:;~:*~& caught ~D WARNING condition~:P~]~
- ~[~:;~:*~& caught ~D STYLE-WARNING condition~:P~]~
- ~[~:;~:*~& printed ~D note~:P~]"
+ ~[~:;~:*~& caught ~W fatal ERROR condition~:P~]~
+ ~[~:;~:*~& caught ~W ERROR condition~:P~]~
+ ~[~:;~:*~& caught ~W WARNING condition~:P~]~
+ ~[~:;~:*~& caught ~W STYLE-WARNING condition~:P~]~
+ ~[~:;~:*~& printed ~W note~:P~]"
abort-p
*aborted-compilation-unit-count*
*compiler-error-count*
(declare (type list locations reserve-locations alternate-scs constant-scs))
(declare (type boolean save-p))
(unless (= (logcount alignment) 1)
- (error "alignment not a power of two: ~D" alignment))
+ (error "alignment not a power of two: ~W" alignment))
(let ((sb (meta-sb-or-lose sb-name)))
(if (eq (sb-kind sb) :finite)
(dolist (el locations)
(declare (type unsigned-byte el))
(unless (<= 1 (+ el element-size) size)
- (error "SC element ~D out of bounds for ~S" el sb))))
+ (error "SC element ~W out of bounds for ~S" el sb))))
(when locations
(error ":LOCATIONS is meaningless in a ~S SB." (sb-kind sb))))
(let ((old (svref *backend-sc-numbers* ',number)))
(when (and old (not (eq (sc-name old) ',name)))
- (warn "redefining SC number ~D from ~S to ~S" ',number
+ (warn "redefining SC number ~W from ~S to ~S" ',number
(sc-name old) ',name)))
(setf (svref *backend-sc-numbers* ',number)
(eq (car x) :constant)))
types)
num)
- (error "expected ~D ~:[result~;argument~] type~P: ~S"
+ (error "expected ~W ~:[result~;argument~] type~P: ~S"
num load-p types num)))
(when more-op
(let ((nvars (length (vop-parse-variant-vars parse))))
(unless (= (length variant) nvars)
- (error "expected ~D variant values: ~S" nvars variant)))
+ (error "expected ~W variant values: ~S" nvars variant)))
`(make-vop-info
:name ',(vop-parse-name parse)
(when (or (vop-parse-more-args parse) (vop-parse-more-results parse))
(error "cannot use VOP with variable operand count templates"))
(unless (= noperands (length operands))
- (error "called with ~D operands, but was expecting ~D"
+ (error "called with ~W operands, but was expecting ~W"
(length operands) noperands))
(multiple-value-bind (acode abinds n-args)
(<= (length fixed-results) result-count))
(error "too many fixed results"))
(unless (= (length info) info-count)
- (error "expected ~D info args" info-count))
+ (error "expected ~W info args" info-count))
(multiple-value-bind (acode abinds n-args)
(make-operand-list fixed-args (car (last args)) nil)
(test-constraint nil :type (or sset null)))
(def!method print-object ((cblock cblock) stream)
(print-unreadable-object (cblock stream :type t :identity t)
- (format stream ":START c~D" (cont-num (block-start cblock)))))
+ (format stream ":START c~W" (cont-num (block-start cblock)))))
;;; The BLOCK-ANNOTATION class is inherited (via :INCLUDE) by
;;; different BLOCK-INFO annotation structures so that code
(vop-results op-vop)))
(error "couldn't find op? bug!")))))
(compiler-note
- "doing ~A (cost ~D)~:[~2*~; ~:[to~;from~] ~S~], for:~%~6T~
+ "doing ~A (cost ~W)~:[~2*~; ~:[to~;from~] ~S~], for:~%~6T~
the ~:R ~:[result~;argument~] of ~A"
note cost name arg-p name
pos arg-p op-note)))
(t
- (compiler-note "doing ~A (cost ~D)~@[ from ~S~]~@[ to ~S~]"
+ (compiler-note "doing ~A (cost ~W)~@[ from ~S~]~@[ to ~S~]"
note cost (get-operand-name op-tn t)
(get-operand-name dest-tn nil)))))
(values))
(def!method print-object ((seg segment) stream)
(print-unreadable-object (seg stream :type t)
(let ((addr (sb!sys:sap-int (funcall (seg-sap-maker seg)))))
- (format stream "#X~X[~D]~:[ (#X~X)~;~*~]~@[ in ~S~]"
+ (format stream "#X~X[~W]~:[ (#X~X)~;~*~]~@[ in ~S~]"
addr
(seg-length seg)
(= (seg-virtual-location seg) addr)
(def!method print-object ((dstate disassem-state) stream)
(print-unreadable-object (dstate stream :type t)
(format stream
- "+~D~@[ in ~S~]"
+ "+~W~@[ in ~S~]"
(dstate-cur-offs dstate)
(dstate-segment dstate))))
(alignment (dstate-alignment dstate)))
(unless (aligned-p location alignment)
(when stream
- (format stream "~A~Vt~D~%" '.align
+ (format stream "~A~Vt~W~%" '.align
(dstate-argument-column dstate)
alignment))
(incf(dstate-next-offs dstate)
(incf max)
(setf (cdr label) max)
(setf (gethash (car label) label-hash)
- (format nil "L~D" max)))))
+ (format nil "L~W" max)))))
(setf (dstate-labels dstate) labels))))
\f
;;; Get the instruction-space, creating it if necessary.
(when (or (null label-location) (> label-location location))
(return))
(unless (< label-location location)
- (format stream " L~D:" (cdr next-label)))
+ (format stream " L~W:" (cdr next-label)))
(pop (dstate-cur-labels dstate))))
;; move to the instruction column
(let ((fun-offset (sb!kernel:get-closure-length fun)))
;; There is function header fun-offset words from the
;; code header.
- (format t "Fun-header ~S at offset ~D (words): ~S~A => ~S~%"
+ (format t "Fun-header ~S at offset ~W (words): ~S~A => ~S~%"
fun
fun-offset
(sb!kernel:code-header-ref
:debug-vars debug-vars))
(let ((debug-var (aref debug-vars debug-var-offset)))
#+nil
- (format t ";;; At offset ~D: ~S~%" debug-var-offset debug-var)
+ (format t ";;; At offset ~W: ~S~%" debug-var-offset debug-var)
(let* ((sc-offset
(sb!di::compiled-debug-var-sc-offset debug-var))
(sb-name
(sb!c:sc-sb (aref sc-vec
(sb!c:sc-offset-scn sc-offset))))))
#+nil
- (format t ";;; SET: ~S[~D]~%"
+ (format t ";;; SET: ~S[~W]~%"
sb-name (sb!c:sc-offset-offset sc-offset))
(unless (null sb-name)
(let ((group (cdr (assoc sb-name groups))))
(when stream
(unless at-block-begin
(terpri stream))
- (format stream ";;; [~D] "
+ (format stream ";;; [~W] "
(sb!di:code-location-form-number
loc))
(prin1-short form stream)
(let ((name (sb!c::compiled-debug-fun-name fmap-entry))
(kind (sb!c::compiled-debug-fun-kind fmap-entry)))
#+nil
- (format t ";;; SAW ~S ~S ~S,~S ~D,~D~%"
+ (format t ";;; SAW ~S ~S ~S,~S ~W,~W~%"
name kind first-block-seen-p nil-block-seen-p
last-offset
(sb!c::compiled-debug-fun-start-pc fmap-entry))
;; Elements of this list have a one-to-one correspondence with
;; elements of the PHYSENV-CLOSURE list of the PHYSENV object that
;; links to us.
- (environment (missing-arg) :type list :read-only t)
+ (closure (missing-arg) :type list :read-only t)
;; the TNs that hold the OLD-FP and RETURN-PC within the function.
;; We always save these so that the debugger can do a backtrace,
;; even if the function has no return (and thus never uses them).
(defun static-fun-template-vop (num-args num-results)
(unless (and (<= num-args register-arg-count)
(<= num-results register-arg-count))
- (error "either too many args (~D) or too many results (~D); max = ~D"
+ (error "either too many args (~W) or too many results (~W); max = ~W"
num-args num-results register-arg-count))
(let ((num-temps (max num-args num-results)))
(collect ((temp-names) (temps) (arg-names) (args) (result-names) (results))
(< -1 offset (length name-vec))
(svref name-vec offset))
;; FIXME: Shouldn't this be an ERROR?
- (format nil "<unknown reg: off=~D, sc=~A>" offset sc-name))))
+ (format nil "<unknown reg: off=~W, sc=~A>" offset sc-name))))
(float-registers (format nil "FR~D" offset))
(stack (format nil "S~D" offset))
(constant (format nil "Const~D" offset))
(setq head (cache-vector-ref head 0))
(incf free))
(format t
- "~&There ~4D are caches of size ~4D. (~D free ~3D%)"
+ "~&There are ~4D caches of size ~4D. (~D free ~3D%)"
allocated
size
free
(sep (when home (line-separation home i))))
(when (and sep (> sep limit))
(error "bad cache ~S ~@
- value at location ~D: ~D lines from its home. The limit is ~D."
+ value at location ~W: ~W lines from its home. The limit is ~W."
cache location sep limit))))
(setq location (next-location location))))))
(defun reset-constructors ()
(multiple-value-bind (nclass ncons)
(map-constructors #'install-lazy-constructor-installer )
- (format t "~&~D classes, ~D constructors." nclass ncons)))
+ (format t "~&~W classes, ~W constructors." nclass ncons)))
(defun disable-constructors ()
(multiple-value-bind (nclass ncons)
(constructor-class c)
() () () ())
'fallback)))))
- (format t "~&~D classes, ~D constructors." nclass ncons)))
+ (format t "~&~W classes, ~W constructors." nclass ncons)))
(defun enable-constructors ()
(reset-constructors))
(ft "It has no name (the name is NIL).~%")))
(ft "The direct superclasses are: ~:S, and the direct~%~
subclasses are: ~:S. The class precedence list is:~%~S~%~
- There are ~D methods specialized for this class."
+ There are ~W methods specialized for this class."
(mapcar #'pretty-class (class-direct-superclasses class))
(mapcar #'pretty-class (class-direct-subclasses class))
(mapcar #'pretty-class (class-precedence-list class))
(sort (third type+count+sizes) #'< :key #'car)))
*dfun-count*)
(mapc #'(lambda (type+count+sizes)
- (format t "~&There are ~D dfuns of type ~S."
+ (format t "~&There are ~W dfuns of type ~S."
(cadr type+count+sizes) (car type+count+sizes))
(format t "~% ~S~%" (caddr type+count+sizes)))
*dfun-count*)
(defun error-need-at-least-n-args (function n)
- (error "~@<The function ~2I~_~S ~I~_requires at least ~D argument~:P.~:>"
+ (error "~@<The function ~2I~_~S ~I~_requires at least ~W argument~:P.~:>"
function
n))
(defmethod print-object ((cache cache) stream)
(print-unreadable-object (cache stream :type t :identity t)
(format stream
- "~D ~S ~D"
+ "~W ~S ~W"
(cache-nkeys cache)
(cache-valuep cache)
(cache-nlines cache))))
(defvar *scratch-file-stream*)
(dolist (scratch-file-length '(1 ; everyone's favorite corner case
200123)) ; hopefully much bigger than buffer
- (format t "/SCRATCH-FILE-LENGTH=~D~%" scratch-file-length)
+ (format t "/SCRATCH-FILE-LENGTH=~W~%" scratch-file-length)
(with-open-file (s *scratch-file-name* :direction :output)
(dotimes (i scratch-file-length)
(write-char #\x s)))
result))
(defun stress-gc (n-passes &optional (size 3000))
- (format t "~&beginning STRESS-GC N-PASSES=~D SIZE=~D~%" n-passes size)
+ (format t "~&beginning STRESS-GC N-PASSES=~W SIZE=~W~%" n-passes size)
(let ((generations (make-array (isqrt size) :initial-element nil))
;; We allocate on the order of MOST-POSITIVE-FIXNUM things
;; before doing a full GC.
(assert-generation i-generation generation-i))
(setf (aref generations i-generation)
generation-i))))
- (format t "~&done with STRESS-GC N-PASSES=~D SIZE=~D~%" n-passes size))
+ (format t "~&done with STRESS-GC N-PASSES=~W SIZE=~W~%" n-passes size))
(defvar *expected*)
(defvar *got*)
;; wimpy to inspect lexical variables.
(let ((*expected* (funcall repr index-within-generation))
(*got* element-of-generation))
- (error "bad element #~D in generation #~D:~% expected ~S~% from ~S,~% got ~S"
+ (error "bad element #~W in generation #~D:~% expected ~S~% from ~S,~% got ~S"
index-within-generation
index-of-generation
*expected*
;;; for internal versions, especially for internal versions off the
;;; main CVS branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.pre7.87"
+"0.pre7.88"
projects / sbcl.git / commitdiff