Fix compiler passes.

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)

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))

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

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)