From 6e64d0c249f53f4d41fd7a75f80dfd10a1c89f06 Mon Sep 17 00:00:00 2001 From: William Harold Newman Date: Sun, 1 Sep 2002 21:49:02 +0000 Subject: [PATCH] 0.7.7.8: merged APD bug 122 patch (sbcl-devel 2002-08-30) Tweak seq.impure.lisp test more or less along the lines of APD's explanation of the pathname problem. (SUBSEQ is FLUSHABLE, and validly so. The old test bogusly relied on it not being flushed and/or the compiler not being infernally clever about type inference.) --- src/code/target-error.lisp | 91 +++----------------------------------------- src/compiler/fndb.lisp | 39 ++++++++++--------- tests/seq.impure.lisp | 2 +- version.lisp-expr | 2 +- 4 files changed, 27 insertions(+), 107 deletions(-) diff --git a/src/code/target-error.lisp b/src/code/target-error.lisp index ef1eea8..747b54f 100644 --- a/src/code/target-error.lisp +++ b/src/code/target-error.lisp @@ -324,99 +324,18 @@ ;;;; HANDLER-CASE -(defmacro handler-case (form &rest clauses) +(defmacro handler-case (form &rest cases) "(HANDLER-CASE form { (type ([var]) body) }* ) Execute FORM in a context with handlers established for the condition - types. A peculiar property allows type to be :no-error. If such a clause + types. A peculiar property allows type to be :NO-ERROR. If such a clause occurs, and form returns normally, all its values are passed to this clause as if by MULTIPLE-VALUE-CALL. The :NO-ERROR clause accepts more than one var specification." - ;; FIXME: This old SBCL code uses multiple nested THROW/CATCH - ;; operations, which seems like an ugly way to handle lexical - ;; nonlocal exit. MNA sbcl-devel 2001-07-17 provided a patch - ;; (included below this form, but #+NIL'ed out) to switch over to - ;; RETURN-FROM, which seems like basically a better idea. - ;; Unfortunately when using his patch, this reasonable code - ;; (DEFUN FOO1I () - ;; (IF (NOT (IGNORE-ERRORS - ;; (MAKE-PATHNAME :HOST "FOO" - ;; :DIRECTORY "!BLA" - ;; :NAME "BAR"))) - ;; (PRINT "OK") - ;; (ERROR "NOTUNLESSNOT"))) - ;; fails (doing ERROR "NOTUNLESSNOT" when it should PRINT "OK" - ;; instead). I think this may not be a bug in MNA's patch, but - ;; instead in the rest of the compiler (e.g. handling of RETURN-FROM) - ;; but whatever the reason. (I noticed this problem in - ;; sbcl-0.pre7.14.flaky4.11, and reverted to the old code at that point. - ;; The problem also occurs at least in sbcl-0.6.12.59 and - ;; sbcl-0.6.13.) -- WHN - ;; - ;; Note also: I think the old nested THROW/CATCH version became - ;; easier to read once I converted it to use DESTRUCTURING-BIND and - ;; mnemonic names, and it would probably be a useful to do that to - ;; the RETURN-FROM version when/if it's adopted. - (let ((no-error-clause (assoc ':no-error clauses))) - (if no-error-clause - (let ((normal-return (make-symbol "normal-return")) - (error-return (make-symbol "error-return"))) - `(block ,error-return - (multiple-value-call #'(lambda ,@(cdr no-error-clause)) - (block ,normal-return - (return-from ,error-return - (handler-case (return-from ,normal-return ,form) - ;; FIXME: What if there's more than one :NO-ERROR - ;; clause? The code here and above doesn't seem - ;; either to remove both of them or to signal - ;; a good error, so it's probably wrong. - ,@(remove no-error-clause clauses))))))) - (let ((var (gensym "HC-VAR-")) - (outer-tag (gensym "OUTER-HC-TAG-")) - (inner-tag (gensym "INNER-HC-TAG-")) - (tag-var (gensym "HC-TAG-VAR-")) - (tagged-clauses (mapcar (lambda (clause) - (cons (gensym "HC-TAG-") clause)) - clauses))) - `(let ((,outer-tag (cons nil nil)) - (,inner-tag (cons nil nil)) - ,var ,tag-var) - ;; FIXME: should be (DECLARE (IGNORABLE ,VAR)) - ,var ;ignoreable - (catch ,outer-tag - (catch ,inner-tag - (throw ,outer-tag - (handler-bind - ,(mapcar (lambda (tagged-clause) - (destructuring-bind - (tag typespec args &body body) - tagged-clause - (declare (ignore body)) - `(,typespec - (lambda (temp) - ,(if args - `(setq ,var temp) - '(declare (ignore temp))) - (setf ,tag-var ',tag) - (/show "THROWing INNER-TAG from HANDLER-BIND closure for" ',typespec) - (throw ,inner-tag nil))))) - tagged-clauses) - ,form))) - (case ,tag-var - ,@(mapcar (lambda (tagged-clause) - (destructuring-bind - (tag typespec args &body body) - tagged-clause - (declare (ignore typespec)) - `(,tag - ,@(if args - (destructuring-bind (arg) args - `((let ((,arg ,var)) - ,@body))) - body)))) - tagged-clauses))))))) - #+nil ; MNA's patched version -- see FIXME above + ;; FIXME: Replacing CADR, CDDDR and friends with DESTRUCTURING-BIND + ;; and names for the subexpressions would make it easier to + ;; understand the code below. (let ((no-error-clause (assoc ':no-error cases))) (if no-error-clause (let ((normal-return (make-symbol "normal-return")) diff --git a/src/compiler/fndb.lisp b/src/compiler/fndb.lisp index f6d9f54..64e584a 100644 --- a/src/compiler/fndb.lisp +++ b/src/compiler/fndb.lisp @@ -1024,7 +1024,8 @@ ;;; (No pathname functions are FOLDABLE because they all potentially ;;; depend on *DEFAULT-PATHNAME-DEFAULTS*, e.g. to provide a default -;;; host when parsing a namestring.) +;;; host when parsing a namestring. They are not FLUSHABLE because +;;; parsing of a PATHNAME-DESIGNATOR might signal an error.) (defknown wild-pathname-p (pathname-designator &optional @@ -1032,21 +1033,21 @@ :directory :name :type :version)) boolean - (flushable)) + ()) (defknown pathname-match-p (pathname-designator pathname-designator) boolean - (flushable)) + ()) (defknown translate-pathname (pathname-designator pathname-designator pathname-designator &key) pathname - (flushable)) + ()) (defknown logical-pathname (pathname-designator) logical-pathname ()) (defknown translate-logical-pathname (pathname-designator &key) pathname ()) (defknown load-logical-pathname-translations (string) t ()) (defknown logical-pathname-translations (logical-host-designator) list ()) -(defknown pathname (pathname-designator) pathname (flushable)) +(defknown pathname (pathname-designator) pathname ()) (defknown truename (pathname-designator) pathname ()) (defknown parse-namestring @@ -1063,7 +1064,7 @@ (defknown merge-pathnames (pathname-designator &optional pathname-designator pathname-version) pathname - (flushable)) + ()) (defknown make-pathname (&key (:defaults pathname-designator) @@ -1073,35 +1074,35 @@ (:name (or pathname-name string (member :wild))) (:type (or pathname-type string (member :wild))) (:version pathname-version) (:case (member :local :common))) - pathname (flushable)) + pathname ()) (defknown pathnamep (t) boolean (movable flushable)) (defknown pathname-host (pathname-designator &key (:case (member :local :common))) - pathname-host (flushable)) + pathname-host ()) (defknown pathname-device (pathname-designator &key (:case (member :local :common))) - pathname-device (flushable)) + pathname-device ()) (defknown pathname-directory (pathname-designator &key (:case (member :local :common))) - pathname-directory (flushable)) + pathname-directory ()) (defknown pathname-name (pathname-designator &key (:case (member :local :common))) - pathname-name (flushable)) + pathname-name ()) (defknown pathname-type (pathname-designator &key (:case (member :local :common))) - pathname-type (flushable)) + pathname-type ()) (defknown pathname-version (pathname-designator) - pathname-version (flushable)) + pathname-version ()) (defknown (namestring file-namestring directory-namestring host-namestring) (pathname-designator) simple-string - (flushable)) + ()) (defknown enough-namestring (pathname-designator &optional pathname-designator) simple-string - (flushable)) + ()) (defknown user-homedir-pathname (&optional t) pathname (flushable)) @@ -1119,11 +1120,11 @@ (defknown rename-file (pathname-designator filename) (values pathname pathname pathname)) (defknown delete-file (pathname-designator) t) -(defknown probe-file (pathname-designator) (or pathname null) (flushable)) +(defknown probe-file (pathname-designator) (or pathname null) ()) (defknown file-write-date (pathname-designator) (or unsigned-byte null) - (flushable)) + ()) (defknown file-author (pathname-designator) (or simple-string null) - (flushable)) + ()) (defknown file-position (stream &optional (or unsigned-byte (member :start :end))) @@ -1140,7 +1141,7 @@ t) (defknown directory (pathname-designator &key) - list (flushable)) + list ()) ;;;; from the "Errors" chapter: diff --git a/tests/seq.impure.lisp b/tests/seq.impure.lisp index c75e952..ef70526 100644 --- a/tests/seq.impure.lisp +++ b/tests/seq.impure.lisp @@ -196,7 +196,7 @@ ;; physical ARRAY-DIMENSION 0. ;; ;; fixed in sbcl-0.7.4.22 by WHN - (assert (null (ignore-errors (subseq avec 1 5))))) + (assert (null (ignore-errors (aref (subseq avec 1 5) 0))))) ;;; FILL (defun test-fill-typecheck (x) diff --git a/version.lisp-expr b/version.lisp-expr index 4681457..8257144 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.7.7" +"0.7.7.8" -- 1.7.10.4