From fc047ff117f27af43d5d78ddc28ddac24739653b Mon Sep 17 00:00:00 2001 From: William Harold Newman Date: Sat, 25 Aug 2001 19:12:51 +0000 Subject: [PATCH] 0.pre7.14.flaky4.12: commented out MNA's HANDLER-CASE patch from sbcl-dev 2001-07-16 (merged in sbcl-0.6.12.51) in favor of the grotty old THROW/CATCH code, since the MNA code causes (DEFUN FOO1I () (IF (NOT (IGNORE-ERRORS (MAKE-PATHNAME :HOST "FOO" :DIRECTORY "!BLA" :NAME "BAR"))) (PRINT "OK") (ERROR "NOTUNLESSNOT"))) to be compiled incorrectly. (I rather suspect that may not be a bug in the patch, but instead that the correct code generated by the patch exercises a bug elsewhere in the compiler.) redid indentation in MNA HANDLER-CASE code fixed #!+X86 (was #+X86) conditionalization in MNA HANDLER-CASE code --- BUGS | 42 ++++++------- src/code/early-target-error.lisp | 126 +++++++++++++++++++++++++++++--------- tests/pathnames.impure.lisp | 17 ----- version.lisp-expr | 2 +- 4 files changed, 116 insertions(+), 71 deletions(-) diff --git a/BUGS b/BUGS index 94a87e1..637e51e 100644 --- a/BUGS +++ b/BUGS @@ -1169,30 +1169,24 @@ Error in function C::GET-LAMBDA-TO-COMPILE: 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 - #> - :ARGS (#)> - is not of type - SB-C::COMBINATION. - in - (SB-C::GENERATE-BYTE-CODE-FOR-REF - # - # - :WHERE-FROM :DECLARED - :KIND :GLOBAL-FUNCTION>> - #) +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 diff --git a/src/code/early-target-error.lisp b/src/code/early-target-error.lisp index 87bc240..890ed93 100644 --- a/src/code/early-target-error.lisp +++ b/src/code/early-target-error.lisp @@ -329,53 +329,121 @@ 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 diff --git a/tests/pathnames.impure.lisp b/tests/pathnames.impure.lisp index d4022f5..b14b99f 100644 --- a/tests/pathnames.impure.lisp +++ b/tests/pathnames.impure.lisp @@ -79,22 +79,6 @@ ;;; FIXME: currently SBCL throws NAMESTRING-PARSE-ERROR: should this be ;;; a TYPE-ERROR? -;;; FIXME: These fail in sbcl-0.pre7.15 because of some problem with -;;; interpreted UNLESS, so that e.g. -;;; (ignore-errors (make-pathname :host "FOO" :directory "!bla" :name "bar")) -;;; => NIL, # -;;; (not (ignore-errors (make-pathname :host "FOO" -;;; :directory "!bla" :name "bar"))) -;;; =>T -;;; (unless (not (ignore-errors (make-pathname :host "FOO" -;;; :directory "!bla" -;;; :name "bar"))) -;;; "foo") -;;; => "foo" -;;; (unless t "foo") -;;; => NIL -#| -;; error: directory-component not valid (assert (not (ignore-errors (make-pathname :host "FOO" :directory "!bla" :name "bar")))) @@ -113,7 +97,6 @@ ;;; from host mismatches). (assert (equal (namestring (parse-namestring "" "FOO")) "FOO:")) (assert (equal (namestring (parse-namestring "" :unspecific)) "")) -|# ;;; The third would work if the call were (and it should continue to ;;; work ...) diff --git a/version.lisp-expr b/version.lisp-expr index 27005dd..50e612e 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -16,4 +16,4 @@ ;;; four numeric fields, is used for versions which aren't released ;;; but correspond only to CVS tags or snapshots. -"0.pre7.14.flaky4.11" +"0.pre7.14.flaky4.12" -- 1.7.10.4