(Also, when this is fixed, we can enable the code in PROCLAIM which
checks for incompatible FTYPE redeclarations.)
-16:
- The ANSI spec says that CONS can be a compound type spec, e.g.
- (CONS FIXNUM REAL). SBCL doesn't support this.
-
18:
from DTC on the CMU CL mailing list 25 Feb 2000:
;;; Compiler fails when this file is compiled.
also report on closures, telling about the values of the bound variables.
34:
+ WHN test case: Compile this file:
+ (eval-when (:compile-toplevel :load-toplevel :execute)
+ (defclass a-class () (a)))
+ (defconstant +a-constant+ (make-instance 'a-class))
+ (defconstant +another-constant+ (vector +a-constant+))
as reported by Robert Strandh on the CMU CL mailing list 12 Jun 2000:
$ cat xx.lisp
(defconstant +a-constant+ (make-instance 'a-class))
They hired William Newman to do some consulting for them,
including the implementation of EQUALP hash tables for CMU CL;
then agreed to release the EQUALP code into the public domain,
- giving SBCL, and CMU CL, EQUALP hash tables.
+ giving SBCL (and CMU CL) EQUALP hash tables.
Douglas Crosher:
He continued to improve CMU CL after SBCL forked from it, creating
instead of the old "5]", "5]]", "5]]]" sequence. (I was motivated
to do this when ILISP and SBCL got into arguments which left me
deeply nested in the debugger.)
+* When the profiling interface settles down, it might impact TRACE.
+ They both encapsulate functions, and it's not clear yet how
+ e.g. UNPROFILE will interact with TRACE and UNTRACE. (This shouldn't
+ matter, though, unless you are using profiling.)
\f
;;;; miscellaneous accessor functions
-;;; These functions are needed by the interpreter, 'cause the compiler inlines
-;;; them.
+;;; These functions are needed by the interpreter, 'cause the compiler
+;;; inlines them.
(macrolet ((def-frob (name)
`(progn
(defun ,name (array)
(fixnum index))
(%check-bound array bound index))
-;;; The guts of the WITH-ARRAY-DATA macro. Note that this function is
-;;; only called if we have an array header or an error, so it doesn't
-;;; have to be too tense.
+;;; the guts of the WITH-ARRAY-DATA macro (except when DEFTRANSFORM
+;;; %WITH-ARRAY-DATA takes over)
(defun %with-array-data (array start end)
(declare (array array) (type index start) (type (or index null) end))
;; FIXME: The VALUES declaration here is correct, but as of SBCL
;;; These functions are used in the implementation of MAKE-ARRAY for
;;; complex arrays. There are lots of transforms to simplify
-;;; MAKE-ARRAY is transformed away for various easy cases, but not for
-;;; all reasonable cases, so e.g. as of sbcl-0.6.6 we still make full
-;;; calls to MAKE-ARRAY for any non-simple array. Thus, there's some
-;;; value to making this somewhat efficient, at least not doing full
-;;; calls to SUBTYPEP in the easy cases.
+;;; MAKE-ARRAY for various easy cases, but not for all reasonable
+;;; cases, so e.g. as of sbcl-0.6.6 we still make full calls to
+;;; MAKE-ARRAY for any non-simple array. Thus, there's some value to
+;;; making this somewhat efficient, at least not doing full calls to
+;;; SUBTYPEP in the easy cases.
(defun %vector-type-code (type)
(case type
;; Pick off some easy common cases.
(initial-element nil initial-element-p)
initial-contents adjustable fill-pointer
displaced-to displaced-index-offset)
- #!+sb-doc
- "Creates an array of the specified Dimensions. See manual for details."
(let* ((dimensions (if (listp dimensions) dimensions (list dimensions)))
(array-rank (length (the list dimensions)))
(simple (and (null fill-pointer)
&optional
(extension (1+ (length vector))))
#!+sb-doc
- "Like Vector-Push except that if the fill pointer gets too large, the
- Vector is extended rather than Nil being returned."
+ "This is like Vector-Push except that if the fill pointer gets too
+ large, the Vector is extended rather than Nil being returned."
(declare (vector vector) (fixnum extension))
(let ((fill-pointer (fill-pointer vector)))
(declare (fixnum fill-pointer))
(when (and fill-pointer (> array-rank 1))
(error "Multidimensional arrays can't have fill pointers."))
(cond (initial-contents
- ;; Array former contents replaced by initial-contents.
+ ;; array former contents replaced by INITIAL-CONTENTS
(if (or initial-element-p displaced-to)
- (error "Initial contents may not be specified with ~
+ (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
fill-pointer)
0 dimensions nil)
(if (array-header-p array)
- ;; Simple multidimensional or single dimensional array.
+ ;; simple multidimensional or single dimensional array
(make-array dimensions
:element-type element-type
:initial-contents initial-contents)
array-data))))
(displaced-to
- ;; No initial-contents supplied is already established.
+ ;; We already established that no INITIAL-CONTENTS was supplied.
(when initial-element
(error "The :INITIAL-ELEMENT option may not be specified ~
with :DISPLACED-TO."))
\f
;;;; ZAP-ARRAY-DATA for ADJUST-ARRAY
-;;; Make a temporary to be used when old-data and new-data are EQ.
+;;; a temporary to be used when OLD-DATA and NEW-DATA are EQ.
;;; KLUDGE: Boy, DYNAMIC-EXTENT would be nice.
(defvar *zap-array-data-temp* (make-array 1000 :initial-element t))
:end length))
*zap-array-data-temp*)
-;;; This does the grinding work for ADJUST-ARRAY. It zaps the data from the
-;;; Old-Data in an arrangement specified by the Old-Dims to the New-Data in an
-;;; arrangement specified by the New-Dims. Offset is a displaced offset to be
-;;; added to computed indexes of Old-Data. New-Length, Element-Type,
-;;; Initial-Element, and Initial-Element-P are used when Old-Data and New-Data
-;;; are EQ; in this case, a temporary must be used and filled appropriately.
-;;; When Old-Data and New-Data are not EQ, New-Data has already been filled
-;;; with any specified initial-element.
+;;; This does the grinding work for ADJUST-ARRAY. It zaps the data
+;;; from the OLD-DATA in an arrangement specified by the OLD-DIMS to
+;;; the NEW-DATA in an arrangement specified by the NEW-DIMS. OFFSET
+;;; is a displaced offset to be added to computed indices of OLD-DATA.
+;;; NEW-LENGTH, ELEMENT-TYPE, INITIAL-ELEMENT, and INITIAL-ELEMENT-P
+;;; are used when OLD-DATA and NEW-DATA are EQ; in this case, a
+;;; temporary must be used and filled appropriately. When OLD-DATA and
+;;; NEW-DATA are not EQ, NEW-DATA has already been filled with any
+;;; specified initial-element.
(defun zap-array-data (old-data old-dims offset new-data new-dims new-length
element-type initial-element initial-element-p)
(declare (list old-dims new-dims))
offset)))))))
;;; Figure out the row-major-order index of an array reference from a
-;;; list of subscripts and a list of dimensions. This is for internal calls
-;;; only, and the subscripts and dim-list variables are assumed to be reversed
-;;; from what the user supplied.
+;;; list of subscripts and a list of dimensions. This is for internal
+;;; calls only, and the subscripts and dim-list variables are assumed
+;;; to be reversed from what the user supplied.
(defun row-major-index-from-dims (rev-subscripts rev-dim-list)
(do ((rev-subscripts rev-subscripts (cdr rev-subscripts))
(rev-dim-list rev-dim-list (cdr rev-dim-list))
;; fixups be done separately? Wouldn't that be clearer and better?
;; -- WHN 19991204
(/show0 "doing cold toplevel forms and fixups")
- (/show0 "(LENGTH *!REVERSED-COLD-TOPLEVELS*)=..")
+ (/show0 "(LISTP *!REVERSED-COLD-TOPLEVELS*)=..")
#!+sb-show (%primitive print
- (sb!impl::hexstr (length *!reversed-cold-toplevels*)))
- (let (#!+sb-show (index-in-cold-toplevels 0)
- #!+sb-show (filename-in-cold-toplevels nil))
+ (if (listp *!reversed-cold-toplevels*) "true" "NIL"))
+ (/show0 "about to calculate (LENGTH *!REVERSED-COLD-TOPLEVELS*)")
+ (/show0 "(LENGTH *!REVERSED-COLD-TOPLEVELS*)=..")
+ #!+sb-show (let ((r-c-tl-length (length *!reversed-cold-toplevels*)))
+ (/show0 "(length calculated..)")
+ (let ((hexstr (sb!impl::hexstr r-c-tl-length)))
+ (/show0 "(hexstr calculated..)")
+ (%primitive print hexstr)))
+ (let (#!+sb-show (index-in-cold-toplevels 0))
#!+sb-show (declare (type fixnum index-in-cold-toplevels))
(dolist (toplevel-thing (prog1
(nreverse *!reversed-cold-toplevels*)
(gc-cold-init-or-reinit)
(setf (sb!alien:extern-alien "internal_errors_enabled" boolean) t)
(set-floating-point-modes :traps
- ;; PRINT seems to not like x86 NPX denormal
- ;; floats like LEAST-NEGATIVE-SINGLE-FLOAT, so
- ;; the :UNDERFLOW exceptions are disabled by
- ;; default. Joe User can explicitly enable them
- ;; if desired.
- '(:overflow #!-x86 :underflow :invalid
- :divide-by-zero))
+ '(:overflow
+ :invalid
+ :divide-by-zero
+ ;; PRINT seems not to like x86 NPX
+ ;; denormal floats like
+ ;; LEAST-NEGATIVE-SINGLE-FLOAT, so
+ ;; the :UNDERFLOW exceptions are
+ ;; disabled by default. Joe User can
+ ;; explicitly enable them if
+ ;; desired.
+ #!-x86 :underflow))
;; Clear pseudo atomic in case this core wasn't compiled with
;; support.
;;
;;;; some support for any hapless wretches who end up debugging cold
;;;; init code
-;;; Decode THING into hex using only machinery available early in cold
-;;; init.
+;;; Decode THING into hexadecimal notation using only machinery
+;;; available early in cold init.
#!+sb-show
(defun hexstr (thing)
+ (/show0 "entering HEXSTR")
(let ((addr (sb!kernel:get-lisp-obj-address thing))
(str (make-string 10)))
+ (/show0 "ADDR and STR calculated")
(setf (char str 0) #\0
(char str 1) #\x)
+ (/show0 "CHARs 0 and 1 set")
(dotimes (i 8)
+ (/show0 "at head of DOTIMES loop")
(let* ((nibble (ldb (byte 4 0) addr))
(chr (char "0123456789abcdef" nibble)))
(declare (type (unsigned-byte 4) nibble)
(base-char chr))
+ (/show0 "NIBBLE and CHR calculated")
(setf (char str (- 9 i)) chr
addr (ash addr -4))))
str))
(cell nil :type (or cons null)))
(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
- ;; the appropriate initialization value for the CPL slot of a CONDITION,
- ;; calculated by looking at the INHERITS information in the LAYOUT
- ;; of the CONDITION
+ ;; the appropriate initialization value for the CPL slot of a
+ ;; CONDITION, calculated by looking at the INHERITS information in
+ ;; the LAYOUT of the CONDITION
(defun condition-class-cpl-from-layout (condition)
(declare (type condition condition))
(let* ((class (sb!xc:find-class condition))
\f
;;;; slots of CONDITION objects
-(defvar *empty-slot* '(empty))
+(defvar *empty-condition-slot* '(empty))
(defun find-slot-default (class slot)
(let ((initargs (condition-slot-initargs slot))
(dolist (class cpl)
(let ((default-initargs (condition-class-default-initargs class)))
(dolist (initarg initargs)
- (let ((val (getf default-initargs initarg *empty-slot*)))
- (unless (eq val *empty-slot*)
+ (let ((val (getf default-initargs initarg *empty-condition-slot*)))
+ (unless (eq val *empty-condition-slot*)
(return-from find-slot-default
(if (functionp val)
(funcall val)
initform))
(error "unbound condition slot: ~S" (condition-slot-name slot)))))
-(defun find-slot (classes name)
- (dolist (sclass classes nil)
+(defun find-condition-class-slot (condition-class slot-name)
+ (dolist (sclass
+ (condition-class-cpl condition-class)
+ (error "There is no slot named ~S in ~S."
+ slot-name condition-class))
(dolist (slot (condition-class-slots sclass))
- (when (eq (condition-slot-name slot) name)
- (return-from find-slot slot)))))
+ (when (eq (condition-slot-name slot) slot-name)
+ (return-from find-condition-class-slot slot)))))
(defun condition-writer-function (condition new-value name)
(dolist (cslot (condition-class-class-slots
(car (condition-slot-cell cslot)))))
(let ((val (getf (condition-assigned-slots condition) name
- *empty-slot*)))
- (if (eq val *empty-slot*)
+ *empty-condition-slot*)))
+ (if (eq val *empty-condition-slot*)
(let ((actual-initargs (condition-actual-initargs condition))
- (slot (find-slot (condition-class-cpl class) name)))
+ (slot (find-condition-class-slot class name)))
(dolist (initarg (condition-slot-initargs slot))
- (let ((val (getf actual-initargs initarg *empty-slot*)))
- (unless (eq val *empty-slot*)
+ (let ((val (getf actual-initargs
+ initarg
+ *empty-condition-slot*)))
+ (unless (eq val *empty-condition-slot*)
(return-from condition-reader-function
(setf (getf (condition-assigned-slots condition)
name)
;; Set any class slots with initargs present in this call.
(dolist (cslot (condition-class-class-slots class))
(dolist (initarg (condition-slot-initargs cslot))
- (let ((val (getf args initarg *empty-slot*)))
- (unless (eq val *empty-slot*)
+ (let ((val (getf args initarg *empty-condition-slot*)))
+ (unless (eq val *empty-condition-slot*)
(setf (car (condition-slot-cell cslot)) val)))))
;; Default any slots with non-constant defaults now.
(dolist (hslot (condition-class-hairy-slots class))
(when (dolist (initarg (condition-slot-initargs hslot) t)
- (unless (eq (getf args initarg *empty-slot*) *empty-slot*)
+ (unless (eq (getf args initarg *empty-condition-slot*)
+ *empty-condition-slot*)
(return nil)))
(setf (getf (condition-assigned-slots res) (condition-slot-name hslot))
(find-slot-default class hslot))))
#'(lambda (new-value condition)
(condition-writer-function condition new-value name))))))
- ;; Compute effective slots and set up the class and hairy slots (subsets of
- ;; the effective slots.)
+ ;; Compute effective slots and set up the class and hairy slots
+ ;; (subsets of the effective slots.)
(let ((eslots (compute-effective-slots class))
(e-def-initargs
(reduce #'append
(if (functionp initform)
(funcall initform)
initform))
- *empty-slot*))))
+ *empty-condition-slot*))))
(push slot (condition-class-class-slots class)))
((:instance nil)
(setf (condition-slot-allocation slot) :instance)
(define-condition style-warning (warning) ())
(defun simple-condition-printer (condition stream)
- ;; FIXME: Why use APPLY instead of an ordinary form? To stop the optimizer
- ;; from doing something?
(apply #'format stream (simple-condition-format-control condition)
(simple-condition-format-arguments condition)))
(define-condition storage-condition (serious-condition) ())
-;;; FIXME: Should we really be reporting CONDITION-FUNCTION-NAME data on an
-;;; ad hoc basis, for some conditions and not others? Why not standardize
-;;; it somehow? perhaps by making the debugger report it?
+;;; FIXME: Should we really be reporting CONDITION-FUNCTION-NAME data
+;;; on an ad hoc basis, for some conditions and not others? Why not
+;;; standardize it somehow? perhaps by making the debugger report it?
(define-condition type-error (error)
((datum :reader type-error-datum :initarg :datum)
"Transfer control to a restart named ABORT, signalling a CONTROL-ERROR if
none exists."
(invoke-restart (find-restart 'abort condition))
- ;; ABORT signals an error in case there was a restart named ABORT that did
- ;; not transfer control dynamically. This could happen with RESTART-BIND.
+ ;; ABORT signals an error in case there was a restart named ABORT
+ ;; that did not transfer control dynamically. This could happen with
+ ;; RESTART-BIND.
(error 'abort-failure))
(defun muffle-warning (&optional condition)
:format-control "~S cannot be coerced to a string."
:format-arguments (list x)))))
-;;; With-One-String is used to set up some string hacking things. The keywords
-;;; are parsed, and the string is hacked into a simple-string.
-
(eval-when (:compile-toplevel)
-
-(sb!xc:defmacro with-one-string (string start end cum-offset &rest forms)
+;;; WITH-ONE-STRING is used to set up some string hacking things. The
+;;; keywords are parsed, and the string is hacked into a
+;;; simple-string.
+(sb!xc:defmacro with-one-string ((string start end) &body forms)
`(let ((,string (if (stringp ,string) ,string (string ,string))))
- (with-array-data ((,string ,string :offset-var ,cum-offset)
+ (with-array-data ((,string ,string)
(,start ,start)
(,end (or ,end (length (the vector ,string)))))
,@forms)))
-
-) ; EVAN-WHEN
-
-;;; With-String is like With-One-String, but doesn't parse keywords.
-
-(eval-when (:compile-toplevel)
-
+;;; WITH-STRING is like WITH-ONE-STRING, but doesn't parse keywords.
(sb!xc:defmacro with-string (string &rest forms)
`(let ((,string (if (stringp ,string) ,string (string ,string))))
(with-array-data ((,string ,string)
(start)
(end (length (the vector ,string))))
,@forms)))
-
-) ; EVAL-WHEN
-
-;;; With-Two-Strings is used to set up string comparison operations. The
-;;; keywords are parsed, and the strings are hacked into simple-strings.
-
-(eval-when (:compile-toplevel)
-
+;;; WITH-TWO-STRINGS is used to set up string comparison operations. The
+;;; keywords are parsed, and the strings are hacked into SIMPLE-STRINGs.
(sb!xc:defmacro with-two-strings (string1 string2 start1 end1 cum-offset-1
start2 end2 &rest forms)
`(let ((,string1 (if (stringp ,string1) ,string1 (string ,string1)))
(,start2 ,start2)
(,end2 (or ,end2 (length (the vector ,string2)))))
,@forms))))
-
) ; EVAL-WHEN
(defun char (string index)
(- (the fixnum index) ,offset1))
(t nil))
,(if equalp `(- (the fixnum end1) ,offset1) 'nil))))))
-) ; eval-when
+) ; EVAL-WHEN
(defun string<* (string1 string2 start1 end1 start2 end2)
(declare (fixnum start1 start2))
(slen2 (- end2 start2)))
(declare (fixnum slen1 slen2))
(if (or (minusp slen1) (minusp slen2))
- ;;prevent endless looping later.
+ ;; Prevent endless looping later.
(error "Improper bounds for string comparison."))
(cond ((or (minusp slen1) (or (minusp slen2)))
(error "Improper substring for comparison."))
(setf (schar string i) fill-char))
(make-string count)))
+(flet ((frob (string start end)
+ (declare (string string) (index start) (type (or index null end)))
+ (let ((save-header string))
+ (with-one-string (string start end)
+ (do ((index start (1+ index)))
+ ((= index (the fixnum end)))
+ (declare (fixnum index))
+ (setf (schar string index) (char-upcase (schar string index)))))
+ save-header)))
(defun string-upcase (string &key (start 0) end)
- #!+sb-doc
- "Given a string, returns a new string that is a copy of it with
- all lower case alphabetic characters converted to uppercase."
- (declare (fixnum start))
- (let* ((string (if (stringp string) string (string string)))
- (slen (length string)))
- (declare (fixnum slen))
- (with-one-string string start end offset
- (let ((offset-slen (+ slen offset))
- (newstring (make-string slen)))
- (declare (fixnum offset-slen))
- (do ((index offset (1+ index))
- (new-index 0 (1+ new-index)))
- ((= index start))
- (declare (fixnum index new-index))
- (setf (schar newstring new-index) (schar string index)))
- (do ((index start (1+ index))
- (new-index (- start offset) (1+ new-index)))
- ((= index (the fixnum end)))
- (declare (fixnum index new-index))
- (setf (schar newstring new-index)
- (char-upcase (schar string index))))
- (do ((index end (1+ index))
- (new-index (- (the fixnum end) offset) (1+ new-index)))
- ((= index offset-slen))
- (declare (fixnum index new-index))
- (setf (schar newstring new-index) (schar string index)))
- newstring))))
-
-(defun string-downcase (string &key (start 0) end)
- #!+sb-doc
- "Given a string, returns a new string that is a copy of it with
- all upper case alphabetic characters converted to lowercase."
- (declare (fixnum start))
- (let* ((string (if (stringp string) string (string string)))
- (slen (length string)))
- (declare (fixnum slen))
- (with-one-string string start end offset
- (let ((offset-slen (+ slen offset))
- (newstring (make-string slen)))
- (declare (fixnum offset-slen))
- (do ((index offset (1+ index))
- (new-index 0 (1+ new-index)))
- ((= index start))
- (declare (fixnum index new-index))
- (setf (schar newstring new-index) (schar string index)))
- (do ((index start (1+ index))
- (new-index (- start offset) (1+ new-index)))
- ((= index (the fixnum end)))
- (declare (fixnum index new-index))
- (setf (schar newstring new-index)
- (char-downcase (schar string index))))
- (do ((index end (1+ index))
- (new-index (- (the fixnum end) offset) (1+ new-index)))
- ((= index offset-slen))
- (declare (fixnum index new-index))
- (setf (schar newstring new-index) (schar string index)))
- newstring))))
-
-(defun string-capitalize (string &key (start 0) end)
- #!+sb-doc
- "Given a string, returns a copy of the string with the first
- character of each ``word'' converted to upper-case, and remaining
- chars in the word converted to lower case. A ``word'' is defined
- to be a string of case-modifiable characters delimited by
- non-case-modifiable chars."
- (declare (fixnum start))
- (let* ((string (if (stringp string) string (string string)))
- (slen (length string)))
- (declare (fixnum slen))
- (with-one-string string start end offset
- (let ((offset-slen (+ slen offset))
- (newstring (make-string slen)))
- (declare (fixnum offset-slen))
- (do ((index offset (1+ index))
- (new-index 0 (1+ new-index)))
- ((= index start))
- (declare (fixnum index new-index))
- (setf (schar newstring new-index) (schar string index)))
- (do ((index start (1+ index))
- (new-index (- start offset) (1+ new-index))
- (newword t)
- (char ()))
- ((= index (the fixnum end)))
- (declare (fixnum index new-index))
- (setq char (schar string index))
- (cond ((not (alphanumericp char))
- (setq newword t))
- (newword
- ;;char is first case-modifiable after non-case-modifiable
- (setq char (char-upcase char))
- (setq newword ()))
- ;;char is case-modifiable, but not first
- (t (setq char (char-downcase char))))
- (setf (schar newstring new-index) char))
- (do ((index end (1+ index))
- (new-index (- (the fixnum end) offset) (1+ new-index)))
- ((= index offset-slen))
- (declare (fixnum index new-index))
- (setf (schar newstring new-index) (schar string index)))
- newstring))))
-
+ (frob (copy-seq string) start end))
(defun nstring-upcase (string &key (start 0) end)
- #!+sb-doc
- "Given a string, returns that string with all lower case alphabetic
- characters converted to uppercase."
- (declare (fixnum start))
- (let ((save-header string))
- (with-one-string string start end offset
- (do ((index start (1+ index)))
- ((= index (the fixnum end)))
- (declare (fixnum index))
- (setf (schar string index) (char-upcase (schar string index)))))
- save-header))
-
+ (frob string start end))
+) ; FLET
+
+(flet ((frob (string start end)
+ (declare (string string) (index start) (type (or index null end)))
+ (let ((save-header string))
+ (with-one-string (string start end)
+ (do ((index start (1+ index)))
+ ((= index (the fixnum end)))
+ (declare (fixnum index))
+ (setf (schar string index)
+ (char-downcase (schar string index)))))
+ save-header)))
+(defun string-downcase (string &key (start 0) end)
+ (frob (copy-seq string) start end))
(defun nstring-downcase (string &key (start 0) end)
- #!+sb-doc
- "Given a string, returns that string with all upper case alphabetic
- characters converted to lowercase."
- (declare (fixnum start))
- (let ((save-header string))
- (with-one-string string start end offset
- (do ((index start (1+ index)))
- ((= index (the fixnum end)))
- (declare (fixnum index))
- (setf (schar string index) (char-downcase (schar string index)))))
- save-header))
-
+ (frob string start end))
+) ; FLET
+
+(flet ((frob (string start end)
+ (declare (string string) (index start) (type (or index null end)))
+ (let ((save-header string))
+ (with-one-string (string start end)
+ (do ((index start (1+ index))
+ (newword t)
+ (char ()))
+ ((= index (the fixnum end)))
+ (declare (fixnum index))
+ (setq char (schar string index))
+ (cond ((not (alphanumericp char))
+ (setq newword t))
+ (newword
+ ;; CHAR is the first case-modifiable character after
+ ;; a sequence of non-case-modifiable characters.
+ (setf (schar string index) (char-upcase char))
+ (setq newword ()))
+ (t
+ (setf (schar string index) (char-downcase char))))))
+ save-header)))
+(defun string-capitalize (string &key (start 0) end)
+ (frob (copy-seq string) start end))
(defun nstring-capitalize (string &key (start 0) end)
- #!+sb-doc
- "Given a string, returns that string with the first
- character of each ``word'' converted to upper-case, and remaining
- chars in the word converted to lower case. A ``word'' is defined
- to be a string of case-modifiable characters delimited by
- non-case-modifiable chars."
- (declare (fixnum start))
- (let ((save-header string))
- (with-one-string string start end offset
- (do ((index start (1+ index))
- (newword t)
- (char ()))
- ((= index (the fixnum end)))
- (declare (fixnum index))
- (setq char (schar string index))
- (cond ((not (alphanumericp char))
- (setq newword t))
- (newword
- ;;char is first case-modifiable after non-case-modifiable
- (setf (schar string index) (char-upcase char))
- (setq newword ()))
- (t
- (setf (schar string index) (char-downcase char))))))
- save-header))
+ (frob string start end))
+) ; FLET
(defun string-left-trim (char-bag string)
- #!+sb-doc
- "Given a set of characters (a list or string) and a string, returns
- a copy of the string with the characters in the set removed from the
- left end."
(with-string string
(do ((index start (1+ index)))
((or (= index (the fixnum end))
(declare (fixnum index)))))
(defun string-right-trim (char-bag string)
- #!+sb-doc
- "Given a set of characters (a list or string) and a string, returns
- a copy of the string with the characters in the set removed from the
- right end."
(with-string string
(do ((index (1- (the fixnum end)) (1- index)))
((or (< index start)
(declare (fixnum index)))))
(defun string-trim (char-bag string)
- #!+sb-doc
- "Given a set of characters (a list or string) and a string, returns a
- copy of the string with the characters in the set removed from both
- ends."
(with-string string
(let* ((left-end (do ((index start (1+ index)))
((or (= index (the fixnum end))
;;; bindings of START-VAR and END-VAR. OFFSET-VAR is the cumulative
;;; offset of all displacements encountered, and does not include
;;; SVALUE.
-(defmacro with-array-data (((data-var array &key (offset-var (gensym)))
+(defmacro with-array-data (((data-var array &key offset-var)
(start-var &optional (svalue 0))
(end-var &optional (evalue nil)))
&body forms)
(once-only ((n-array array)
(n-svalue `(the index ,svalue))
(n-evalue `(the (or index null) ,evalue)))
- `(multiple-value-bind (,data-var ,start-var ,end-var ,offset-var)
+ `(multiple-value-bind (,data-var
+ ,start-var
+ ,end-var
+ ,@(when offset-var `(,offset-var)))
(if (not (array-header-p ,n-array))
(let ((,n-array ,n-array))
(declare (type (simple-array * (*)) ,n-array))
,(once-only ((n-len `(length ,n-array))
(n-end `(or ,n-evalue ,n-len)))
`(if (<= ,n-svalue ,n-end ,n-len)
+ ;; success
(values ,n-array ,n-svalue ,n-end 0)
- (%with-array-data ,n-array ,n-svalue ,n-evalue))))
+ ;; failure: Make a NOTINLINE call to
+ ;; %WITH-ARRAY-DATA with our bad data
+ ;; to cause the error to be signalled.
+ (locally
+ (declare (notinline %with-array-data))
+ (%with-array-data ,n-array ,n-svalue ,n-evalue)))))
(%with-array-data ,n-array ,n-svalue ,n-evalue))
- (declare (ignorable ,offset-var))
,@forms)))
#!-gengc
(cond (name
(write-string (string-capitalize name) stream))
((<= 0 (char-code char) 31)
- ;; Print control characters as "^"<char>
+ ;; Print control characters as "^"<char>. (This seems to be
+ ;; old pre-ANSI behavior, but ANSI just says that the "#^"
+ ;; sequence is undefined and not reserved for the user, so
+ ;; this behavior should be ANSI-compliant.)
(write-char #\^ stream)
(write-char (code-char (+ 64 (char-code char))) stream))
(t
\f
;;;; array accessors
+;;; FIXME: This was commented out in sbcl-0.6.9.21 since it was
+;;; causing a problem in a CHAR form in HEXSTR. It's still important
+;;; to be able to inline this, so something along these lines
+;;; will probably be back, but it might be different in detail, e.g.
+;;; (DECLAIM (MAYBE-INLINE %WITH-ARRAY-DATA)).
+#|
;;; Handle the 1-dimensional case of %WITH-ARRAY-DATA specially. It's
;;; important to do this efficiently if we want people to be able to
;;; use vectors with fill pointers anywhere near inner loops, and
;;; hence it's important to do this efficiently if we want people to
;;; be able to use sequence functions anywhere near inner loops.
(deftransform %with-array-data ((array start end)
- (vector index index)
+ (vector index (or index null))
*
:important t
:node node
(element-type-specifier (type-specifier element-ctype))
(simple-array-type `(simple-array ,element-type-specifier 1)))
(declare (type ctype element-ctype))
- #|
- (when (eq element-type-specifier '*)
- (give-up-ir1-transform
- "upgraded array element type not known at compile time"))
- |#
`(let* (;; FIXME: Instead of doing this hairy expression for SIZE,
;; it should just be (ARRAY-DIMENSION ARRAY 0), and there
;; should be a DEFTRANSFORM for ARRAY-DIMENSION which
(error "The start of vector data was out of range."))
(defun vector-data-end-out-of-range ()
(error "The end of vector data was out of range."))
+|#
;;; We convert all typed array accessors into AREF and %ASET with type
;;; assertions on the array.
(when (and rejected
(policy call (> speed inhibit-warnings)))
(note-rejected-templates call ltn-policy template))
- ;; If we are forced to do a full call, we check to see whether the
- ;; function called is the same as the current function. If so, we
- ;; give a warning, as this is probably a botched interpreter stub.
+ ;; If we are forced to do a full call, we check to see whether
+ ;; the function called is the same as the current function. If
+ ;; so, we give a warning, as this is probably a botched attempt
+ ;; to implement an out-of-line version in terms of inline
+ ;; transforms or VOPs or whatever.
(unless template
(when (and (eq (continuation-function-name (combination-fun call))
(leaf-name
(ir1-attributep (function-info-attributes info)
recursive)))))
(let ((*compiler-error-context* call))
- (compiler-warning "recursive known function definition")))
+ (compiler-warning "recursion in known function definition~2I ~
+ ~_arg types=~S"
+ (mapcar (lambda (arg)
+ (type-specifier (continuation-type
+ arg)))
+ args))))
(ltn-default-call call ltn-policy)
(return-from ltn-analyze-known-call (values)))
(setf (basic-combination-info call) template)
;;; versions, and a string like "0.6.5.12" is used for versions which
;;; aren't released but correspond only to CVS tags or snapshots.
-"0.6.9.20"
+"0.6.9.21"
projects / sbcl.git / commitdiff