From 988afd9d54ba6c8a915544822658824ab6ae0d6c Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Sat, 30 Oct 2004 14:36:05 +0000 Subject: [PATCH] 0.8.16.16: Various string-related fixes and harmless changes, mostly apparently cosmetic (but necessary for base-char not equalling character). ... tests for dumper behaviour This patch brought to you by character_branch --- NEWS | 3 +++ contrib/sb-simple-streams/impl.lisp | 6 +++--- src/code/cross-type.lisp | 5 +++++ src/code/filesys.lisp | 22 +++++++++++--------- src/code/fop.lisp | 2 +- src/code/host-c-call.lisp | 10 ++++----- src/code/late-format.lisp | 9 ++++++--- src/code/pprint.lisp | 2 +- src/code/pred.lisp | 2 ++ src/code/primordial-extensions.lisp | 33 +++++++++--------------------- src/code/run-program.lisp | 1 + src/code/stream.lisp | 12 +++++------ src/code/target-format.lisp | 3 +++ src/code/target-pathname.lisp | 32 ++++++++++++++--------------- src/code/target-thread.lisp | 2 +- src/code/target-unithread.lisp | 2 +- src/code/unix.lisp | 11 +++++----- src/compiler/array-tran.lisp | 3 +-- src/compiler/assem.lisp | 2 +- src/compiler/dump.lisp | 36 +++++++++++++++++++++++---------- src/compiler/fndb.lisp | 2 +- src/compiler/srctran.lisp | 38 +++++++++++++++++++++++++---------- tests/dump.impure-cload.lisp | 26 ++++++++++++++++++++++++ version.lisp-expr | 2 +- 24 files changed, 162 insertions(+), 104 deletions(-) diff --git a/NEWS b/NEWS index 3a3e2cf..be5f03d 100644 --- a/NEWS +++ b/NEWS @@ -29,6 +29,9 @@ changes in sbcl-0.8.17 relative to sbcl-0.8.16: 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: diff --git a/contrib/sb-simple-streams/impl.lisp b/contrib/sb-simple-streams/impl.lisp index d5b709c..79fe4c4 100644 --- a/contrib/sb-simple-streams/impl.lisp +++ b/contrib/sb-simple-streams/impl.lisp @@ -173,7 +173,7 @@ (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 @@ -200,7 +200,7 @@ (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) @@ -210,7 +210,7 @@ (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))))) diff --git a/src/code/cross-type.lisp b/src/code/cross-type.lisp index 752f7c2..1aefd7f 100644 --- a/src/code/cross-type.lisp +++ b/src/code/cross-type.lisp @@ -360,6 +360,11 @@ (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) diff --git a/src/code/filesys.lisp b/src/code/filesys.lisp index 3bf1a5a..aa8b501 100644 --- a/src/code/filesys.lisp +++ b/src/code/filesys.lisp @@ -192,8 +192,9 @@ (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))) @@ -296,7 +297,7 @@ (t (error "invalid pattern piece: ~S" piece)))))) (apply #'concatenate - 'simple-string + 'simple-base-string (strings)))))) (defun unparse-unix-directory-list (directory) @@ -322,7 +323,7 @@ (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)) @@ -350,18 +351,18 @@ (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))) @@ -583,9 +584,10 @@ (/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) @@ -1040,7 +1042,7 @@ :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~%" diff --git a/src/code/fop.lisp b/src/code/fop.lisp index ea97330..fab38c4 100644 --- a/src/code/fop.lisp +++ b/src/code/fop.lisp @@ -75,7 +75,7 @@ (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 diff --git a/src/code/host-c-call.lisp b/src/code/host-c-call.lisp index 4ad089a..409fd9f 100644 --- a/src/code/host-c-call.lisp +++ b/src/code/host-c-call.lisp @@ -14,9 +14,8 @@ (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)) @@ -24,7 +23,7 @@ (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)) @@ -37,7 +36,8 @@ `(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") diff --git a/src/code/late-format.lisp b/src/code/late-format.lisp index 4f058c0..4cb042a 100644 --- a/src/code/late-format.lisp +++ b/src/code/late-format.lisp @@ -39,7 +39,7 @@ (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)) @@ -270,8 +270,11 @@ (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)) diff --git a/src/code/pprint.lisp b/src/code/pprint.lisp index 90ea31d..8c084d6 100644 --- a/src/code/pprint.lisp +++ b/src/code/pprint.lisp @@ -119,7 +119,7 @@ (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 diff --git a/src/code/pred.lisp b/src/code/pred.lisp index ed06587..5305ac0 100644 --- a/src/code/pred.lisp +++ b/src/code/pred.lisp @@ -128,6 +128,8 @@ '(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))) diff --git a/src/code/primordial-extensions.lisp b/src/code/primordial-extensions.lisp index 1ed66e7..d09a8b2 100644 --- a/src/code/primordial-extensions.lisp +++ b/src/code/primordial-extensions.lisp @@ -167,30 +167,15 @@ ;;; 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) diff --git a/src/code/run-program.lisp b/src/code/run-program.lisp index 0119d6c..e3a1299 100644 --- a/src/code/run-program.lisp +++ b/src/code/run-program.lisp @@ -382,6 +382,7 @@ ;;; 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)))) diff --git a/src/code/stream.lisp b/src/code/stream.lisp index 51c1911..a99b5e3 100644 --- a/src/code/stream.lisp +++ b/src/code/stream.lisp @@ -1028,7 +1028,7 @@ (: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 @@ -1525,7 +1525,7 @@ (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)) @@ -1550,7 +1550,7 @@ (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)) @@ -1583,7 +1583,7 @@ (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)) @@ -1628,7 +1628,7 @@ (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)) @@ -1673,7 +1673,7 @@ (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)) diff --git a/src/code/target-format.lisp b/src/code/target-format.lisp index 2e30451..26616bc 100644 --- a/src/code/target-format.lisp +++ b/src/code/target-format.lisp @@ -76,8 +76,11 @@ (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 diff --git a/src/code/target-pathname.lisp b/src/code/target-pathname.lisp index 9f72ccd..6848a57 100644 --- a/src/code/target-pathname.lisp +++ b/src/code/target-pathname.lisp @@ -202,12 +202,12 @@ (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. @@ -308,7 +308,7 @@ (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)))) @@ -319,7 +319,7 @@ (make-pattern (mapcar (lambda (piece) (typecase piece - (simple-base-string + (simple-string (funcall fun piece)) (cons (case (car piece) @@ -333,7 +333,7 @@ (pattern-pieces thing)))) (list (mapcar fun thing)) - (simple-base-string + (simple-string (funcall fun thing)) (t thing)))) @@ -702,7 +702,7 @@ a host-structure or string." ;;; 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))) @@ -924,7 +924,7 @@ a host-structure or string." (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)) @@ -1157,13 +1157,14 @@ a host-structure or string." (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. @@ -1257,7 +1258,7 @@ a host-structure or string." ;;; 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) @@ -1418,7 +1419,7 @@ a host-structure or string." (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 ".") @@ -1524,12 +1525,9 @@ a host-structure or string." (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 diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp index 62c7b03..b882962 100644 --- a/src/code/target-thread.lisp +++ b/src/code/target-thread.lisp @@ -58,7 +58,7 @@ (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)) diff --git a/src/code/target-unithread.lisp b/src/code/target-unithread.lisp index 4fc86d5..886ed82 100644 --- a/src/code/target-unithread.lisp +++ b/src/code/target-unithread.lisp @@ -37,7 +37,7 @@ ;;;; 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)) diff --git a/src/code/unix.lisp b/src/code/unix.lisp index 7c1298d..b011c9e 100644 --- a/src/code/unix.lisp +++ b/src/code/unix.lisp @@ -811,7 +811,7 @@ previous timer after the body has finished executing" ;;; 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 @@ -837,7 +837,7 @@ previous timer after the body has finished executing" :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) @@ -853,9 +853,9 @@ previous timer after the body has finished executing" (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)) @@ -929,7 +929,8 @@ previous timer after the body has finished executing" (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) diff --git a/src/compiler/array-tran.lisp b/src/compiler/array-tran.lisp index 539a4e4..0c52b81 100644 --- a/src/compiler/array-tran.lisp +++ b/src/compiler/array-tran.lisp @@ -293,8 +293,7 @@ (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 diff --git a/src/compiler/assem.lisp b/src/compiler/assem.lisp index cdf3d1c..6b68100 100644 --- a/src/compiler/assem.lisp +++ b/src/compiler/assem.lisp @@ -27,7 +27,7 @@ ;;; 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. diff --git a/src/compiler/dump.lisp b/src/compiler/dump.lisp index 83229a0..453daf4 100644 --- a/src/compiler/dump.lisp +++ b/src/compiler/dump.lisp @@ -192,11 +192,19 @@ (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 @@ -217,7 +225,16 @@ (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. @@ -370,11 +387,8 @@ (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) diff --git a/src/compiler/fndb.lisp b/src/compiler/fndb.lisp index 9bc3d95..309758f 100644 --- a/src/compiler/fndb.lisp +++ b/src/compiler/fndb.lisp @@ -421,7 +421,7 @@ (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 diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp index a49c415..a5ccd02 100644 --- a/src/compiler/srctran.lisp +++ b/src/compiler/srctran.lisp @@ -2996,21 +2996,18 @@ ;;; 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 @@ -3029,8 +3026,8 @@ (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) @@ -3047,6 +3044,25 @@ (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) * *) diff --git a/tests/dump.impure-cload.lisp b/tests/dump.impure-cload.lisp index 393e285..d5854ce 100644 --- a/tests/dump.impure-cload.lisp +++ b/tests/dump.impure-cload.lisp @@ -98,4 +98,30 @@ (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)) +;;; 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)))) + (sb-ext:quit :unix-status 104) ; success diff --git a/version.lisp-expr b/version.lisp-expr index 7718cb2..346af38 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; 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" -- 1.7.10.4