diff --git a/src/org/armedbear/lisp/compiler-pass1.lisp b/src/org/armedbear/lisp/compiler-pass1.lisp index 35298de73..b861e267d 100644 --- a/src/org/armedbear/lisp/compiler-pass1.lisp +++ b/src/org/armedbear/lisp/compiler-pass1.lisp @@ -767,7 +767,7 @@ where each of the vars returned is a list with these elements: ;; tag. (setf live nil)) (push (p1 subform) new-body)))) - (setf (tagbody-form block) (list* 'TAGBODY (nreverse new-body)))) + (setf (tagbody-form block) (cons form (list* 'TAGBODY (nreverse new-body))))) (when (some #'tag-used-non-locally (tagbody-tags block)) (push (setf (tagbody-id-variable block) (make-variable :name (gensym) diff --git a/src/org/armedbear/lisp/compiler-pass2.lisp b/src/org/armedbear/lisp/compiler-pass2.lisp index 37879dbbf..deb89c2ff 100644 --- a/src/org/armedbear/lisp/compiler-pass2.lisp +++ b/src/org/armedbear/lisp/compiler-pass2.lisp @@ -3635,7 +3635,8 @@ given a specific common representation.") (let* ((*blocks* (cons block *blocks*)) (*visible-tags* *visible-tags*) (*register* *register*) - (form (tagbody-form block)) + (original-body (cdr (car (tagbody-form block)))) + (form (cdr (tagbody-form block))) (body (cdr form)) (BEGIN-BLOCK (gensym "F")) (END-BLOCK (gensym "U")) @@ -3658,14 +3659,16 @@ given a specific common representation.") (when (tagbody-non-local-go-p block) (save-dynamic-environment specials-register)) (label BEGIN-BLOCK) - (do* ((rest body (cdr rest)) + (do* ((original-rest original-body (cdr original-rest)) + (original-subform (car original-rest) (car original-rest)) + (rest body (cdr rest)) (subform (car rest) (car rest))) ((null rest)) - (cond ((or (symbolp subform) (integerp subform)) - (let ((tag (find subform (tagbody-tags block) :key #'tag-name + (cond ((or (symbolp original-subform) (integerp original-subform)) + (let ((tag (find original-subform (tagbody-tags block) :key #'tag-name :test #'eql))) (unless tag - (error "COMPILE-TAGBODY: tag not found: ~S~%" subform)) + (error "COMPILE-TAGBODY: tag not found: ~S~%" original-subform)) (when (tag-used tag) (label (tag-label tag))))) (t @@ -4487,7 +4490,10 @@ given a specific common representation.") (setf type1 (derive-compiler-type arg1) type2 (derive-compiler-type arg2) result-type (derive-compiler-type form)) - (cond ((and (fixnum-constant-value type1) (fixnum-constant-value type2)) + (cond ((and (node-constant-value-p arg1) + (node-constant-value-p arg2) + (fixnum-constant-value type1) + (fixnum-constant-value type2)) (compile-constant (logior (fixnum-constant-value type1) (fixnum-constant-value type2)) target representation)) @@ -4995,6 +5001,11 @@ given a specific common representation.") (derive-compiler-type (third form)) t)) +(define-derive-type-handler progn (form) + (if (cdr form) + (derive-compiler-type (car (last (cdr form)))) + NIL)) + (defknown derive-type-logior/logxor (t) t) (defun derive-type-logior/logxor (form) (let ((op (car form)) diff --git a/src/org/armedbear/lisp/jvm.lisp b/src/org/armedbear/lisp/jvm.lisp index 32ed1a087..a1d4c6252 100644 --- a/src/org/armedbear/lisp/jvm.lisp +++ b/src/org/armedbear/lisp/jvm.lisp @@ -658,6 +658,17 @@ until predicate returns non-NIL, returning that value. (t nil))) +(defknown node-constant-value-p (t) boolean) +(defun node-constant-value-p (object) + (cond ((node-p object) + nil) + ((var-ref-p object) + (var-ref-constant-p object)) + ((constantp object) + t) + (t + nil))) + (defknown block-requires-non-local-exit-p (t) boolean) (defun block-requires-non-local-exit-p (object) "A block which *always* requires a 'non-local-exit' is a block which diff --git a/test/lisp/abcl/bugs.lisp b/test/lisp/abcl/bugs.lisp index 88aee59ff..3fe580530 100644 --- a/test/lisp/abcl/bugs.lisp +++ b/test/lisp/abcl/bugs.lisp @@ -163,4 +163,12 @@ nil) result) t) - +;;; https://abcl.org/trac/ticket/454 +(deftest bugs.tagbody.1 + (functionp (compile nil '(lambda () (tagbody (catch 'c 100))))) + t) + +;;; https://abcl.org/trac/ticket/455 +(deftest bugs.boole.1 + (eval (funcall (compile nil '(lambda () (let ((a 15)) (boole boole-2 (logior 0 (setf a 14)) a)))))) + 14)