Skip to content

Commit

Permalink
0.7.7.8:
Browse files Browse the repository at this point in the history 
	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.)
  • Loading branch information
William Harold Newman committed Sep 1, 2002
1 parent eb356db commit 6e64d0c
Show file tree
Hide file tree
Showing 4 changed files with 27 additions and 107 deletions.
91 changes: 5 additions & 86 deletions src/code/target-error.lisp
View file
Expand Up @@ -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"))
Expand Down
39 changes: 20 additions & 19 deletions src/compiler/fndb.lisp
View file
Expand Up @@ -1024,29 +1024,30 @@

;;; (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
(member nil :host :device
: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
Expand All @@ -1063,7 +1064,7 @@
(defknown merge-pathnames
(pathname-designator &optional pathname-designator pathname-version)
pathname
(flushable))
())

(defknown make-pathname
(&key (:defaults pathname-designator)
Expand All @@ -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))

Expand All @@ -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)))
Expand All @@ -1140,7 +1141,7 @@
t)

(defknown directory (pathname-designator &key)
list (flushable))
list ())

;;;; from the "Errors" chapter:

Expand Down
2 changes: 1 addition & 1 deletion tests/seq.impure.lisp
View file
Expand Up @@ -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)
Expand Down
2 changes: 1 addition & 1 deletion version.lisp-expr
View file
Expand Up @@ -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"

0 comments on commit 6e64d0c

Please sign in to comment.