From: William Harold Newman Date: Mon, 8 Jan 2001 03:44:51 +0000 (+0000) Subject: 0.6.9.21: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=79953929196409f21fe505b29b15d2a9281884b7;p=sbcl.git 0.6.9.21: strengthened condition system error-checking to fix the bug reported by Eric Marsden on cmucl-imp@cons.org 2001-01-06 undid DEFTRANSFORM %WITH-ARRAY-DATA since it didn't work right WITH-ARRAY-DATA :OFFSET-VAR stuff tidied up (e.g. no longer IGNORABLE) replaced amazing old STRING-FOO functions with smaller, simpler, slightly slower versions --- diff --git a/BUGS b/BUGS index 25eaf5d..0e4abea 100644 --- a/BUGS +++ b/BUGS @@ -173,10 +173,6 @@ WORKAROUND: (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. @@ -340,6 +336,11 @@ returning an array as first value always. 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)) diff --git a/CREDITS b/CREDITS index eeedcec..31bc3c2 100644 --- a/CREDITS +++ b/CREDITS @@ -497,7 +497,7 @@ Cadabra, Inc. (later merged into GoTo.com): 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 diff --git a/NEWS b/NEWS index df35d22..00e8230 100644 --- a/NEWS +++ b/NEWS @@ -647,3 +647,7 @@ planned incompatible changes in 0.7.x: 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.) diff --git a/src/code/array.lisp b/src/code/array.lisp index 3e94740..b8a9fcd 100644 --- a/src/code/array.lisp +++ b/src/code/array.lisp @@ -17,8 +17,8 @@ ;;;; 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) @@ -46,9 +46,8 @@ (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 @@ -97,11 +96,11 @@ ;;; 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. @@ -175,8 +174,6 @@ (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) @@ -668,8 +665,8 @@ &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)) @@ -714,9 +711,9 @@ (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 @@ -729,13 +726,13 @@ 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.")) @@ -901,7 +898,7 @@ ;;;; 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)) @@ -919,14 +916,15 @@ :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)) @@ -964,9 +962,9 @@ 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)) diff --git a/src/code/cold-init.lisp b/src/code/cold-init.lisp index b6dd324..d3417f2 100644 --- a/src/code/cold-init.lisp +++ b/src/code/cold-init.lisp @@ -142,11 +142,17 @@ ;; 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*) @@ -280,13 +286,17 @@ instead (which is another name for the same thing).")) (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. ;; @@ -301,19 +311,24 @@ instead (which is another name for the same thing).")) ;;;; 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)) diff --git a/src/code/late-target-error.lisp b/src/code/late-target-error.lisp index 7c28116..8fc3f32 100644 --- a/src/code/late-target-error.lisp +++ b/src/code/late-target-error.lisp @@ -78,9 +78,9 @@ (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)) @@ -166,7 +166,7 @@ ;;;; 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)) @@ -174,8 +174,8 @@ (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) @@ -188,11 +188,14 @@ 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 @@ -210,13 +213,15 @@ (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) @@ -254,13 +259,14 @@ ;; 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)))) @@ -365,8 +371,8 @@ #'(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 @@ -382,7 +388,7 @@ (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) @@ -537,8 +543,6 @@ (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))) @@ -566,9 +570,9 @@ (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) @@ -763,8 +767,9 @@ "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) diff --git a/src/code/string.lisp b/src/code/string.lisp index ec9c7a0..3ffae90 100644 --- a/src/code/string.lisp +++ b/src/code/string.lisp @@ -27,38 +27,25 @@ :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))) @@ -70,7 +57,6 @@ (,start2 ,start2) (,end2 (or ,end2 (length (the vector ,string2))))) ,@forms)))) - ) ; EVAL-WHEN (defun char (string index) @@ -131,7 +117,7 @@ (- (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)) @@ -252,7 +238,7 @@ (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.")) @@ -366,166 +352,64 @@ (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)) @@ -534,10 +418,6 @@ (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) @@ -546,10 +426,6 @@ (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)) diff --git a/src/code/sysmacs.lisp b/src/code/sysmacs.lisp index 9f7fc9d..b9e4436 100644 --- a/src/code/sysmacs.lisp +++ b/src/code/sysmacs.lisp @@ -23,24 +23,32 @@ ;;; 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 diff --git a/src/code/target-format.lisp b/src/code/target-format.lisp index e362550..78001b9 100644 --- a/src/code/target-format.lisp +++ b/src/code/target-format.lisp @@ -229,7 +229,10 @@ (cond (name (write-string (string-capitalize name) stream)) ((<= 0 (char-code char) 31) - ;; Print control characters as "^" + ;; Print control characters as "^". (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 diff --git a/src/compiler/array-tran.lisp b/src/compiler/array-tran.lisp index 2e22234..945e154 100644 --- a/src/compiler/array-tran.lisp +++ b/src/compiler/array-tran.lisp @@ -425,13 +425,19 @@ ;;;; 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 @@ -441,11 +447,6 @@ (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 @@ -477,6 +478,7 @@ (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. diff --git a/src/compiler/ltn.lisp b/src/compiler/ltn.lisp index 9a2570a..e102f64 100644 --- a/src/compiler/ltn.lisp +++ b/src/compiler/ltn.lisp @@ -888,9 +888,11 @@ (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 @@ -901,7 +903,12 @@ (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) diff --git a/version.lisp-expr b/version.lisp-expr index 2fe4feb..eaf0446 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -15,4 +15,4 @@ ;;; 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"