From 8fa3b333d2b37f45c3702f478f784b8c6f491080 Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Sun, 26 May 2002 15:00:21 +0000 Subject: [PATCH] 0.7.4.1: Apply patch to type system (CSR sbcl-devel 2002-05-23) to generate more useful types from intersections of complicated numeric types; Be more consistent over handling of wild pathnames to functions expecting non-wild pathnames; Apply two slight optimizations to array transforms; Fix (from Pierre Mai) for BUG 140; treat with (slight) care, as this removes an explicit request for non-invalidation of a wrapper, which presumably had some reason for being there at one time. --- BUGS | 71 +++------------------------------------- NEWS | 7 ++++ src/code/filesys.lisp | 73 ++++++++++++++++-------------------------- src/code/late-type.lisp | 22 +++++++++++-- src/code/target-load.lisp | 57 +++++++++++++-------------------- src/compiler/array-tran.lisp | 23 ++++--------- src/pcl/braid.lisp | 2 +- tests/filesys.pure.lisp | 18 ++++++++++- tests/type.impure.lisp | 14 +++++++- version.lisp-expr | 2 +- 10 files changed, 119 insertions(+), 170 deletions(-) diff --git a/BUGS b/BUGS index 0838256..ad7b82a 100644 --- a/BUGS +++ b/BUGS @@ -260,7 +260,6 @@ WORKAROUND: MERGE also have the same problem. c: (COERCE 'AND 'FUNCTION) returns something related to (MACRO-FUNCTION 'AND), but ANSI says it should raise an error. - g: (LOAD "*.lsp") should signal FILE-ERROR. h: (MAKE-CONCATENATED-STREAM (MAKE-STRING-OUTPUT-STREAM)) should signal TYPE-ERROR. i: MAKE-TWO-WAY-STREAM doesn't check that its arguments can @@ -897,9 +896,6 @@ WORKAROUND: Evidently Python thinks of the lambda as a code transformation so much that it forgets that it's also an object. -126: - (fixed in 0.pre7.41) - 127: The DEFSTRUCT section of the ANSI spec, in the :CONC-NAME section, specifies a precedence rule for name collisions between slot accessors of @@ -1003,36 +999,6 @@ WORKAROUND: still some functions named "hairy arg processor" and "SB-INT:&MORE processor". -140: - (reported by Alexey Dejneka sbcl-devel 2002-01-03) - - SUBTYPEP does not work well with redefined classes: - --- - * (defclass a () ()) - # - * (defclass b () ()) - # - * (subtypep 'b 'a) - NIL - T - * (defclass b (a) ()) - # - * (subtypep 'b 'a) - T - T - * (defclass b () ()) - # - - ;;; And now... - * (subtypep 'b 'a) - T - T - - This is probably due to underzealous clearing of the type caches; a - brute-force solution in that case would be to make a defclass expand - into something that included a call to SB-KERNEL::CLEAR-TYPE-CACHES, - but there may be a better solution. - 141: Pretty-printing nested backquotes doesn't work right, as reported by Alexey Dejneka sbcl-devel 2002-01-13: @@ -1160,9 +1126,6 @@ WORKAROUND: but it has happened in more complicated cases (which I haven't figured out how to reproduce). -155: - (fixed in sbcl-0.7.2.9) - 156: FUNCTION-LAMBDA-EXPRESSION doesn't work right in 0.7.0 or 0.7.2.9: * (function-lambda-expression #'(lambda (x) x)) @@ -1175,16 +1138,6 @@ WORKAROUND: UPGRADED-COMPLEX-PART-TYPE should have an optional environment argument. (reported by Alexey Dejneka sbcl-devel 2002-04-12) -158: - Compiling the following code causes SBCL 0.7.2 to bug. This only - happens with optimization enabled, and only when the loop variable is - being incremented by more than 1. - (defun foo (array) - (declare (optimize (safety 0) (space 0) (debug 0) (speed 3))) - (loop for i from 0 to 10 by 2 - do (foo (svref array i))) (svref array (1+ i))) - (reported by Eric Marsden sbcl-devel 2002-04-15) - 162: (reported by Robert E. Brown 2002-04-16) When a function is called with too few arguments, causing the @@ -1205,12 +1158,6 @@ WORKAROUND: isn't too surprising since there are many differences in stack implementation and GC conservatism between the X86 and other ports.) -164: - The type system still can't quite deal with all useful identities; - for instance, as of sbcl-0.7.2.18, the type specifier '(and (real -1 - 7) (real 4 8)) is a HAIRY-TYPE rather than that which would be hoped - for, viz: '(real 4 7). - 165: Array types with element-types of some unknown type are falsely being assumed to be of type (ARRAY T) by the compiler in some cases. The @@ -1302,20 +1249,10 @@ WORKAROUND: ; caught 1 STYLE-WARNING condition But the code works as it should. Checked in 0.6.12.43 and later. -170: - (reported by Matthias Hoelzl on sbcl-devel 2002-05-13) - * (defmacro foo () ''x) - FOO - * (foo) - X - * (compile 'foo) - FOO - NIL - NIL - * (foo) - debugger invoked on condition of type UNDEFINED-FUNCTION: - The function FOO is undefined. - +171: + (reported by Pierre Mai while investigating bug 47): + (DEFCLASS FOO () ((A :SILLY T))) + signals a SIMPLE-ERROR, not a PROGRAM-ERROR. DEFUNCT CATEGORIES OF BUGS IR1-#: diff --git a/NEWS b/NEWS index b2516d9..7ba2cfe 100644 --- a/NEWS +++ b/NEWS @@ -1126,6 +1126,13 @@ changes in sbcl-0.7.4 relative to sbcl-0.7.3: an ordinary character. Thus e.g. (READ-FROM-STRING "AB") returns |AB|, instead of A as it used to. +changes in sbcl-0.7.5 relative to sbcl-0.7.4: + * bug 140 fixed: redefinition of classes with different supertypes + is now reflected in the type hierarchy. (thanks to Pierre Mai) + * minor incompatible change: The LOAD function no longer, when given + a wild pathname to load, loads all files matching that pathname; + instead, an error of type FILE-ERROR is signalled. + planned incompatible changes in 0.7.x: * When the profiling interface settles down, maybe in 0.7.x, maybe later, it might impact TRACE. They both encapsulate functions, and diff --git a/src/code/filesys.lisp b/src/code/filesys.lisp index b4d48c6..bde23dc 100644 --- a/src/code/filesys.lisp +++ b/src/code/filesys.lisp @@ -682,14 +682,16 @@ (defun unix-namestring (pathname-spec &optional (for-input t)) (let* ((namestring (physicalize-pathname (merge-pathnames pathname-spec))) (matches nil)) ; an accumulator for actual matches + (when (wild-pathname-p namestring) + (error 'simple-file-error + :pathname namestring + :format-control "bad place for a wild pathname")) (!enumerate-matches (match namestring nil :verify-existence for-input) (push match matches)) (case (length matches) (0 nil) (1 (first matches)) - (t (error 'simple-file-error - :format-control "~S is ambiguous:~{~% ~A~}" - :format-arguments (list pathname-spec matches)))))) + (t (bug "!ENUMERATE-MATCHES returned more than one match on a non-wild pathname"))))) ;;;; TRUENAME and PROBE-FILE @@ -703,27 +705,19 @@ Under Unix, the TRUENAME of a broken symlink is considered to be the name of the broken symlink itself." - (if (wild-pathname-p pathname) + (let ((result (probe-file pathname))) + (unless result (error 'simple-file-error - :format-control "can't use a wild pathname here" - :pathname pathname) - (let ((result (probe-file pathname))) - (unless result - (error 'simple-file-error - :pathname pathname - :format-control "The file ~S does not exist." - :format-arguments (list (namestring pathname)))) - result))) + :pathname pathname + :format-control "The file ~S does not exist." + :format-arguments (list (namestring pathname)))) + result)) ;;; If PATHNAME exists, return its truename, otherwise NIL. (defun probe-file (pathname) #!+sb-doc "Return a pathname which is the truename of the file if it exists, or NIL otherwise. An error of type FILE-ERROR is signaled if pathname is wild." - (when (wild-pathname-p pathname) - (error 'simple-file-error - :pathname pathname - :format-control "can't use a wild pathname here")) (let* ((defaulted-pathname (merge-pathnames pathname (sane-default-pathname-defaults))) @@ -789,43 +783,30 @@ #!+sb-doc "Return file's creation date, or NIL if it doesn't exist. An error of type file-error is signaled if file is a wild pathname" - (if (wild-pathname-p file) - ;; FIXME: This idiom appears many times in this file. Perhaps it - ;; should turn into (CANNOT-BE-WILD-PATHNAME FILE). (C-B-W-P - ;; should be a macro, not a function, so that the error message - ;; is reported as coming from e.g. FILE-WRITE-DATE instead of - ;; from CANNOT-BE-WILD-PATHNAME itself.) - (error 'simple-file-error - :pathname file - :format-control "bad place for a wild pathname") - (let ((name (unix-namestring file t))) - (when name - (multiple-value-bind - (res dev ino mode nlink uid gid rdev size atime mtime) - (sb!unix:unix-stat name) - (declare (ignore dev ino mode nlink uid gid rdev size atime)) - (when res - (+ unix-to-universal-time mtime))))))) + (let ((name (unix-namestring file t))) + (when name + (multiple-value-bind + (res dev ino mode nlink uid gid rdev size atime mtime) + (sb!unix:unix-stat name) + (declare (ignore dev ino mode nlink uid gid rdev size atime)) + (when res + (+ unix-to-universal-time mtime)))))) (defun file-author (file) #!+sb-doc "Return the file author as a string, or NIL if the author cannot be determined. Signal an error of type FILE-ERROR if FILE doesn't exist, or FILE is a wild pathname." - (if (wild-pathname-p file) + (let ((name (unix-namestring (pathname file) t))) + (unless name (error 'simple-file-error :pathname file - "bad place for a wild pathname") - (let ((name (unix-namestring (pathname file) t))) - (unless name - (error 'simple-file-error - :pathname file - :format-control "~S doesn't exist." - :format-arguments (list file))) - (multiple-value-bind (winp dev ino mode nlink uid) - (sb!unix:unix-stat name) - (declare (ignore dev ino mode nlink)) - (and winp (sb!unix:uid-username uid)))))) + :format-control "~S doesn't exist." + :format-arguments (list file))) + (multiple-value-bind (winp dev ino mode nlink uid) + (sb!unix:unix-stat name) + (declare (ignore dev ino mode nlink)) + (and winp (sb!unix:uid-username uid))))) ;;;; DIRECTORY diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp index 4b92965..5bf3aa3 100644 --- a/src/code/late-type.lisp +++ b/src/code/late-type.lisp @@ -849,6 +849,16 @@ #+sb-xc-host (coerce types 'list) #-sb-xc-host (coerce-to-list types))))) +(defun maybe-distribute-one-union (union-type types) + (let* ((intersection (apply #'type-intersection types)) + (union (mapcar (lambda (x) (type-intersection x intersection)) + (union-type-types union-type)))) + (if (notany (lambda (x) (or (hairy-type-p x) + (intersection-type-p x))) + union) + union + nil))) + (defun type-intersection (&rest input-types) (let ((simplified-types (simplified-compound-types input-types #'intersection-type-p @@ -860,11 +870,17 @@ ;; always achieve that by the distributive rule. But we don't want ;; to just apply the distributive rule, since it would be too easy ;; to end up with unreasonably huge type expressions. So instead - ;; we punt to HAIRY-TYPE when this comes up. + ;; we try to generate a simple type by distributing the union; if + ;; the type can't be made simple, we punt to HAIRY-TYPE. (if (and (> (length simplified-types) 1) (some #'union-type-p simplified-types)) - (make-hairy-type - :specifier `(and ,@(map 'list #'type-specifier simplified-types))) + (let* ((first-union (find-if #'union-type-p simplified-types)) + (other-types (coerce (remove first-union simplified-types) 'list)) + (distributed (maybe-distribute-one-union first-union other-types))) + (if distributed + (apply #'type-union distributed) + (make-hairy-type + :specifier `(and ,@(map 'list #'type-specifier simplified-types))))) (make-compound-type-or-something #'%make-intersection-type simplified-types (some #'type-enumerable diff --git a/src/code/target-load.lisp b/src/code/target-load.lisp index 9254a35..48a96c4 100644 --- a/src/code/target-load.lisp +++ b/src/code/target-load.lisp @@ -183,40 +183,29 @@ '(unsigned-byte 8))) (load-as-fasl filespec verbose print) (load-as-source filespec verbose print)) - (let (;; FIXME: MERGE-PATHNAMES doesn't work here for - ;; FILESPEC="TEST:Load-Test" and - ;; (LOGICAL-PATHNAME-TRANSLATIONS "TEST") - ;; = (("**;*.*.*" "/foo/bar/**/*.*")). - ;; Physicalizing the pathname before merging - ;; is a workaround, but the ANSI spec talks about - ;; MERGE-PATHNAMES accepting (and returning) - ;; logical pathnames, so a true fix would probably - ;; include fixing MERGE-PATHNAMES, then probably - ;; revisiting this code. - (ppn (physicalize-pathname (pathname filespec)))) - (if (wild-pathname-p ppn) - (let ((files (directory ppn))) - #!+high-security - (when (null files) - (error 'file-error :pathname filespec)) - (dolist (file files t) - (internal-load ppn - file - internal-if-does-not-exist - verbose - print))) - (let ((tn (probe-file ppn))) - (if (or tn (pathname-type ppn)) - (internal-load ppn - tn - internal-if-does-not-exist - verbose - print) - (internal-load-default-type - ppn - internal-if-does-not-exist - verbose - print))))))))) + (let* (;; FIXME: MERGE-PATHNAMES doesn't work here for + ;; FILESPEC="TEST:Load-Test" and + ;; (LOGICAL-PATHNAME-TRANSLATIONS "TEST") + ;; = (("**;*.*.*" "/foo/bar/**/*.*")). + ;; Physicalizing the pathname before merging + ;; is a workaround, but the ANSI spec talks about + ;; MERGE-PATHNAMES accepting (and returning) + ;; logical pathnames, so a true fix would probably + ;; include fixing MERGE-PATHNAMES, then probably + ;; revisiting this code. + (ppn (physicalize-pathname (pathname filespec))) + (unix-name (unix-namestring ppn t))) + (if (or unix-name (pathname-type ppn)) + (internal-load ppn + unix-name + internal-if-does-not-exist + verbose + print) + (internal-load-default-type + ppn + internal-if-does-not-exist + verbose + print))))))) ;;; Load a code object. BOX-NUM objects are popped off the stack for ;;; the boxed storage section, then SIZE bytes of code are read in. diff --git a/src/compiler/array-tran.lisp b/src/compiler/array-tran.lisp index 1cb1a64..772b90f 100644 --- a/src/compiler/array-tran.lisp +++ b/src/compiler/array-tran.lisp @@ -512,12 +512,7 @@ `(if (<= ,n-svalue ,n-end ,n-len) ;; success (values ,n-array ,n-svalue ,n-end 0) - ;; 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))))) + (failed-%with-array-data ,n-array ,n-svalue ,n-evalue)))) (,(if force-inline '%with-array-data-macro '%with-array-data) ,n-array ,n-svalue ,n-evalue)) ,@forms))) @@ -561,16 +556,12 @@ (declare (type index ,cumulative-offset)))))) (deftransform %with-array-data ((array start end) - ;; Note: This transform is limited to - ;; VECTOR only because I happened to - ;; create it in order to get sequence - ;; function operations to be more - ;; efficient. It might very well be - ;; reasonable to allow general ARRAY - ;; here, I just haven't tried to - ;; understand the performance issues - ;; involved. -- WHN - (vector index (or index null)) + ;; It might very well be reasonable to + ;; allow general ARRAY here, I just + ;; haven't tried to understand the + ;; performance issues involved. -- + ;; WHN, and also CSR 2002-05-26 + (simple-array index (or index null)) * :important t :node node diff --git a/src/pcl/braid.lisp b/src/pcl/braid.lisp index ca67036..246b911 100644 --- a/src/pcl/braid.lisp +++ b/src/pcl/braid.lisp @@ -578,7 +578,7 @@ (sb-kernel:order-layout-inherits (map 'simple-vector #'class-wrapper (reverse (rest (class-precedence-list class)))))) - (sb-kernel:register-layout layout :invalidate nil) + (sb-kernel:register-layout layout) ;; Subclasses of formerly forward-referenced-class may be ;; unknown to CL:FIND-CLASS and also anonymous. This diff --git a/tests/filesys.pure.lisp b/tests/filesys.pure.lisp index a1800e2..3e7ab3d 100644 --- a/tests/filesys.pure.lisp +++ b/tests/filesys.pure.lisp @@ -49,8 +49,24 @@ ;; SBCL 0.7.1.2 failed to merge on OPEN (with-open-file (i "tests/filesys.pure.lisp") (assert i))) - +;;; OPEN, LOAD and friends should signal an error of type FILE-ERROR +;;; if they are fed wild pathname designators; firstly, with wild +;;; pathnames that don't correspond to any files: +(assert (typep (nth-value 1 (ignore-errors (open "non-existent*.lisp"))) + 'file-error)) +(assert (typep (nth-value 1 (ignore-errors (load "non-existent*.lisp"))) + 'file-error)) +;;; then for pathnames that correspond to precisely one: +(assert (typep (nth-value 1 (ignore-errors (open "filesys.pur*.lisp"))) + 'file-error)) +(assert (typep (nth-value 1 (ignore-errors (load "filesys.pur*.lisp"))) + 'file-error)) +;;; then for pathnames corresponding to many: +(assert (typep (nth-value 1 (ignore-errors (open "*.lisp"))) + 'file-error)) +(assert (typep (nth-value 1 (ignore-errors (load "*.lisp"))) + 'file-error)) ;;; ANSI: FILE-LENGTH should signal an error of type TYPE-ERROR if ;;; STREAM is not a stream associated with a file. diff --git a/tests/type.impure.lisp b/tests/type.impure.lisp index 5033591..bf127c7 100644 --- a/tests/type.impure.lisp +++ b/tests/type.impure.lisp @@ -182,6 +182,11 @@ ;;; thing to want anyway, let's test for it here: (assert-t-t (subtypep '(or some-undefined-type (member :no-ir2-yet :dead)) '(or some-undefined-type (member :no-ir2-yet :dead)))) +;;; BUG 158 (failure to compile loops with vector references and +;;; increments of greater than 1) was a symptom of type system +;;; uncertainty, to wit: +(assert-t-t (subtypep '(and (mod 536870911) (or (integer 0 0) (integer 2 536870912))) + '(mod 536870911))) ; aka SB-INT:INDEX. ;;;; Douglas Thomas Crosher rewrote the CMU CL type test system to ;;;; allow inline type tests for CONDITIONs and STANDARD-OBJECTs, and @@ -337,6 +342,13 @@ #.*tests-of-inline-type-tests*) (tests-of-inline-type-tests) (format t "~&/done with compiled (TESTS-OF-INLINE-TYPE-TESTS)~%") - + +;;; Redefinition of classes should alter the type hierarchy (BUG 140): +(defclass superclass () ()) +(defclass maybe-subclass (superclass) ()) +(assert-t-t (subtypep 'maybe-subclass 'superclass)) +(defclass maybe-subclass () ()) +(assert-nil-t (subtypep 'maybe-subclass 'superclass)) + ;;; success (quit :unix-status 104) diff --git a/version.lisp-expr b/version.lisp-expr index c74a620..76aca69 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -18,4 +18,4 @@ ;;; for internal versions, especially for internal versions off the ;;; main CVS branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.7.4" +"0.7.4.1" -- 1.7.10.4