name conflict situations in CLHS 11.1.1.2.5, and provide a restart
permitting resolution in favour of any of the conflicting symbols.
(reported by Bruno Haible for CMUCL)
+ * bug fix: EQUAL compiler optimizations is less aggressive on
+ strings which can potentially compare true despite having distinct
+ specialized array element types.
* FORMAT compile-time argument count checking has been enhanced.
(report from Bruno Haible for CMUCL)
* fixed some bugs revealed by Paul Dietz' test suite:
(index 0) ; current index in current buffer
(total 0)) ; total characters
(declare (type simple-stream encap)
- (type simple-base-string cbuf)
+ (type simple-string cbuf)
(type cons bufs tail)
(type sb-int:index index total))
(loop
(do ((list bufs (cdr list)))
((eq list tail))
(let ((buf (car list)))
- (declare (type simple-base-string buf))
+ (declare (type simple-string buf))
(replace cbuf buf :start1 idx)
(incf idx (length buf)))))
(return (values (sb-kernel:shrink-vector cbuf total)
(index 0))
(declare (type sb-int:index index))
(dolist (buf bufs)
- (declare (type simple-base-string buf))
+ (declare (type simple-string buf))
(replace string buf :start1 index)
(incf index (length buf)))
(return (values string (eq done :eof)))))
(make-member-type :members (list x)))
(number
(ctype-of-number x))
+ (string
+ (make-array-type :dimensions (array-dimensions x)
+ :complexp (not (typep x 'simple-array))
+ :element-type (specifier-type 'base-char)
+ :specialized-element-type (specifier-type 'base-char)))
(array
(let ((etype (specifier-type (array-element-type x))))
(make-array-type :dimensions (array-dimensions x)
(values absolute (pieces)))))
(defun parse-unix-namestring (namestr start end)
- (declare (type simple-base-string namestr)
+ (declare (type simple-string namestr)
(type index start end))
+ (setf namestr (coerce namestr 'simple-base-string))
(multiple-value-bind (absolute pieces) (split-at-slashes namestr start end)
(multiple-value-bind (name type version)
(let* ((tail (car (last pieces)))
(t
(error "invalid pattern piece: ~S" piece))))))
(apply #'concatenate
- 'simple-string
+ 'simple-base-string
(strings))))))
(defun unparse-unix-directory-list (directory)
(pieces "/"))
(t
(error "invalid directory component: ~S" dir)))))
- (apply #'concatenate 'simple-string (pieces))))
+ (apply #'concatenate 'simple-base-string (pieces))))
(defun unparse-unix-directory (pathname)
(declare (type pathname pathname))
(when type-supplied
(unless name
(error "cannot specify the type without a file: ~S" pathname))
- (when (typep type 'simple-base-string)
+ (when (typep type 'simple-string)
(when (position #\. type)
(error "type component can't have a #\. inside: ~S" pathname)))
(strings ".")
(strings (unparse-unix-piece type))))
- (apply #'concatenate 'simple-string (strings))))
+ (apply #'concatenate 'simple-base-string (strings))))
(/show0 "filesys.lisp 406")
(defun unparse-unix-namestring (pathname)
(declare (type pathname pathname))
- (concatenate 'simple-string
+ (concatenate 'simple-base-string
(unparse-unix-directory pathname)
(unparse-unix-file pathname)))
(/noshow0 "computed NAME, TYPE, and VERSION")
(cond ((member name '(nil :unspecific))
(/noshow0 "UNSPECIFIC, more or less")
- (when (or (not verify-existence)
- (sb!unix:unix-file-kind directory))
- (funcall function directory)))
+ (let ((directory (coerce directory 'base-string)))
+ (when (or (not verify-existence)
+ (sb!unix:unix-file-kind directory))
+ (funcall function directory))))
((or (pattern-p name)
(pattern-p type)
(eq name :wild)
:device (pathname-device pathname)
:directory (subseq dir 0 i))))
(unless (probe-file newpath)
- (let ((namestring (namestring newpath)))
+ (let ((namestring (coerce (namestring newpath) 'base-string)))
(when verbose
(format *standard-output*
"~&creating directory: ~A~%"
(defun read-string-as-bytes (stream string &optional (length (length string)))
(dotimes (i length)
(setf (aref string i)
- (code-char (read-byte stream))))
+ (sb!xc:code-char (read-byte stream))))
;; FIXME: The classic CMU CL code to do this was
;; (READ-N-BYTES FILE STRING START END).
;; It was changed for SBCL because we needed a portable version for
(define-alien-type-class (c-string :include pointer :include-args (to)))
(define-alien-type-translator c-string ()
- (make-alien-c-string-type :to
- (parse-alien-type 'char
- (sb!kernel::make-null-lexenv))))
+ (make-alien-c-string-type
+ :to (parse-alien-type 'char (sb!kernel:make-null-lexenv))))
(define-alien-type-method (c-string :unparse) (type)
(declare (ignore type))
(define-alien-type-method (c-string :lisp-rep) (type)
(declare (ignore type))
- '(or simple-base-string null (alien (* char))))
+ '(or simple-string null (alien (* char))))
(define-alien-type-method (c-string :naturalize-gen) (type alien)
(declare (ignore type))
`(etypecase ,value
(null (int-sap 0))
((alien (* char)) (alien-sap ,value))
- (simple-base-string (vector-sap ,value))))
+ (simple-base-string (vector-sap ,value))
+ (simple-string (vector-sap (coerce ,value 'simple-base-string)))))
(/show0 "host-c-call.lisp 42")
(string (missing-arg) :type simple-string)
(start (missing-arg) :type (and unsigned-byte fixnum))
(end (missing-arg) :type (and unsigned-byte fixnum))
- (character (missing-arg) :type base-char)
+ (character (missing-arg) :type character)
(colonp nil :type (member t nil))
(atsignp nil :type (member t nil))
(params nil :type list))
(etypecase directive
(format-directive
(let ((expander
- (aref *format-directive-expanders*
- (char-code (format-directive-character directive))))
+ (let ((char (format-directive-character directive)))
+ (typecase char
+ (base-char
+ (aref *format-directive-expanders* (char-code char)))
+ (character nil))))
(*default-format-error-offset*
(1- (format-directive-end directive))))
(declare (type (or null function) expander))
(defun pretty-out (stream char)
(declare (type pretty-stream stream)
- (type base-char char))
+ (type character char))
(cond ((char= char #\newline)
(enqueue-newline stream :literal))
(t
'(integer #.(1+ sb!xc:most-positive-fixnum))
'bignum))
(standard-char 'standard-char)
+ (base-char 'base-char)
+ (extended-char 'extended-char)
((member t) 'boolean)
(keyword 'keyword)
((or array complex) (type-specifier (ctype-of object)))
;;; producing a symbol in the current package.
(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
(defun symbolicate (&rest things)
- (let ((name (case (length things)
- ;; Why isn't this just the value in the T branch?
- ;; Well, this is called early in cold-init, before
- ;; the type system is set up; however, now that we
- ;; check for bad lengths, the type system is needed
- ;; for calls to CONCATENATE. So we need to make sure
- ;; that the calls are transformed away:
- (1 (concatenate 'string
- (the simple-base-string
- (string (car things)))))
- (2 (concatenate 'string
- (the simple-base-string
- (string (car things)))
- (the simple-base-string
- (string (cadr things)))))
- (3 (concatenate 'string
- (the simple-base-string
- (string (car things)))
- (the simple-base-string
- (string (cadr things)))
- (the simple-base-string
- (string (caddr things)))))
- (t (apply #'concatenate 'string (mapcar #'string things))))))
- (values (intern name)))))
+ (let* ((length (reduce #'+ things
+ :key (lambda (x) (length (string x)))))
+ (name (make-array length :element-type 'character)))
+ (let ((index 0))
+ (dolist (thing things (values (intern name)))
+ (let* ((x (string thing))
+ (len (length x)))
+ (replace name x :start1 index)
+ (incf index len)))))))
;;; like SYMBOLICATE, but producing keywords
(defun keywordicate (&rest things)
;;; Is UNIX-FILENAME the name of a file that we can execute?
(defun unix-filename-is-executable-p (unix-filename)
(declare (type simple-string unix-filename))
+ (setf unix-filename (coerce unix-filename 'base-string))
(values (and (eq (sb-unix:unix-file-kind unix-filename) :file)
(sb-unix:unix-access unix-filename sb-unix:x_ok))))
(:include string-stream
(in #'string-inch)
(bin #'ill-bin)
- (n-bin #'string-stream-read-n-bytes)
+ (n-bin #'ill-bin)
(misc #'string-in-misc)
(string (missing-arg) :type simple-string))
(:constructor internal-make-string-input-stream
(defun case-frob-upcase-sout (stream str start end)
(declare (type case-frob-stream stream)
- (type simple-base-string str)
+ (type simple-string str)
(type index start)
(type (or index null) end))
(let* ((target (case-frob-stream-target stream))
(defun case-frob-downcase-sout (stream str start end)
(declare (type case-frob-stream stream)
- (type simple-base-string str)
+ (type simple-string str)
(type index start)
(type (or index null) end))
(let* ((target (case-frob-stream-target stream))
(defun case-frob-capitalize-sout (stream str start end)
(declare (type case-frob-stream stream)
- (type simple-base-string str)
+ (type simple-string str)
(type index start)
(type (or index null) end))
(let* ((target (case-frob-stream-target stream))
(defun case-frob-capitalize-aux-sout (stream str start end)
(declare (type case-frob-stream stream)
- (type simple-base-string str)
+ (type simple-string str)
(type index start)
(type (or index null) end))
(let* ((target (case-frob-stream-target stream))
(defun case-frob-capitalize-first-sout (stream str start end)
(declare (type case-frob-stream stream)
- (type simple-base-string str)
+ (type simple-string str)
(type index start)
(type (or index null) end))
(let* ((target (case-frob-stream-target stream))
(multiple-value-bind (new-directives new-args)
(let* ((character (format-directive-character directive))
(function
+ (typecase character
+ (base-char
(svref *format-directive-interpreters*
(char-code character)))
+ (character nil)))
(*default-format-error-offset*
(1- (format-directive-end directive))))
(unless function
(or (eq thing wild)
(eq wild :wild)
(typecase thing
- (simple-base-string
+ (simple-string
;; String is matched by itself, a matching pattern or :WILD.
(typecase wild
(pattern
(values (pattern-matches wild thing)))
- (simple-base-string
+ (simple-string
(string= thing wild))))
(pattern
;; A pattern is only matched by an identical pattern.
(dolist (x in)
(when (check-for pred x)
(return t))))
- (simple-base-string
+ (simple-string
(dotimes (i (length in))
(when (funcall pred (schar in i))
(return t))))
(make-pattern
(mapcar (lambda (piece)
(typecase piece
- (simple-base-string
+ (simple-string
(funcall fun piece))
(cons
(case (car piece)
(pattern-pieces thing))))
(list
(mapcar fun thing))
- (simple-base-string
+ (simple-string
(funcall fun thing))
(t
thing))))
;;; If NAMESTR begins with a colon-terminated, defined, logical host,
;;; then return that host, otherwise return NIL.
(defun extract-logical-host-prefix (namestr start end)
- (declare (type simple-base-string namestr)
+ (declare (type simple-string namestr)
(type index start end)
(values (or logical-host null)))
(let ((colon-pos (position #\: namestr :start start :end end)))
(defun substitute-into (pattern subs diddle-case)
(declare (type pattern pattern)
(type list subs)
- (values (or simple-base-string pattern) list))
+ (values (or simple-string pattern) list))
(let ((in-wildcard nil)
(pieces nil)
(strings nil))
(let ((word (string-upcase word)))
(dotimes (i (length word))
(let ((ch (schar word i)))
- (unless (or (alpha-char-p ch) (digit-char-p ch) (char= ch #\-))
+ (unless (and (typep ch 'standard-char)
+ (or (alpha-char-p ch) (digit-char-p ch) (char= ch #\-)))
(error 'namestring-parse-error
:complaint "logical namestring character which ~
is not alphanumeric or hyphen:~% ~S"
:args (list ch)
:namestring word :offset i))))
- word))
+ (coerce word 'base-string)))
;;; Given a logical host or string, return a logical host. If ERROR-P
;;; is NIL, then return NIL when no such host exists.
;;; Break up a logical-namestring, always a string, into its
;;; constituent parts.
(defun parse-logical-namestring (namestr start end)
- (declare (type simple-base-string namestr)
+ (declare (type simple-string namestr)
(type index start end))
(collect ((directory))
(let ((host nil)
(when type-supplied
(unless name
(error "cannot specify the type without a file: ~S" pathname))
- (when (typep type 'simple-base-string)
+ (when (typep type 'simple-string)
(when (position #\. type)
(error "type component can't have a #\. inside: ~S" pathname)))
(strings ".")
(t (translate-logical-pathname (pathname pathname)))))
(defvar *logical-pathname-defaults*
- (%make-logical-pathname (make-logical-host :name "BOGUS")
- :unspecific
- nil
- nil
- nil
- nil))
+ (%make-logical-pathname
+ (make-logical-host :name (logical-word-or-lose "BOGUS"))
+ :unspecific nil nil nil nil))
(defun load-logical-pathname-translations (host)
#!+sb-doc
(declaim (inline waitqueue-data-address mutex-value-address))
(defstruct waitqueue
- (name nil :type (or null simple-base-string))
+ (name nil :type (or null simple-string))
(lock 0)
(data nil))
;;;; the higher-level locking operations are based on waitqueues
(defstruct waitqueue
- (name nil :type (or null simple-base-string))
+ (name nil :type (or null simple-string))
(lock 0)
(data nil))
;;; paths have been converted to absolute paths, so we don't need to
;;; try to handle any more generality than that.
(defun unix-resolve-links (pathname)
- (declare (type simple-string pathname))
+ (declare (type simple-base-string pathname))
(aver (not (relative-unix-pathname? pathname)))
(/noshow "entering UNIX-RESOLVE-LINKS")
(loop with previous-pathnames = nil do
:from-end t)))
(dir (subseq pathname 0 dir-len)))
(/noshow dir)
- (concatenate 'string dir link))
+ (concatenate 'base-string dir link))
link))))
(if (unix-file-kind new-pathname)
(setf pathname new-pathname)
(push pathname previous-pathnames))))
(defun unix-simplify-pathname (src)
- (declare (type simple-string src))
+ (declare (type simple-base-string src))
(let* ((src-len (length src))
- (dst (make-string src-len))
+ (dst (make-string src-len :element-type 'base-char))
(dst-len 0)
(dots 0)
(last-slash nil))
(position #\/ dst :end last-slash :from-end t)))
(if prev-prev-slash
(setf dst-len (1+ prev-prev-slash))
- (return-from unix-simplify-pathname "./")))))))
+ (return-from unix-simplify-pathname
+ (coerce "./" 'simple-base-string))))))))
(cond ((zerop dst-len)
"./")
((= dst-len src-len)
(give-up-ir1-transform
"cannot open-code creation of ~S" result-type-spec))
#-sb-xc-host
- (unless (csubtypep (ctype-of (sb!vm:saetp-initial-element-default saetp))
- eltype-type)
+ (unless (ctypep (sb!vm:saetp-initial-element-default saetp) eltype-type)
;; This situation arises e.g. in (MAKE-ARRAY 4 :ELEMENT-TYPE
;; '(INTEGER 1 5)) ANSI's definition of MAKE-ARRAY says "If
;; INITIAL-ELEMENT is not supplied, the consequences of later
;;; This structure holds the state of the assembler.
(defstruct (segment (:copier nil))
;; the name of this segment (for debugging output and stuff)
- (name "unnamed" :type simple-base-string)
+ (name "unnamed" :type simple-string)
;; Ordinarily this is a vector where instructions are written. If
;; the segment is made invalid (e.g. by APPEND-SEGMENT) then the
;; vector can be replaced by NIL.
(declare (type fasl-output fasl-output))
(unless *cold-load-dump*
(let ((handle (gethash x (fasl-output-equal-table fasl-output))))
- (cond (handle
- (dump-push handle fasl-output)
- t)
- (t
- nil)))))
+ (cond
+ (handle (dump-push handle fasl-output) t)
+ (t nil)))))
+(defun string-check-table (x fasl-output)
+ (declare (type fasl-output fasl-output)
+ (type string x))
+ (unless *cold-load-dump*
+ (let ((handle (cdr (assoc
+ (array-element-type x)
+ (gethash x (fasl-output-equal-table fasl-output))))))
+ (cond
+ (handle (dump-push handle fasl-output) t)
+ (t nil)))))
;;; These functions are called after dumping an object to save the
;;; object in the table. The object (also passed in as X) must already
(setf (gethash x (fasl-output-eq-table fasl-output)) handle)
(dump-push handle fasl-output)))
(values))
-
+(defun string-save-object (x fasl-output)
+ (declare (type fasl-output fasl-output)
+ (type string x))
+ (unless *cold-load-dump*
+ (let ((handle (dump-pop fasl-output)))
+ (push (cons (array-element-type x) handle)
+ (gethash x (fasl-output-equal-table fasl-output)))
+ (setf (gethash x (fasl-output-eq-table fasl-output)) handle)
+ (dump-push handle fasl-output)))
+ (values))
;;; Record X in File's CIRCULARITY-TABLE unless *COLD-LOAD-DUMP* is
;;; true. This is called on objects that we are about to dump might
;;; have a circular path through them.
(dump-structure x file)
(eq-save-object x file))
(array
- ;; FIXME: The comment at the head of
- ;; DUMP-NON-IMMEDIATE-OBJECT says it's for objects which
- ;; we want to save, instead of repeatedly dumping them.
- ;; But then we dump arrays here without doing anything
- ;; like EQUAL-SAVE-OBJECT. What gives?
+ ;; DUMP-ARRAY (and its callees) are responsible for
+ ;; updating the EQ and EQUAL hash tables.
(dump-array x file))
(number
(unless (equal-check-table x file)
(movable foldable flushable))
(defknown name-char (string-designator) (or character null)
(movable foldable flushable))
-(defknown code-char (char-code) base-char
+(defknown code-char (char-code) character
;; By suppressing constant folding on CODE-CHAR when the
;; cross-compiler is running in the cross-compilation host vanilla
;; ANSI Common Lisp, we can use CODE-CHAR expressions to delay until
;;; then the result is definitely false.
(deftransform simple-equality-transform ((x y) * *
:defun-only t)
- (cond ((same-leaf-ref-p x y)
- t)
- ((not (types-equal-or-intersect (lvar-type x)
- (lvar-type y)))
+ (cond
+ ((same-leaf-ref-p x y) t)
+ ((not (types-equal-or-intersect (lvar-type x) (lvar-type y)))
nil)
- (t
- (give-up-ir1-transform))))
+ (t (give-up-ir1-transform))))
(macrolet ((def (x)
`(%deftransform ',x '(function * *) #'simple-equality-transform)))
(def eq)
- (def char=)
- (def equal))
+ (def char=))
-;;; This is similar to SIMPLE-EQUALITY-PREDICATE, except that we also
+;;; This is similar to SIMPLE-EQUALITY-TRANSFORM, except that we also
;;; try to convert to a type-specific predicate or EQ:
;;; -- If both args are characters, convert to CHAR=. This is better than
;;; just converting to EQ, since CHAR= may have special compilation
(y-type (lvar-type y))
(char-type (specifier-type 'character))
(number-type (specifier-type 'number)))
- (cond ((same-leaf-ref-p x y)
- t)
+ (cond
+ ((same-leaf-ref-p x y) t)
((not (types-equal-or-intersect x-type y-type))
nil)
((and (csubtypep x-type char-type)
(t
(give-up-ir1-transform)))))
+;;; similarly to the EQL transform above, we attempt to constant-fold
+;;; or convert to a simpler predicate: mostly we have to be careful
+;;; with strings.
+(deftransform equal ((x y) * *)
+ "convert to simpler equality predicate"
+ (let ((x-type (lvar-type x))
+ (y-type (lvar-type y))
+ (string-type (specifier-type 'string)))
+ (cond
+ ((same-leaf-ref-p x y) t)
+ ((and (csubtypep x-type string-type)
+ (csubtypep y-type string-type))
+ '(string= x y))
+ ((and (or (not (types-equal-or-intersect x-type string-type))
+ (not (types-equal-or-intersect y-type string-type)))
+ (not (types-equal-or-intersect x-type y-type)))
+ nil)
+ (t (give-up-ir1-transform)))))
+
;;; Convert to EQL if both args are rational and complexp is specified
;;; and the same for both.
(deftransform = ((x y) * *)
(defvar *2-bit* #.(make-array 5 :element-type '(unsigned-byte 2) :initial-element 0))
(defvar *4-bit* #.(make-array 5 :element-type '(unsigned-byte 4) :initial-element 1))
\f
+;;; tests for constant coalescing (and absence of such) in the
+;;; presence of strings.
+(progn
+ (defvar *character-string-1* #.(make-string 5 :initial-element #\a))
+ (defvar *character-string-2* #.(make-string 5 :initial-element #\a))
+ (assert (eq *character-string-1* *character-string-2*))
+ (assert (typep *character-string-1* '(simple-array character (5)))))
+
+(progn
+ (defvar *base-string-1*
+ #.(make-string 5 :initial-element #\b :element-type 'base-char))
+ (defvar *base-string-2*
+ #.(make-string 5 :initial-element #\b :element-type 'base-char))
+ (assert (eq *base-string-1* *base-string-2*))
+ (assert (typep *base-string-1* '(simple-base-string 5))))
+
+#-#.(cl:if (cl:subtypep 'cl:character 'cl:base-char) '(and) '(or))
+(progn
+ (defvar *base-string*
+ #.(make-string 5 :element-type 'base-char :initial-element #\x))
+ (defvar *character-string*
+ #.(make-string 5 :initial-element #\x))
+ (assert (not (eq *base-string* *character-string*)))
+ (assert (typep *base-string* 'base-string))
+ (assert (typep *character-string* '(vector character))))
+\f
(sb-ext:quit :unix-status 104) ; success
;;; checkins which aren't released. (And occasionally for internal
;;; versions, especially for internal versions off the main CVS
;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.8.16.15"
+"0.8.16.16"
projects / sbcl.git / commitdiff