is attached to FOO in 120a above, and used to optimize code which
calls FOO.
-121:
- In sbcl-0.7.14.flaky4.10, the last MAPTEST test case at the end
- of tests/map-tests.impure.lisp dies with
- The value
- #<SB-C::MV-COMBINATION
- :FUN #<SB-C::REF
- :LEAF #<SB-C::GLOBAL-VAR
- :NAME +
- :TYPE #
- :WHERE-FROM :DECLARED
- :KIND :GLOBAL-FUNCTION>>
- :ARGS (#<SB-C::COMBINATION :FUN # :ARGS (#)>)>
- is not of type
- SB-C::COMBINATION.
- in
- (SB-C::GENERATE-BYTE-CODE-FOR-REF
- #<SB-ASSEM:SEGMENT :NAME "Byte Output">
- #<SB-C::REF
- :LEAF #<SB-C::GLOBAL-VAR
- :NAME +
- :TYPE #<SB-KERNEL:FUNCTION-TYPE (FUNCTION # NUMBER)>
- :WHERE-FROM :DECLARED
- :KIND :GLOBAL-FUNCTION>>
- #<SB-C::CONTINUATION {506AD995}>)
+122:
+ There was some sort of screwup in handling of
+ (IF (NOT (IGNORE-ERRORS ..))). E.g.
+ (defun foo1i ()
+ (if (not (ignore-errors
+ (make-pathname :host "foo" :directory "!bla" :name "bar")))
+ (print "ok")
+ (error "notunlessnot")))
+ The (NOT (IGNORE-ERRORS ..)) form evaluates to T, so this should be
+ printing "ok", but instead it's going to the ERROR. This problem
+ seems to've been introduced by MNA's HANDLER-CASE patch (sbcl-devel
+ 2001-07-17) and as a workaround (put in sbcl-0.pre7.14.flaky4.12)
+ I reverted back to the old weird HANDLER-CASE code. However, I
+ think the problem looks like a compiler bug in handling RETURN-FROM,
+ so I left the MNA-patched code in HANDLER-CASE (suppressed with
+ #+NIL) and I'd like to go back to see whether this really is
+ a compiler bug before I delete this BUGS entry.
+
KNOWN BUGS RELATED TO THE IR1 INTERPRETER
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
+ (let ((no-error-clause (assoc ':no-error cases)))
+ (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)
+ ,@(remove no-error-clause cases)))))))
+ (let ((var (gensym))
+ (outer-tag (gensym))
+ (inner-tag (gensym))
+ (tag-var (gensym))
+ (annotated-cases (mapcar #'(lambda (case) (cons (gensym) case))
+ cases)))
+ `(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 (annotated-case)
+ `(,(cadr annotated-case)
+ #'(lambda (temp)
+ ,(if (caddr annotated-case)
+ `(setq ,var temp)
+ '(declare (ignore temp)))
+ (setf ,tag-var
+ ',(car annotated-case))
+ (throw ,inner-tag nil))))
+ annotated-cases)
+ ,form)))
+ (case ,tag-var
+ ,@(mapcar #'(lambda (annotated-case)
+ (let ((body (cdddr annotated-case))
+ (varp (caddr annotated-case)))
+ `(,(car annotated-case)
+ ,@(if varp
+ `((let ((,(car varp) ,var))
+ ,@body))
+ body))))
+ annotated-cases)))))))
+ #+nil ; MNA's patched version -- see FIXME above
(let ((no-error-clause (assoc ':no-error cases)))
(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))
+ (multiple-value-call (lambda ,@(cdr no-error-clause))
(block ,normal-return
(return-from ,error-return
(handler-case (return-from ,normal-return ,form)
,@(remove no-error-clause cases)))))))
(let ((tag (gensym))
(var (gensym))
- (annotated-cases (mapcar #'(lambda (case) (cons (gensym) case))
+ (annotated-cases (mapcar (lambda (case) (cons (gensym) case))
cases)))
`(block ,tag
(let ((,var nil))
(declare (ignorable ,var))
(tagbody
- (handler-bind
- ,(mapcar #'(lambda (annotated-case)
+ (handler-bind
+ ,(mapcar (lambda (annotated-case)
(list (cadr annotated-case)
- `#'(lambda (temp)
- ,(if (caddr annotated-case)
- `(setq ,var temp)
- '(declare (ignore temp)))
- (go ,(car annotated-case)))))
- annotated-cases)
- (return-from ,tag
- #-x86 ,form
- #+x86 (multiple-value-prog1 ,form
- ;; Need to catch FP errors here!
- (float-wait))))
- ,@(mapcan
- #'(lambda (annotated-case)
- (list (car annotated-case)
- (let ((body (cdddr annotated-case)))
- `(return-from
+ `(lambda (temp)
+ ,(if (caddr annotated-case)
+ `(setq ,var temp)
+ '(declare (ignore temp)))
+ (go ,(car annotated-case)))))
+ annotated-cases)
+ (return-from ,tag
+ #!-x86 ,form
+ #!+x86 (multiple-value-prog1 ,form
+ ;; Need to catch FP errors here!
+ (float-wait))))
+ ,@(mapcan
+ (lambda (annotated-case)
+ (list (car annotated-case)
+ (let ((body (cdddr annotated-case)))
+ `(return-from
,tag
- ,(cond ((caddr annotated-case)
- `(let ((,(caaddr annotated-case)
- ,var))
- ,@body))
- ((not (cdr body))
- (car body))
- (t
- `(progn ,@body)))))))
- annotated-cases))))))))
+ ,(cond ((caddr annotated-case)
+ `(let ((,(caaddr annotated-case)
+ ,var))
+ ,@body))
+ ((not (cdr body))
+ (car body))
+ (t
+ `(progn ,@body)))))))
+ annotated-cases))))))))
(defmacro ignore-errors (&rest forms)
#!+sb-doc
projects / sbcl.git / commitdiff