s/ir2-physenv-environment/ir2-physenv-closure/
changed most ~D in FORMAT strings to ~W
changed debugger prompt to "5]", "5[2]", "5[3]", etc.
62 files changed:
: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.
: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
"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
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
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:
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.
** 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
* 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 "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))
(length initial-contents)
length))
(replace array initial-contents))
(unless (and (fixnump fill-pointer)
(>= fill-pointer 0)
(<= fill-pointer length))
(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
fill-pointer))))
(setf (%array-fill-pointer-p array) t))
(t
(t
(unless (typep contents 'sequence)
(error "malformed :INITIAL-CONTENTS: ~S is not a ~
(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 ~
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)
axis (car dims) contents (length contents)))
(if (listp contents)
(dolist (content contents)
(list subscripts))
(let ((rank (array-rank array)))
(unless (= rank (length subscripts))
(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))
(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
(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))
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
(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))))
(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 "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))))
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:~% ~
(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)
name
old-context old-length
context length)
(:report
(lambda (condition stream)
(let ((error-stream (stream-error-stream condition)))
(: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))))))
(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
(def!method print-object ((debug-var debug-var) stream)
(print-unreadable-object (debug-var stream :type t :identity t)
(format stream
(debug-var-symbol debug-var)
(debug-var-id debug-var))))
(debug-var-symbol debug-var)
(debug-var-id debug-var))))
(defun assign-minimal-var-names (vars)
(declare (simple-vector vars))
(let* ((len (length vars))
(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)
(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)
(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)
(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)
"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
(sb!di:frame-number *current-frame*)
(> *debug-command-level* 1)
*debug-command-level*))
(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
(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*)
level)
(debug-prompt *debug-io*)
(force-output *debug-io*)
(let ((v (find id vars :key #'sb!di:debug-var-id)))
(unless v
(error
(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
id
(mapcar #'sb!di:debug-var-id vars)))
,(ecase ref-or-set
(let* ((name
(if (symbolp form)
(symbol-name form)
(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)
(len (length name))
(res nil))
(declare (simple-string name)
#'(lambda ()
(/show0 "in restart-command closure, about to i-r-i")
(invoke-restart-interactively restart))))
#'(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))))
(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)
(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)
(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)
(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)))
(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))
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
;;; 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)
(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)
default values))
(collect ((inlines)
input-buffer-p
(name (if file
(format nil "file ~S" file)
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))
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
(lambda ()
(sb!unix:unix-close fd)
#!+sb-show
- (format *terminal-io* "** closed file descriptor ~D **~%"
+ (format *terminal-io* "** closed file descriptor ~W **~%"
(declare (ignorable arg))
#!+sb-show
(when *show-fop-nop4-p*
(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)))
(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*)))
(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))
*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))
#!+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
(alien-integer-type-bits type)))))
\f
;;;; the BOOLEAN type
(format s "~%The object contains nothing to inspect.~%")
(return-from %inspect (reread)))
(t
(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
(= elements-length 1) (1- elements-length))
(return-from %inspect (reread))))))
(symbol
(defmethod inspected-parts ((object vector))
(values (format nil
(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))
(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)))
(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*))
(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
(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)
:format-arguments (list index array bound)))
(deferr object-not-simple-array-error (object)
(cond ((null handler)
(error 'simple-error
:format-control
(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)
:format-arguments
(list error-number
(mapcar #'(lambda (sc-offset)
(error
'format-error
:complaint
(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)))
:arguments (list ,(length specs))
:offset (caar ,params)))
,,@body)))
`(if (<= 0 ,posn (length orig-args))
(setf args (nthcdr ,posn orig-args))
(error 'format-error
`(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
:arguments (list ,posn (length orig-args))
:offset ,(1- end)))))
(if colonp
(setf args (nthcdr new-posn orig-args))
(error 'format-error
:complaint
(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)))))))
: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)
(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 ~
but this version of SBCL uses ~
- format version ~D.~:@>"
+ format version ~W.~:@>"
(dolist (entry *traced-entries*)
(when (cdr entry) (incf depth)))
(format t
(dolist (entry *traced-entries*)
(when (cdr entry) (incf depth)))
(format t
(+ (mod (* depth *trace-indentation-step*)
(- *max-trace-indentation* *trace-indentation-step*))
*trace-indentation-step*)
(+ (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))
(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))
(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
(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))))
(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
(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 "~%~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 ".~%")
(round (* (cdr space) 100) total-bytes)
(car space)))
(format t ".~%")
#.instance-header-widetag)
(incf descriptor-words (truncate size n-word-bytes)))
(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)
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))
;;; 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))
(let ((totals (make-hash-table :test 'eq))
(total-objects 0)
(total-bytes 0))
(objects (cadr what)))
(incf printed-bytes bytes)
(incf printed-objects objects)
(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)
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.~%"
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
(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
(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
(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?
;; 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))))
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
(defmethod print-object ((process process) stream)
(print-unreadable-object (process stream :type t)
(format stream
(process-pid process)
(process-status process)))
process)
(process-pid process)
(process-status process)))
process)
(when (streamp pty)
(multiple-value-bind (new-fd errno) (sb-unix:unix-dup master)
(unless new-fd
(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
(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
: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)
: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
(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)
(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
;;; 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
\f
;;;; reading arrays and vectors: the #(, #*, and #A readmacros
(make-array (dims) :initial-contents contents))
(unless (typep seq 'sequence)
(%reader-error stream
(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
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))))))))
the last dimension."
dimensions axis))
(setq seq (elt seq 0))))))))
((not radix)
(%reader-error stream "radix missing in #R"))
((not (<= 2 radix 36))
((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
(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."
(etypecase type
(alien-pointer-type
(when (cdr indices)
(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)))
type
(length indices)))
(let ((element-type (alien-pointer-type-to type)))
0))))
(alien-array-type
(unless (= (length indices) (length (alien-array-type-dimensions 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)
type (length indices)))
(labels ((frob (dims indices offset)
(if (null dims)
(alien-fun-type
(unless (= (length (alien-fun-type-arg-types type))
(length args))
(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)))
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:
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
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
(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))))
:arguments (list ,(length specs))
:offset (caar ,params)))
,@body))))
(if (<= 0 posn (length orig-args))
(setf args (nthcdr posn orig-args))
(error 'format-error
(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
: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
(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
: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))))
;;; (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))
(defun %sxhash-simple-string (x)
(declare (optimize speed))
(typecase alien-type
(alien-pointer-type
(when (cdr indices)
(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
(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
(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))
(length arg-types)
(length args)))
(collect ((params) (deports))
(defparameter float-reg-symbols
(coerce
(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
'vector))
(sb!disassem:define-argument-type fp-reg
(assert (and (<= num-args register-arg-count)
(<= num-results register-arg-count))
(num-args num-results)
(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))
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)
(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)))
dims
axis))
(let ((dim (nth axis dims)))
(cond (,end
(unless (or ,unsafe? (<= ,end ,size))
,(if fail-inline?
(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?
,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
`(failed-%with-array-data ,array ,start ,end)))
(do ((,data ,array (%array-data-vector ,data))
(,cumulative-offset 0
name)
'<flushed>)))
(when (inst-depth inst)
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 ()
#!+sb-show-assem
(defun reset-inst-ids ()
(multiple-value-bind (loc-num size)
(sb!c:location-number read)
#!+sb-show-assem (format *trace-output*
(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.
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*
(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.
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)
(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))
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))
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))
;; 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))))
note
(- (segment-current-index segment)
(chooser-index note))))
(old-size (alignment-size note))
(additional-delta (- old-size size)))
(when (minusp additional-delta)
(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)
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)
(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
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)
(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))
total-bits assembly-unit-bits))
quo))
(bytes (make-array num-bytes :initial-element nil))
(:report
(lambda (condition stream)
(format stream
(: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)
'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)
(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)))))
(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)
(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))
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))
count what vop num)))
(unless (eq (tn-ref-vop ref) vop)
(barf "VOP is ~S isn't ~S." ref vop))
(incf const))
(format stream
(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))
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
(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))
(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)))))
(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))
(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)
(defun check-life-consistency (component)
(check-tn-conflicts component)
(check-block-conflicts component)
(vop-next vop))
(number 0 (1+ number)))
((null vop))
(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
(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 ~
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))
arg-name
bytespec
format-length))
(multiple-value-bind (bytes rbits)
(truncate bits sb!vm:n-byte-bits)
(when (not (zerop rbits))
(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)
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)
;; 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))
code-length
nwritten)))
(values))
(ash (descriptor-low des)
(- 1 sb!vm:n-lowtag-bits)))))
(format stream
(ash (descriptor-low des)
(- 1 sb!vm:n-lowtag-bits)))))
(format stream
(if (> unsigned #x1FFFFFFF)
(- unsigned #x40000000)
unsigned))))
(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)))
(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)
(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?
((> 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
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
(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"
(desired (sb!vm:static-fun-offset sym)))
(unless (= offset desired)
;; FIXME: should be fatal
(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 ()
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)
(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)))
(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*
#!+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)))
nconst
code-size)
(do ((i start (+ i sb!vm:n-word-bytes)))
(defun fixnumize (num)
(if (<= #x-20000000 num #x1fffffff)
(ash num 2)
(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
\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*))))
(- (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
(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
(:print-object (lambda (x s)
(print-unreadable-object (x s)
(format s
(class-info-name (type-info-class x))
(type-info-name x)
(type-info-number x)))))
(class-info-name (type-info-class x))
(type-info-name x)
(type-info-number x)))))
reversed-ir2-physenv-alist)))
(let ((res (make-ir2-physenv
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)
: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)
(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))
*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 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*))
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)
(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
(etypecase thing
(lambda-var
;; I think that a failure of this assertion means that we're
(locs loc))))
(when old-fp
(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)))
(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)))
(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))
(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)))
(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)))
(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
(or (template-note loser) (template-name loser))
(template-cost loser))
(cond
(let ((*compiler-error-context* call))
(compiler-note "~{~?~^~&~6T~}"
(if template
(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))
(,(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
(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))
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~]~
(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*
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)
(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)
(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)
(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))))
(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)))
(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)
(sc-name old) ',name)))
(setf (svref *backend-sc-numbers* ',number)
(eq (car x) :constant)))
types)
num)
(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
num load-p types num)))
(when more-op
(let ((nvars (length (vop-parse-variant-vars parse))))
(unless (= (length variant) nvars)
(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)
`(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))
(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 operands) noperands))
(multiple-value-bind (acode abinds n-args)
(<= (length fixed-results) result-count))
(error "too many fixed results"))
(unless (= (length info) info-count)
(<= (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)
(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)
(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
;;; 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
(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
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))
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)))))
(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)
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
(def!method print-object ((dstate disassem-state) stream)
(print-unreadable-object (dstate stream :type t)
(format stream
(dstate-cur-offs dstate)
(dstate-segment dstate))))
(dstate-cur-offs dstate)
(dstate-segment dstate))))
(alignment (dstate-alignment dstate)))
(unless (aligned-p location alignment)
(when stream
(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)
(dstate-argument-column dstate)
alignment))
(incf(dstate-next-offs dstate)
(incf max)
(setf (cdr label) max)
(setf (gethash (car label) label-hash)
(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.
(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)
(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
(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.
(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
fun
fun-offset
(sb!kernel:code-header-ref
:debug-vars debug-vars))
(let ((debug-var (aref debug-vars debug-var-offset)))
#+nil
: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
(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
(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))))
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))
(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)
(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
(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))
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.
;; 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).
;; 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))
(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))
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?
(< -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))
(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
(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%)"
(sep (when home (line-separation home i))))
(when (and sep (> sep limit))
(error "bad cache ~S ~@
(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))))))
cache location sep limit))))
(setq location (next-location location))))))
(defun reset-constructors ()
(multiple-value-bind (nclass ncons)
(map-constructors #'install-lazy-constructor-installer )
(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)
(defun disable-constructors ()
(multiple-value-bind (nclass ncons)
(constructor-class c)
() () () ())
'fallback)))))
(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))
(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~%~
(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))
(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)
(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*)
(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)
(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.~:>"
(defmethod print-object ((cache cache) stream)
(print-unreadable-object (cache stream :type t :identity t)
(format stream
(defmethod print-object ((cache cache) stream)
(print-unreadable-object (cache stream :type t :identity t)
(format stream
(cache-nkeys cache)
(cache-valuep cache)
(cache-nlines cache))))
(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
(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)))
(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))
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.
(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))))
(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*)
(defvar *expected*)
(defvar *got*)
;; wimpy to inspect lexical variables.
(let ((*expected* (funcall repr index-within-generation))
(*got* element-of-generation))
;; 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*
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".)
;;; for internal versions, especially for internal versions off the
;;; main CVS branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
projects / sbcl.git / commitdiff