CMUCL commit: intl-branch src/code (array.lisp describe.lisp gc.lisp)
Raymond Toy
rtoy at common-lisp.net
Mon Feb 8 21:21:45 CET 2010
Date: Monday, February 8, 2010 @ 15:21:45
Author: rtoy
Path: /project/cmucl/cvsroot/src/code
Tag: intl-branch
Modified: array.lisp describe.lisp gc.lisp
Mark translatable strings.
---------------+
array.lisp | 152 ++++++++++++++++++++++++++---------------------------
describe.lisp | 160 ++++++++++++++++++++++++++++----------------------------
gc.lisp | 68 +++++++++++------------
3 files changed, 190 insertions(+), 190 deletions(-)
Index: src/code/array.lisp
diff -u src/code/array.lisp:1.51.2.1 src/code/array.lisp:1.51.2.2
--- src/code/array.lisp:1.51.2.1 Mon Feb 8 12:15:46 2010
+++ src/code/array.lisp Mon Feb 8 15:21:44 2010
@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(ext:file-comment
- "$Header: /project/cmucl/cvsroot/src/code/array.lisp,v 1.51.2.1 2010-02-08 17:15:46 rtoy Exp $")
+ "$Header: /project/cmucl/cvsroot/src/code/array.lisp,v 1.51.2.2 2010-02-08 20:21:44 rtoy Exp $")
;;;
;;; **********************************************************************
;;;
@@ -34,13 +34,13 @@
array-displacement))
(defconstant array-rank-limit 65529
- "The exclusive upper bound on the rank of an array.")
+ _N"The exclusive upper bound on the rank of an array.")
(defconstant array-dimension-limit most-positive-fixnum
- "The exclusive upper bound any given dimension of an array.")
+ _N"The exclusive upper bound any given dimension of an array.")
(defconstant array-total-size-limit most-positive-fixnum
- "The exclusive upper bound on the total number of elements in an array.")
+ _N"The exclusive upper bound on the total number of elements in an array.")
@@ -88,12 +88,12 @@
(let* ((size (array-total-size array))
(end (cond (end
(unless (<= end size)
- (error "End ~D is greater than total size ~D."
+ (error _"End ~D is greater than total size ~D."
end size))
end)
(t size))))
(when (> start end)
- (error "Start ~D is greater than end ~D." start end))
+ (error _"Start ~D is greater than end ~D." start end))
(do ((data array (%array-data-vector data))
(cumulative-offset 0
(+ cumulative-offset
@@ -161,7 +161,7 @@
(t #.vm:complex-vector-type)))
(defvar *static-vectors* nil
- "List of weak-pointers to static vectors. Needed for GCing static vectors")
+ _N"List of weak-pointers to static vectors. Needed for GCing static vectors")
(defun make-static-vector (length element-type)
(multiple-value-bind (type bits)
@@ -181,7 +181,7 @@
#.vm:simple-array-double-float-type
#.vm:simple-array-complex-single-float-type
#.vm:simple-array-complex-double-float-type))
- (error "Cannot make a static array of element type ~S" element-type))
+ (error _"Cannot make a static array of element type ~S" element-type))
;; Malloc space for the vector. We need enough space for the data
;; itself, and then 2 words for the vector header (header word and
;; length). Use calloc to make sure the area is initialized to
@@ -198,7 +198,7 @@
;; Malloc should return double-word (8 byte) alignment.
(assert (zerop (logand 7 (sys:sap-int pointer))))
(when (zerop (sys:sap-int pointer))
- (error "Failed to allocate space for static array of length ~S of type ~S"
+ (error _"Failed to allocate space for static array of length ~S of type ~S"
length element-type))
;; Fill in the vector header word and length word. Set the data
@@ -219,7 +219,7 @@
adjustable fill-pointer
displaced-to displaced-index-offset
allocation)
- "Creates an array of the specified Dimensions and properties. See the
+ _N"Creates an array of the specified Dimensions and properties. See the
manual for details.
:Element-type
@@ -251,11 +251,11 @@
(null displaced-to))))
(declare (fixnum array-rank))
(when (and displaced-index-offset (null displaced-to))
- (error "Can't specify :displaced-index-offset without :displaced-to"))
+ (error _"Can't specify :displaced-index-offset without :displaced-to"))
(when (and adjustable static-array-p)
- (error "Cannot make an adjustable static array"))
+ (error _"Cannot make an adjustable static array"))
(when (and displaced-to static-array-p)
- (error "Cannot make a displaced array static"))
+ (error _"Cannot make a displaced array static"))
(if (and simple (= array-rank 1))
;; It's a (simple-array * (*))
(multiple-value-bind (type bits)
@@ -278,10 +278,10 @@
(fill array initial-element))
(when initial-contents-p
(when initial-element-p
- (error "Cannot specify both :initial-element and ~
+ (error _"Cannot specify both :initial-element and ~
:initial-contents"))
(unless (= length (length initial-contents))
- (error "~D elements in the initial-contents, but the ~
+ (error _"~D elements in the initial-contents, but the ~
vector length is ~D."
(length initial-contents)
length))
@@ -303,7 +303,7 @@
array-rank)))
(cond (fill-pointer
(unless (= array-rank 1)
- (error "Only vectors can have fill pointers."))
+ (error _"Only vectors can have fill pointers."))
(let ((length (car dimensions)))
(declare (fixnum length))
(setf (%array-fill-pointer array)
@@ -313,7 +313,7 @@
(unless (and (fixnump fill-pointer)
(>= fill-pointer 0)
(<= fill-pointer length))
- (error "Invalid fill-pointer ~D"
+ (error _"Invalid fill-pointer ~D"
fill-pointer))
fill-pointer))))
(setf (%array-fill-pointer-p array) t))
@@ -324,7 +324,7 @@
(setf (%array-data-vector array) data)
(cond (displaced-to
(when (or initial-element-p initial-contents-p)
- (error "Neither :initial-element nor :initial-contents ~
+ (error _"Neither :initial-element nor :initial-contents ~
can be specified along with :displaced-to"))
;; The CLHS entry for MAKE-ARRAY says that if the
;; actual array element types are not type equivalent
@@ -334,13 +334,13 @@
(array-element-type displaced-to))
(subtypep (array-element-type displaced-to)
(upgraded-array-element-type element-type)))
- (error "One can't displace an array of type ~S into ~
+ (error _"One can't displace an array of type ~S into ~
another of type ~S."
element-type (array-element-type displaced-to)))
(let ((offset (or displaced-index-offset 0)))
(when (> (+ offset total-size)
(array-total-size displaced-to))
- (error "~S doesn't have enough elements." displaced-to))
+ (error _"~S doesn't have enough elements." displaced-to))
(setf (%array-displacement array) offset)
(setf (%array-displaced-p array) t)))
(t
@@ -362,7 +362,7 @@
(defun free-static-vector (vector)
(sys:without-gcing
(let ((addr (logandc1 vm:lowtag-mask (kernel:get-lisp-obj-address vector))))
- (format t "~&Freeing foreign vector at #x~X~%" addr)
+ (format t _"~&Freeing foreign vector at #x~X~%" addr)
(alien:alien-funcall
(alien:extern-alien "free"
(function c-call:void
@@ -378,7 +378,7 @@
;; gencgc.c.
(when *static-vectors*
(let ((*print-array* nil))
- (format t "Finalizing static vectors ~S~%" *static-vectors*))
+ (format t _"Finalizing static vectors ~S~%" *static-vectors*))
(setf *static-vectors*
(delete-if
#'(lambda (wp)
@@ -386,19 +386,19 @@
(when vector
(let* ((sap (sys:vector-sap vector))
(header (sys:sap-ref-32 sap (* -2 vm:word-bytes))))
- (format t "static vector ~A. header = ~X~%"
+ (format t _"static vector ~A. header = ~X~%"
vector header)
(cond ((logbitp 31 header)
;; Clear mark
(setf (sys:sap-ref-32 sap (* -2 vm:word-bytes))
(logand header #x7fffffff))
(let ((*print-array* nil))
- (format t " static vector ~A in use~%" vector))
+ (format t _" static vector ~A in use~%" vector))
nil)
(t
;; Mark was clear so free the vector
(let ((*print-array* nil))
- (format t " Free static vector ~A~%" vector))
+ (format t _" Free static vector ~A~%" vector))
(sys:without-interrupts
(setf (weak-pointer-value wp) nil)
(free-static-vector vector))
@@ -418,7 +418,7 @@
initial-element initial-element-p
&optional static-array-p)
(when (and initial-contents-p initial-element-p)
- (error "Cannot supply both :initial-contents and :initial-element to
+ (error _"Cannot supply both :initial-contents and :initial-element to
either make-array or adjust-array."))
(let ((data (if static-array-p
(make-static-vector total-size element-type)
@@ -431,7 +431,7 @@
(cond (initial-element-p
(unless (and (simple-vector-p data) static-array-p)
(unless (typep initial-element element-type)
- (error "~S cannot be used to initialize an array of type ~S."
+ (error _"~S cannot be used to initialize an array of type ~S."
initial-element element-type))
(fill (the vector data) initial-element)))
(initial-contents-p
@@ -447,12 +447,12 @@
(incf index))
(t
(unless (typep contents 'sequence)
- (error "Malformed :initial-contents. ~S is not a ~
+ (error _"Malformed :initial-contents. ~S is not a ~
sequence, but ~D more layer~:P needed."
contents
(- (length dimensions) axis)))
(unless (= (length contents) (car dims))
- (error "Malformed :initial-contents. Dimension of ~
+ (error _"Malformed :initial-contents. Dimension of ~
axis ~D is ~D, but ~S is ~D long."
axis (car dims) contents (length contents)))
(if (listp contents)
@@ -464,7 +464,7 @@
(defun vector (&rest objects)
- "Constructs a simple-vector from the given objects."
+ _N"Constructs a simple-vector from the given objects."
(coerce (the list objects) 'simple-vector))
@@ -547,7 +547,7 @@
(list subscripts))
(let ((rank (array-rank array)))
(unless (= rank (length subscripts))
- (simple-program-error "Wrong number of subscripts, ~D, for array of rank ~D"
+ (simple-program-error _"Wrong number of subscripts, ~D, for array of rank ~D"
(length subscripts) rank))
(if (array-header-p array)
(do ((subs (nreverse subscripts) (cdr subs))
@@ -561,7 +561,7 @@
(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 ~D~[~;~:; on axis ~:*~D~] in ~S"
index axis array)
(return-from %array-row-major-index nil)))
(incf result (* chunk-size index))
@@ -569,12 +569,12 @@
(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 ~D in ~S" index array)
(return-from %array-row-major-index nil)))
index))))
(defun array-in-bounds-p (array &rest subscripts)
- "Returns T if the Subscipts are in bounds for the Array, Nil otherwise."
+ _N"Returns T if the Subscipts are in bounds for the Array, Nil otherwise."
(if (%array-row-major-index array subscripts nil)
t))
@@ -582,7 +582,7 @@
(%array-row-major-index array subscripts))
(defun aref (array &rest subscripts)
- "Returns the element of the Array specified by the Subscripts."
+ _N"Returns the element of the Array specified by the Subscripts."
(row-major-aref array (%array-row-major-index array subscripts)))
(defun %aset (array &rest stuff)
@@ -598,7 +598,7 @@
new-value))
(defun row-major-aref (array index)
- "Returns the element of array corressponding to the row-major index. This is
+ _N"Returns the element of array corressponding to the row-major index. This is
SETF'able."
(declare (optimize (safety 1)))
(row-major-aref array index))
@@ -609,7 +609,7 @@
(setf (row-major-aref array index) new-value))
(defun svref (simple-vector index)
- "Returns the Index'th element of the given Simple-Vector."
+ _N"Returns the Index'th element of the given Simple-Vector."
(declare (optimize (safety 1)))
(aref simple-vector index))
@@ -619,7 +619,7 @@
(defun bit (bit-array &rest subscripts)
- "Returns the bit from the Bit-Array at the specified Subscripts."
+ _N"Returns the bit from the Bit-Array at the specified Subscripts."
(declare (type (array bit) bit-array) (optimize (safety 1)))
(row-major-aref bit-array (%array-row-major-index bit-array subscripts)))
@@ -640,7 +640,7 @@
new-value))
(defun sbit (simple-bit-array &rest subscripts)
- "Returns the bit from the Simple-Bit-Array at the specified Subscripts."
+ _N"Returns the bit from the Simple-Bit-Array at the specified Subscripts."
(declare (type (simple-array bit) simple-bit-array) (optimize (safety 1)))
(row-major-aref simple-bit-array
(%array-row-major-index simple-bit-array subscripts)))
@@ -664,7 +664,7 @@
;;;; Random array properties.
(defun array-element-type (array)
- "Returns the type of the elements of the array"
+ _N"Returns the type of the elements of the array"
(let ((type (get-type array)))
(macrolet ((pick-element-type (&rest stuff)
`(cond ,@(mapcar #'(lambda (stuff)
@@ -715,26 +715,26 @@
(defun array-rank (array)
- "Returns the number of dimensions of the Array."
+ _N"Returns the number of dimensions of the Array."
(if (array-header-p array)
(%array-rank array)
1))
(defun array-dimension (array axis-number)
- "Returns length of dimension Axis-Number of the Array."
+ _N"Returns length of dimension Axis-Number of the Array."
(declare (array array) (type index axis-number))
(cond ((not (array-header-p array))
(unless (= axis-number 0)
- (simple-program-error "Vector axis is not zero: ~S" axis-number))
+ (simple-program-error _"Vector axis is not zero: ~S" axis-number))
(length (the (simple-array * (*)) array)))
((>= axis-number (%array-rank array))
- (simple-program-error "~D is too big; ~S only has ~D dimension~:P"
+ (simple-program-error _"~D is too big; ~S only has ~D dimension~:P"
axis-number array (%array-rank array)))
(t
(%array-dimension array axis-number))))
(defun array-dimensions (array)
- "Returns a list whose elements are the dimensions of the array"
+ _N"Returns a list whose elements are the dimensions of the array"
(declare (array array))
(if (array-header-p array)
(do ((results nil (cons (array-dimension array index) results))
@@ -743,14 +743,14 @@
(list (array-dimension array 0))))
(defun array-total-size (array)
- "Returns the total number of elements in the Array."
+ _N"Returns the total number of elements in the Array."
(declare (array array))
(if (array-header-p array)
(%array-available-elements array)
(length (the vector array))))
(defun array-displacement (array)
- "Returns values of :displaced-to and :displaced-index-offset options to
+ _N"Returns values of :displaced-to and :displaced-index-offset options to
make-array, or the defaults nil and 0 if not a displaced array."
(declare (array array))
(if (and (array-header-p array) (%array-displaced-p array))
@@ -759,7 +759,7 @@
(values nil 0)))
(defun adjustable-array-p (array)
- "Returns T if (adjust-array array...) would return an array identical
+ _N"Returns T if (adjust-array array...) would return an array identical
to the argument, this happens for complex arrays."
(declare (array array))
(not (typep array 'simple-array)))
@@ -768,12 +768,12 @@
;;;; Fill pointer frobbing stuff.
(defun array-has-fill-pointer-p (array)
- "Returns T if the given Array has a fill pointer, or Nil otherwise."
+ _N"Returns T if the given Array has a fill pointer, or Nil otherwise."
(declare (array array))
(and (array-header-p array) (%array-fill-pointer-p array)))
(defun fill-pointer (vector)
- "Returns the Fill-Pointer of the given Vector."
+ _N"Returns the Fill-Pointer of the given Vector."
(declare (vector vector))
(if (and (array-header-p vector) (%array-fill-pointer-p vector))
(%array-fill-pointer vector)
@@ -781,7 +781,7 @@
:datum vector
:expected-type '(and vector (satisfies array-has-fill-pointer-p))
:format-control
- "~S is not an array with a fill-pointer."
+ _"~S is not an array with a fill-pointer."
:format-arguments (list vector))))
(defun %set-fill-pointer (vector new)
@@ -789,17 +789,17 @@
(if (and (array-header-p vector) (%array-fill-pointer-p vector))
(if (> new (%array-available-elements vector))
(simple-program-error
- "New fill pointer, ~S, is larger than the length of the vector."
+ _"New fill pointer, ~S, is larger than the length of the vector."
new)
(setf (%array-fill-pointer vector) new))
(error 'simple-type-error
:datum vector
:expected-type '(and vector (satisfies array-has-fill-pointer-p))
- :format-control "~S is not an array with a fill-pointer."
+ :format-control _"~S is not an array with a fill-pointer."
:format-arguments (list vector))))
(defun vector-push (new-el array)
- "Attempts to set the element of Array designated by the fill pointer
+ _N"Attempts to set the element of Array designated by the fill pointer
to New-El and increment fill pointer by one. If the fill pointer is
too large, Nil is returned, otherwise the index of the pushed element is
returned."
@@ -817,7 +817,7 @@
(extension (if (zerop (length array))
1
(length array))))
- "Like Vector-Push except that if the fill pointer gets too large, the
+ _N"Like Vector-Push except that if the fill pointer gets too large, the
Array is extended rather than Nil being returned."
(declare (vector array) (fixnum extension))
(let ((fill-pointer (fill-pointer array)))
@@ -829,14 +829,14 @@
fill-pointer))
(defun vector-pop (array)
- "Attempts to decrease the fill-pointer by 1 and return the element
+ _N"Attempts to decrease the fill-pointer by 1 and return the element
pointer to by the new fill pointer. If the original value of the fill
pointer is 0, an error occurs."
(declare (vector array))
(let ((fill-pointer (fill-pointer array)))
(declare (fixnum fill-pointer))
(if (zerop fill-pointer)
- (simple-program-error "Nothing left to pop.")
+ (simple-program-error _"Nothing left to pop.")
(aref array
(setf (%array-fill-pointer array)
(1- fill-pointer))))))
@@ -850,24 +850,24 @@
(initial-contents nil initial-contents-p)
fill-pointer
displaced-to displaced-index-offset)
- "Adjusts the Array's dimensions to the given Dimensions and stuff."
+ _N"Adjusts the Array's dimensions to the given Dimensions and stuff."
(let ((dimensions (if (listp dimensions) dimensions (list dimensions))))
(cond ((/= (the fixnum (length (the list dimensions)))
(the fixnum (array-rank array)))
- (simple-program-error "Number of dimensions not equal to rank of array."))
+ (simple-program-error _"Number of dimensions not equal to rank of array."))
((not (subtypep element-type (array-element-type array)))
- (simple-program-error "New element type, ~S, is incompatible with old."
+ (simple-program-error _"New element type, ~S, is incompatible with old."
element-type))
((static-array-p array)
- (simple-program-error "Static arrays are not adjustable.")))
+ (simple-program-error _"Static arrays are not adjustable.")))
(let ((array-rank (length (the list dimensions))))
(declare (fixnum array-rank))
(when (and fill-pointer (> array-rank 1))
- (simple-program-error "Multidimensional arrays can't have fill pointers."))
+ (simple-program-error _"Multidimensional arrays can't have fill pointers."))
(cond (initial-contents-p
;; Array former contents replaced by initial-contents.
(if (or initial-element-p displaced-to)
- (simple-program-error "Initial contents may not be specified with ~
+ (simple-program-error _"Initial contents may not be specified with ~
the :initial-element or :displaced-to option."))
(let* ((array-size (apply #'* dimensions))
(array-data (data-vector-from-inits
@@ -888,10 +888,10 @@
(displaced-to
;; No initial-contents supplied is already established.
(when initial-element
- (simple-program-error "The :initial-element option may not be specified ~
+ (simple-program-error _"The :initial-element option may not be specified ~
with :displaced-to."))
(unless (subtypep element-type (array-element-type displaced-to))
- (simple-program-error "One can't displace an array of type ~S into another of ~
+ (simple-program-error _"One can't displace an array of type ~S into another of ~
type ~S."
element-type (array-element-type displaced-to)))
(let ((displacement (or displaced-index-offset 0))
@@ -899,7 +899,7 @@
(declare (fixnum displacement array-size))
(if (< (the fixnum (array-total-size displaced-to))
(the fixnum (+ displacement array-size)))
- (simple-program-error "The :displaced-to array is too small."))
+ (simple-program-error _"The :displaced-to array is too small."))
(if (adjustable-array-p array)
;; None of the original contents appear in adjusted array.
(set-array-header array displaced-to array-size
@@ -979,13 +979,13 @@
(when (array-has-fill-pointer-p old-array)
(when (> (%array-fill-pointer old-array) new-array-size)
(simple-program-error
- "Cannot adjust-array an array (~S) to a size (~S) that is ~
+ _"Cannot adjust-array an array (~S) to a size (~S) that is ~
smaller than it's fill pointer (~S)."
old-array new-array-size (fill-pointer old-array)))
(%array-fill-pointer old-array)))
((not (array-has-fill-pointer-p old-array))
(simple-program-error
- "Cannot supply a non-NIL value (~S) for :fill-pointer ~
+ _"Cannot supply a non-NIL value (~S) for :fill-pointer ~
in adjust-array unless the array (~S) was originally ~
created with a fill pointer."
fill-pointer
@@ -993,18 +993,18 @@
((numberp fill-pointer)
(when (> fill-pointer new-array-size)
(simple-program-error
- "Cannot supply a value for :fill-pointer (~S) that is larger ~
+ _"Cannot supply a value for :fill-pointer (~S) that is larger ~
than the new length of the vector (~S)."
fill-pointer new-array-size))
fill-pointer)
((eq fill-pointer t)
new-array-size)
(t
- (simple-program-error "Bogus value for :fill-pointer in adjust-array: ~S"
+ (simple-program-error _"Bogus value for :fill-pointer in adjust-array: ~S"
fill-pointer))))
(defun shrink-vector (vector new-size)
- "Destructively alters the Vector, changing its length to New-Size, which
+ _N"Destructively alters the Vector, changing its length to New-Size, which
must be less than or equal to its current size."
(declare (vector vector))
(unless (array-header-p vector)
@@ -1053,7 +1053,7 @@
(defun set-array-header (array data length fill-pointer displacement dimensions
&optional displacedp)
- "Fills in array header with provided information. Returns array."
+ _N"Fills in array header with provided information. Returns array."
(setf (%array-data-vector array) data)
(setf (%array-available-elements array) length)
(cond (fill-pointer
@@ -1087,7 +1087,7 @@
(make-array length :initial-element t)))
(when initial-element-p
(unless (typep initial-element element-type)
- (simple-program-error "~S cannot be used to initialize an array of type ~S."
+ (simple-program-error _"~S cannot be used to initialize an array of type ~S."
initial-element element-type))
(fill (the simple-vector *zap-array-data-temp*) initial-element
:end length))
@@ -1182,7 +1182,7 @@
(t
(unless (bit-array-same-dimensions-p bit-array-1
result-bit-array)
- (simple-program-error "~S and ~S do not have the same dimensions."
+ (simple-program-error _"~S and ~S do not have the same dimensions."
bit-array-1 result-bit-array))
result-bit-array)))
@@ -1198,7 +1198,7 @@
(declare (type (array bit) bit-array-1 bit-array-2)
(type (or (array bit) (member t nil)) result-bit-array))
(unless (bit-array-same-dimensions-p bit-array-1 bit-array-2)
- (simple-program-error "~S and ~S do not have the same dimensions."
+ (simple-program-error _"~S and ~S do not have the same dimensions."
bit-array-1 bit-array-2))
(let ((result-bit-array (pick-result-array result-bit-array bit-array-1)))
(if (and (simple-bit-vector-p bit-array-1)
@@ -1233,7 +1233,7 @@
(def-bit-array-op bit-orc2 logorc2)
(defun bit-not (bit-array &optional result-bit-array)
- "Performs a bit-wise logical NOT on the elements of BIT-ARRAY,
+ _N"Performs a bit-wise logical NOT on the elements of BIT-ARRAY,
putting the results in RESULT-BIT-ARRAY. If RESULT-BIT-ARRAY is T,
BIT-ARRAY is used. If RESULT-BIT-ARRAY is NIL or omitted, a new array is
created. Both arrays must have the same rank and dimensions."
Index: src/code/describe.lisp
diff -u src/code/describe.lisp:1.54.2.1 src/code/describe.lisp:1.54.2.2
--- src/code/describe.lisp:1.54.2.1 Mon Feb 8 12:15:47 2010
+++ src/code/describe.lisp Mon Feb 8 15:21:44 2010
@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(ext:file-comment
- "$Header: /project/cmucl/cvsroot/src/code/describe.lisp,v 1.54.2.1 2010-02-08 17:15:47 rtoy Exp $")
+ "$Header: /project/cmucl/cvsroot/src/code/describe.lisp,v 1.54.2.2 2010-02-08 20:21:44 rtoy Exp $")
;;;
;;; **********************************************************************
;;;
@@ -36,39 +36,39 @@
;;;; DESCRIBE public switches.
(defvar *describe-level* 2
- "Depth of recursive descriptions allowed.")
+ _N"Depth of recursive descriptions allowed.")
(defvar *describe-verbose* nil
- "If non-nil, descriptions may provide interpretations of information and
+ _N"If non-nil, descriptions may provide interpretations of information and
pointers to additional information. Normally nil.")
(defvar *describe-print-level* 2
- "*print-level* gets bound to this inside describe. If null, use
+ _N"*print-level* gets bound to this inside describe. If null, use
*print-level*")
(defvar *describe-print-length* 5
- "*print-length* gets bound to this inside describe. If null, use
+ _N"*print-length* gets bound to this inside describe. If null, use
*print-length*.")
(defvar *describe-indentation* 3
- "Number of spaces that sets off each line of a recursive description.")
+ _N"Number of spaces that sets off each line of a recursive description.")
(defvar *in-describe* nil
- "Used to tell whether we are doing a recursive describe.")
+ _N"Used to tell whether we are doing a recursive describe.")
(defvar *current-describe-level* 0
- "Used to implement recursive description cutoff. Don't touch.")
+ _N"Used to implement recursive description cutoff. Don't touch.")
(defvar *describe-output* nil
- "An output stream used by Describe for indenting and stuff.")
+ _N"An output stream used by Describe for indenting and stuff.")
(defvar *described-objects* nil
- "List of all objects describe within the current top-level call to describe.")
+ _N"List of all objects describe within the current top-level call to describe.")
(defvar *current-describe-object* nil
- "The last object passed to describe.")
+ _N"The last object passed to describe.")
;;; DESCRIBE sets up the output stream and calls DESCRIBE-AUX, which does the
;;; hard stuff.
;;;
(defun describe (x &optional stream)
- "Prints a description of the object X."
+ _N"Prints a description of the object X."
(declare (type (or stream (member t nil)) stream))
(unless *describe-output*
(setq *describe-output* (make-indenting-stream *standard-output*)))
@@ -100,7 +100,7 @@
(defun describe-aux (x)
(when (or (not (integerp *describe-level*))
(minusp *describe-level*))
- (error "*describe-level* should be a nonnegative integer - ~A."
+ (error _"*describe-level* should be a nonnegative integer - ~A."
*describe-level*))
(when (or (>= *current-describe-level* *describe-level*)
(member x *described-objects*))
@@ -140,14 +140,14 @@
;;;; Miscellaneous DESCRIBE methods:
(defun default-describe (x)
- (format t "~&~S is a ~S." x (type-of x)))
+ (format t _"~&~S is a ~S." x (type-of x)))
(defun describe-character (x)
- (format t "~&~S is a ~S." x (type-of x))
- (format t "~&Its code is #x~4,'0x." (char-code x))
- (format t "~&Its name is ~A." (char-name x))
+ (format t _"~&~S is a ~S." x (type-of x))
+ (format t _"~&Its code is #x~4,'0x." (char-code x))
+ (format t _"~&Its name is ~A." (char-name x))
(when (surrogatep x)
- (format t "~&It is a ~:[high (leading)~;low (trailing)~] surrogate character."
+ (format t _"~&It is a ~:[high (leading)~;low (trailing)~] surrogate character."
(surrogatep x :low))))
(defun describe-instance (x &optional (kind :structure))
@@ -156,7 +156,7 @@
(fresh-line *standard-output*)
(describe-object x *standard-output*))
(t
- (format t "~&~S is a ~(~A~) of type ~A." x kind (type-of x))
+ (format t _"~&~S is a ~(~A~) of type ~A." x kind (type-of x))
(dolist (slot (cddr (inspect::describe-parts x)))
(format t "~%~A: ~S." (car slot) (cdr slot))))))
@@ -164,47 +164,47 @@
(let ((rank (array-rank x))
(element-type (array-element-type x)))
(cond ((= rank 1)
- (format t "~&~S is a ~:[~;displaced ~]vector of length ~D." x
+ (format t _"~&~S is a ~:[~;displaced ~]vector of length ~D." x
(and (array-header-p x) (%array-displaced-p x))
(array-dimension x 0))
(if (array-has-fill-pointer-p x)
- (format t "~&It has a fill pointer, currently ~d"
+ (format t _"~&It has a fill pointer, currently ~d"
(fill-pointer x))
- (format t "~&It has no fill pointer.")))
+ (format t _"~&It has no fill pointer.")))
(t
- (format t "~&~S is ~:[an~;a displaced~] array of rank ~A"
+ (format t _"~&~S is ~:[an~;a displaced~] array of rank ~A"
x (%array-displaced-p x) rank)
- (format t "~%Its dimensions are ~S." (array-dimensions x))))
+ (format t _"~%Its dimensions are ~S." (array-dimensions x))))
(unless (eq t element-type)
- (format t "~&Its element type is specialized to ~S." element-type))
+ (format t _"~&Its element type is specialized to ~S." element-type))
(when (adjustable-array-p x)
- (format t "~&It is adjustable."))
+ (format t _"~&It is adjustable."))
(when (static-array-p x)
- (format t "~&It is static."))))
+ (format t _"~&It is static."))))
(defun describe-fixnum (x)
(cond ((not (or *describe-verbose* (zerop *current-describe-level*))))
((primep x)
- (format t "~&It is a prime number."))
+ (format t _"~&It is a prime number."))
(t
- (format t "~&It is a composite number."))))
+ (format t _"~&It is a composite number."))))
#+double-double
(defun describe-double-double-float (x)
- (format t "~&~S is a ~S." x (type-of x))
- (format t "~&Its components are ~S and ~S."
+ (format t _"~&~S is a ~S." x (type-of x))
+ (format t _"~&Its components are ~S and ~S."
(kernel:double-double-hi x) (kernel:double-double-lo x)))
(defun describe-hash-table (x)
- (format t "~&~S is an ~A hash table." x (hash-table-test x))
- (format t "~&Its size is ~D buckets." (length (hash-table-table x)))
- (format t "~&Its rehash-size is ~S." (hash-table-rehash-size x))
- (format t "~&Its rehash-threshold is ~S."
+ (format t _"~&~S is an ~A hash table." x (hash-table-test x))
+ (format t _"~&Its size is ~D buckets." (length (hash-table-table x)))
+ (format t _"~&Its rehash-size is ~S." (hash-table-rehash-size x))
+ (format t _"~&Its rehash-threshold is ~S."
(hash-table-rehash-threshold x))
- (format t "~&It currently holds ~d entries."
+ (format t _"~&It currently holds ~d entries."
(hash-table-number-entries x))
(when (hash-table-weak-p x)
- (format t "~&It is weak ~A table." (hash-table-weak-p x))))
+ (format t _"~&It is weak ~A table." (hash-table-weak-p x))))
(defun describe-package (x)
(describe-instance x)
@@ -214,7 +214,7 @@
(external (package-external-symbols x))
(external-count (- (package-hashtable-size external)
(package-hashtable-free external))))
- (format t "~&~d symbols total: ~d internal and ~d external."
+ (format t _"~&~d symbols total: ~d internal and ~d external."
(+ internal-count external-count) internal-count external-count)))
@@ -227,7 +227,7 @@
(when (and name (typep name '(or symbol cons)))
(let ((doc (documentation name kind)))
(when doc
- (format t "~&~@(~A documentation:~)~& ~A"
+ (format t _"~&~@(~A documentation:~)~& ~A"
(or kind-doc kind) doc)))))
@@ -247,13 +247,13 @@
(info function where-from name))
(values type-spec :defined))
(when (consp type)
- (format t "~&Its ~(~A~) argument types are:~% ~S"
+ (format t _"~&Its ~(~A~) argument types are:~% ~S"
where (second type))
- (format t "~&Its result type is:~% ~S" (third type)))))
+ (format t _"~&Its result type is:~% ~S" (third type)))))
(let ((inlinep (info function inlinep name)))
(when inlinep
- (format t "~&It is currently declared ~(~A~);~
+ (format t _"~&It is currently declared ~(~A~);~
~:[no~;~] expansion is available."
inlinep (info function inline-expansion name)))))
@@ -268,9 +268,9 @@
(multiple-value-bind (exp closure-p dname)
(eval:interpreted-function-lambda-expression x)
(let ((args (eval:interpreted-function-arglist x)))
- (format t "~&~@(~@[~A ~]arguments:~%~)" kind)
+ (format t _"~&~@(~@[~A ~]arguments:~%~)" kind)
(cond ((not args)
- (write-string " There are no arguments."))
+ (write-string _" There are no arguments."))
(t
(write-string " ")
(indenting-further *standard-output* 2
@@ -284,13 +284,13 @@
(type-specifier (eval:interpreted-function-type x)))))
(when closure-p
- (format t "~&Its closure environment is:")
+ (format t _"~&Its closure environment is:")
(indenting-further *standard-output* 2
(let ((clos (eval:interpreted-function-closure x)))
(dotimes (i (length clos))
(format t "~&~D: ~S" i (svref clos i))))))
- (format t "~&Its definition is:~% ~S" exp)))
+ (format t _"~&Its definition is:~% ~S" exp)))
;;; PRINT-COMPILED-FROM -- Internal
@@ -301,7 +301,7 @@
(let ((info (kernel:%code-debug-info code-obj)))
(when info
(let ((sources (c::debug-info-source info)))
- (format t "~&On ~A it was compiled from:"
+ (format t _"~&On ~A it was compiled from:"
(format-universal-time nil
(c::debug-source-compiled
(first sources))))
@@ -309,11 +309,11 @@
(let ((name (c::debug-source-name source)))
(ecase (c::debug-source-from source)
(:file
- (format t "~&~A~% Created: " (namestring name))
+ (format t _"~&~A~% Created: " (namestring name))
(ext:format-universal-time t (c::debug-source-created source))
(let ((comment (c::debug-source-comment source)))
(when comment
- (format t "~& Comment: ~A" comment))))
+ (format t _"~& Comment: ~A" comment))))
(:stream (format t "~&~S" name))
(:lisp (format t "~&~S" name)))))))))
@@ -325,11 +325,11 @@
;;;
(defun describe-function-compiled (x kind name)
(let ((args (%function-arglist x)))
- (format t "~&~@(~@[~A ~]arguments:~%~)" kind)
+ (format t _"~&~@(~@[~A ~]arguments:~%~)" kind)
(cond ((not args)
- (format t " There is no argument information available."))
+ (format t _" There is no argument information available."))
((string= args "()")
- (write-string " There are no arguments."))
+ (write-string _" There are no arguments."))
(t
(write-string " ")
(indenting-further *standard-output* 2
@@ -363,14 +363,14 @@
(declare (type function x) (type (member :macro :function nil) kind))
(fresh-line)
(ecase kind
- (:macro (format t "Macro-function: ~S" x))
- (:function (format t "Function: ~S" x))
+ (:macro (format t _"Macro-function: ~S" x))
+ (:function (format t _"Function: ~S" x))
((nil)
- (format t "~S is a function." x)))
+ (format t _"~S is a function." x)))
(case (get-type x)
(#.vm:closure-header-type
(describe-function-compiled (%closure-function x) kind name)
- (format t "~&Its closure environment is:")
+ (format t _"~&Its closure environment is:")
(indenting-further *standard-output* 8)
(dotimes (i (- (get-closure-length x) (1- vm:closure-info-offset)))
(format t "~&~D: ~S" i (%closure-index-ref x i))))
@@ -383,7 +383,7 @@
(kernel:byte-closure
(describe-function-byte-compiled (byte-closure-function x)
kind name)
- (format t "~&Its closure environment is:")
+ (format t _"~&Its closure environment is:")
(indenting-further *standard-output* 8)
(let ((data (byte-closure-data x)))
(dotimes (i (length data))
@@ -393,7 +393,7 @@
(t
(describe-instance x :funcallable-instance))))
(t
- (format t "~&It is an unknown type of function."))))
+ (format t _"~&It is an unknown type of function."))))
(defun describe-symbol (x)
@@ -402,40 +402,40 @@
(multiple-value-bind (symbol status)
(find-symbol (symbol-name x) package)
(declare (ignore symbol))
- (format t "~&~A is an ~A symbol in the ~A package." x
+ (format t _"~&~A is an ~A symbol in the ~A package." x
(string-downcase (symbol-name status))
(package-name (symbol-package x))))
- (format t "~&~A is an uninterned symbol." x)))
+ (format t _"~&~A is an uninterned symbol." x)))
;;
;; Describe the value cell.
(let* ((kind (info variable kind x))
(wot (ecase kind
- (:special "special variable")
- (:constant "constant")
- (:global "undefined variable")
- (:macro "symbol macro")
+ (:special _"special variable")
+ (:constant _"constant")
+ (:global _"undefined variable")
+ (:macro _"symbol macro")
(:alien nil))))
(cond
((eq kind :alien)
(let ((info (info variable alien-info x)))
- (format t "~&~@<It is an alien at #x~8,'0X of type ~3I~:_~S.~:>~%"
+ (format t _"~&~@<It is an alien at #x~8,'0X of type ~3I~:_~S.~:>~%"
(sap-int (eval (alien::heap-alien-info-sap-form info)))
(alien-internals:unparse-alien-type
(alien::heap-alien-info-type info)))
- (format t "~@<Its current value is ~3I~:_~S.~:>"
+ (format t _"~@<Its current value is ~3I~:_~S.~:>"
(eval x))))
((eq kind :macro)
(let ((expansion (info variable macro-expansion x)))
- (format t "~&It is a ~A with expansion: ~S." wot expansion)))
+ (format t _"~&It is a ~A with expansion: ~S." wot expansion)))
((boundp x)
(let ((value (symbol-value x)))
- (format t "~&It is a ~A; its value is ~S." wot value)
+ (format t _"~&It is a ~A; its value is ~S." wot value)
(describe value)))
((not (eq kind :global))
- (format t "~&It is a ~A; no current value." wot)))
+ (format t _"~&It is a ~A; no current value." wot)))
(when (eq (info variable where-from x) :declared)
- (format t "~&Its declared type is ~S."
+ (format t _"~&Its declared type is ~S."
(type-specifier (info variable type x))))
(desc-doc x 'variable kind))
@@ -444,39 +444,39 @@
(cond ((macro-function x)
(describe-function (macro-function x) :macro x))
((special-operator-p x)
- (desc-doc x 'function "Special form"))
+ (desc-doc x 'function _"Special form"))
((fboundp x)
(describe-function (fdefinition x) :function x)))
;;
;; Print other documentation.
- (desc-doc x 'structure "Structure")
- (desc-doc x 'type "Type")
- (desc-doc x 'setf "Setf macro")
+ (desc-doc x 'structure _"Structure")
+ (desc-doc x 'type _"Type")
+ (desc-doc x 'setf _"Setf macro")
(dolist (assoc (info random-documentation stuff x))
- (format t "~&Documentation on the ~(~A~):~%~A" (car assoc) (cdr assoc)))
+ (format t _"~&Documentation on the ~(~A~):~%~A" (car assoc) (cdr assoc)))
;;
;; Print Class information
(let ((class (kernel::find-class x nil)))
(when class
- (format t "~&It names a class ~A." class)
+ (format t _"~&It names a class ~A." class)
(describe class)
(let ((pcl-class (%class-pcl-class class)))
(when pcl-class
- (format t "~&It names a PCL class ~A." pcl-class)
+ (format t _"~&It names a PCL class ~A." pcl-class)
(describe pcl-class)))))
;;
;; Print out information about any types named by the symbol
(when (eq (info type kind x) :defined)
- (format t "~&It names a type specifier."))
+ (format t _"~&It names a type specifier."))
;;
;; Print out properties, possibly ignoring implementation details.
(do ((plist (symbol-plist X) (cddr plist)))
((null plist) ())
(unless (member (car plist) *implementation-properties*)
- (format t "~&Its ~S property is ~S." (car plist) (cadr plist))
+ (format t _"~&Its ~S property is ~S." (car plist) (cadr plist))
(describe (cadr plist))))
;; Describe where it was defined.
(let ((locn (info :source-location :defvar x)))
(when locn
- (format t "~&It is defined in:~&~A" (c::file-source-location-pathname locn)))))
+ (format t _"~&It is defined in:~&~A" (c::file-source-location-pathname locn)))))
Index: src/code/gc.lisp
diff -u src/code/gc.lisp:1.42.38.1 src/code/gc.lisp:1.42.38.2
--- src/code/gc.lisp:1.42.38.1 Mon Feb 8 12:15:47 2010
+++ src/code/gc.lisp Mon Feb 8 15:21:44 2010
@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(ext:file-comment
- "$Header: /project/cmucl/cvsroot/src/code/gc.lisp,v 1.42.38.1 2010-02-08 17:15:47 rtoy Exp $")
+ "$Header: /project/cmucl/cvsroot/src/code/gc.lisp,v 1.42.38.2 2010-02-08 20:21:44 rtoy Exp $")
;;;
;;; **********************************************************************
;;;
@@ -105,7 +105,7 @@
((= start (dynamic-1-space-start))
1)
(t
- (error "Oh no. The current dynamic space is missing!")))))
+ (error _"Oh no. The current dynamic space is missing!")))))
;;;; Room.
@@ -114,18 +114,18 @@
(flet ((megabytes (bytes)
;; Convert bytes to nearest megabyte
(ceiling bytes (* 1024 1024))))
- (format t "Dynamic Space Usage: ~13:D bytes (out of ~4:D MB).~%"
+ (format t _"Dynamic Space Usage: ~13:D bytes (out of ~4:D MB).~%"
(dynamic-usage) (megabytes (dynamic-space-size)))
- (format t "Read-Only Space Usage: ~13:D bytes (out of ~4:D MB).~%"
+ (format t _"Read-Only Space Usage: ~13:D bytes (out of ~4:D MB).~%"
(read-only-space-usage) (megabytes (read-only-space-size)))
- (format t "Static Space Usage: ~13:D bytes (out of ~4:D MB).~%"
+ (format t _"Static Space Usage: ~13:D bytes (out of ~4:D MB).~%"
(static-space-usage) (megabytes (static-space-size)))
- (format t "Control Stack Usage: ~13:D bytes (out of ~4:D MB).~%"
+ (format t _"Control Stack Usage: ~13:D bytes (out of ~4:D MB).~%"
(control-stack-usage) (megabytes (control-stack-size)))
- (format t "Binding Stack Usage: ~13:D bytes (out of ~4:D MB).~%"
+ (format t _"Binding Stack Usage: ~13:D bytes (out of ~4:D MB).~%"
(binding-stack-usage) (megabytes (binding-stack-size)))
- (format t "The current dynamic space is ~D.~%" (current-dynamic-space))
- (format t "Garbage collection is currently ~:[enabled~;DISABLED~].~%"
+ (format t _"The current dynamic space is ~D.~%" (current-dynamic-space))
+ (format t _"Garbage collection is currently ~:[enabled~;DISABLED~].~%"
*gc-inhibit*)))
(defun room-intermediate-info ()
@@ -143,7 +143,7 @@
(defun room (&optional (verbosity :default))
- "Prints to *STANDARD-OUTPUT* information about the state of internal
+ _N"Prints to *STANDARD-OUTPUT* information about the state of internal
storage and its management. The optional argument controls the
verbosity of ROOM. If it is T, ROOM prints out a maximal amount of
information. If it is NIL, ROOM prints out a minimal amount of
@@ -160,7 +160,7 @@
(:default
(room-intermediate-info))
(t
- (error "No way man! The optional argument to ROOM must be T, NIL, ~
+ (error _"No way man! The optional argument to ROOM must be T, NIL, ~
or :DEFAULT.~%What do you think you are doing?")))
(room-minimal-info))
(values))
@@ -185,7 +185,7 @@
(cond ((null *last-bytes-in-use*)
(pushnew
#'(lambda ()
- (print "resetting GC counters")
+ (print _"resetting GC counters")
(force-output)
(setf *last-bytes-in-use* nil)
(setf *total-bytes-consed* (dfixnum:make-dfixnum)))
@@ -209,7 +209,7 @@
#-(or cgc gencgc)
(defun get-bytes-consed-dfixnum ()
- "Returns the number of bytes consed since the first time this function
+ _N"Returns the number of bytes consed since the first time this function
was called. The first time it is called, it returns zero."
(declare (optimize (speed 3) (safety 0)(inhibit-warnings 3)))
(cond ((null *last-bytes-in-use*)
@@ -223,7 +223,7 @@
*total-bytes-consed*)
(defun get-bytes-consed ()
- "Returns the number of bytes consed since the first time this function
+ _N"Returns the number of bytes consed since the first time this function
was called. The first time it is called, it returns zero."
(dfixnum:dfixnum-integer (get-bytes-consed-dfixnum)))
@@ -239,14 +239,14 @@
;;; will be triggered.
;;;
(defparameter *bytes-consed-between-gcs* default-bytes-consed-between-gcs
- "This number specifies the minimum number of bytes of dynamic space
+ _N"This number specifies the minimum number of bytes of dynamic space
that must be consed before the next gc will occur.")
;;;
(declaim (type index *bytes-consed-between-gcs*))
;;; Public
(defvar *gc-run-time* 0
- "The total CPU time spend doing garbage collection (as reported by
+ _N"The total CPU time spend doing garbage collection (as reported by
GET-INTERNAL-RUN-TIME.)")
(declaim (type index *gc-run-time*))
@@ -304,11 +304,11 @@
;;; after garbage collection occurs.
;;;
(defvar *before-gc-hooks* nil
- "A list of functions that are called before garbage collection occurs.
+ _N"A list of functions that are called before garbage collection occurs.
The functions should take no arguments.")
;;;
(defvar *after-gc-hooks* nil
- "A list of functions that are called after garbage collection occurs.
+ _N"A list of functions that are called after garbage collection occurs.
The functions should take no arguments.")
;;;
@@ -321,7 +321,7 @@
;;; Presumably someone will call GC-ON later to collect the garbage.
;;;
(defvar *gc-inhibit-hook* nil
- "Should be bound to a function or NIL. If it is a function, this
+ _N"Should be bound to a function or NIL. If it is a function, this
function should take one argument, the current amount of dynamic
usage. The function should return NIL if garbage collection should
continue and non-NIL if it should be inhibited. Use with caution.")
@@ -332,7 +332,7 @@
;;; *GC-VERBOSE*
;;;
(defvar *gc-verbose* t
- "When non-NIL, causes the functions bound to *GC-NOTIFY-BEFORE* and
+ _N"When non-NIL, causes the functions bound to *GC-NOTIFY-BEFORE* and
*GC-NOTIFY-AFTER* to be called before and after a garbage collection
occurs respectively. If :BEEP, causes the default notify functions to beep
annoyingly.")
@@ -341,26 +341,26 @@
(defun default-gc-notify-before (bytes-in-use)
(when (eq *gc-verbose* :beep)
(system:beep *standard-output*))
- (format t "~&; [GC threshold exceeded with ~:D bytes in use. ~
+ (format t _"~&; [GC threshold exceeded with ~:D bytes in use. ~
Commencing GC.]~%" bytes-in-use)
(finish-output))
;;;
(defparameter *gc-notify-before* #'default-gc-notify-before
- "This function bound to this variable is invoked before GC'ing (unless
+ _N"This function bound to this variable is invoked before GC'ing (unless
*GC-VERBOSE* is NIL) with the current amount of dynamic usage (in
bytes). It should notify the user that the system is going to GC.")
(defun default-gc-notify-after (bytes-retained bytes-freed new-trigger)
- (format t "~&; [GC completed with ~:D bytes retained and ~:D bytes freed.]~%"
+ (format t _"~&; [GC completed with ~:D bytes retained and ~:D bytes freed.]~%"
bytes-retained bytes-freed)
- (format t "~&; [GC will next occur when at least ~:D bytes are in use.]~%"
+ (format t _"~&; [GC will next occur when at least ~:D bytes are in use.]~%"
new-trigger)
(when (eq *gc-verbose* :beep)
(system:beep *standard-output*))
(finish-output))
;;;
(defparameter *gc-notify-after* #'default-gc-notify-after
- "The function bound to this variable is invoked after GC'ing (unless
+ _N"The function bound to this variable is invoked after GC'ing (unless
*GC-VERBOSE* is NIL) with the amount of dynamic usage (in bytes) now
free, the number of bytes freed by the GC, and the new GC trigger
threshold. The function should notify the user that the system has
@@ -381,7 +381,7 @@
(let ((words (ash (+ (current-dynamic-space-start) bytes) -2)))
(unless (and (fixnump words) (plusp words))
(clear-auto-gc-trigger)
- (warn "Attempt to set GC trigger to something bogus: ~S" bytes))
+ (warn _"Attempt to set GC trigger to something bogus: ~S" bytes))
(setf rt::*internal-gc-trigger* words)))
#-ibmrt
@@ -411,7 +411,7 @@
(defmacro carefully-funcall (function &rest args)
`(handler-case (funcall ,function , at args)
(error (cond)
- (warn "(FUNCALL ~S~{ ~S~}) lost:~%~A" ',function ',args cond)
+ (warn _"(FUNCALL ~S~{ ~S~}) lost:~%~A" ',function ',args cond)
nil)))
;;;
@@ -433,7 +433,7 @@
;; The noise w/ symbol-value above is to keep the compiler from
;; optimizing the test away because of the type declaim for
;; *bytes-consed-between-gcs*.
- (warn "The value of *BYTES-CONSED-BETWEEN-GCS*, ~S, is not an ~
+ (warn _"The value of *BYTES-CONSED-BETWEEN-GCS*, ~S, is not an ~
integer. Resetting it to ~D." *bytes-consed-between-gcs*
default-bytes-consed-between-gcs)
(setf *bytes-consed-between-gcs* default-bytes-consed-between-gcs))
@@ -509,14 +509,14 @@
;;;
#-gencgc
(defun gc (&optional (verbose-p *gc-verbose*))
- "Initiates a garbage collection. The optional argument, VERBOSE-P,
+ _N"Initiates a garbage collection. The optional argument, VERBOSE-P,
which defaults to the value of the variable *GC-VERBOSE* controls
whether or not GC statistics are printed."
(sub-gc :verbose-p verbose-p :force-p t))
;;;
#+gencgc
(defun gc (&key (verbose *gc-verbose*) (gen 0) (full nil))
- "Initiates a garbage collection. The keyword :VERBOSE, which
+ _N"Initiates a garbage collection. The keyword :VERBOSE, which
defaults to the value of the variable *GC-VERBOSE* controls whether or
not GC statistics are printed. The keyword :GEN defaults to 0, and
controls the number of generations to garbage collect."
@@ -526,7 +526,7 @@
;;;; Auxiliary Functions.
(defun bytes-consed-between-gcs ()
- "Return the amount of memory that will be allocated before the next garbage
+ _N"Return the amount of memory that will be allocated before the next garbage
collection is initiated. This can be set with SETF."
*bytes-consed-between-gcs*)
;;;
@@ -548,14 +548,14 @@
(defun gc-on ()
- "Enables the garbage collector."
+ _N"Enables the garbage collector."
(setq *gc-inhibit* nil)
(when *need-to-collect-garbage*
(sub-gc))
nil)
(defun gc-off ()
- "Disables the garbage collector."
+ _N"Disables the garbage collector."
(setq *gc-inhibit* t)
nil)
@@ -584,7 +584,7 @@
(min-av-mem-age c-call:double)))
(defun gencgc-stats (generation)
- "Return some GC statistics for the specified GENERATION. The
+ _N"Return some GC statistics for the specified GENERATION. The
statistics are the number of bytes allocated in this generation; the
gc-trigger; the number of bytes consed between GCs; the number of
GCs that have occurred; the trigger age; the cumulative number of
More information about the cmucl-commit
mailing list