catch works

diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el
index 35a59dbe6070ea8d89291c2981ead267375a760e..005a7d0eb08741145d36cc35eb197a2e52acb305 100644 (file)
--- a/lisp/emacs-lisp/comp.el
+++ b/lisp/emacs-lisp/comp.el
@@ -407,6 +407,24 @@ If NEGATED non nil negate the test condition."
         (puthash n name hash)
         name))))
 
+(defun comp-emit-handler (guarded-label handler-type)
+  "Emit a non local exit handler for GUARDED-LABEL of type HANDLER-TYPE."
+  (let ((blocks (comp-func-blocks comp-func))
+             (guarded-bb (comp-new-block-sym)))
+         (puthash guarded-bb
+                 (make-comp-block :sp (comp-sp))
+                 blocks)
+         (let ((handler-bb (comp-lap-to-limple-bb guarded-label)))
+           (comp-emit (list 'push-handler (comp-slot-next)
+                            handler-type
+                            handler-bb
+                            guarded-bb))
+           (puthash handler-bb
+                   (make-comp-block :sp (1+ (comp-sp)))
+                   blocks)
+           (comp-mark-block-closed)
+           (comp-emit-block guarded-bb))))
+
 (defmacro comp-op-case (&rest cases)
   "Expand CASES into the corresponding pcase.
 This is responsible for generating the proper stack adjustment when known and
@@ -450,12 +468,12 @@ the annotation emission."
                                                  op-name))))
        (_ (error "Unexpected LAP op %s" (symbol-name op))))))
 
-(defun comp-limplify-lap-inst (inst)
-  "Limplify LAP instruction INST pushng it in the proper basic block."
-  (let ((op (car inst))
-        (arg (if (consp (cdr inst))
-                 (cadr inst)
-               (cdr inst))))
+(defun comp-limplify-lap-inst (insn)
+  "Limplify LAP instruction INSN pushng it in the proper basic block."
+  (let ((op (car insn))
+        (arg (if (consp (cdr insn))
+                 (cadr insn)
+               (cdr insn))))
     (comp-op-case
       (TAG
        (comp-emit-block (comp-lap-to-limple-bb arg)))
@@ -487,23 +505,9 @@ the annotation emission."
       (byte-pophandler
        (comp-emit '(pop-handler)))
       (byte-pushconditioncase
-       (let ((blocks (comp-func-blocks comp-func))
-             (guarded-bb (comp-new-block-sym)))
-         (puthash guarded-bb
-                 (make-comp-block :sp (comp-sp))
-                 blocks)
-         (let ((handler-bb (comp-lap-to-limple-bb (cl-third inst)))
-               (handler-type (cdr (last inst))))
-           (comp-emit (list 'push-handler (comp-slot-next)
-                            handler-type
-                            handler-bb
-                            guarded-bb))
-           (puthash handler-bb
-                   (make-comp-block :sp (1+ (comp-sp)))
-                   blocks)
-           (comp-mark-block-closed)
-           (comp-emit-block guarded-bb))))
-      (byte-pushcatch)
+       (comp-emit-handler (cl-third insn) 'condition-case))
+      (byte-pushcatch
+       (comp-emit-handler (cl-third insn) 'catcher))
       (byte-nth auto)
       (byte-symbolp auto)
       (byte-consp auto)
@@ -584,15 +588,15 @@ the annotation emission."
       (byte-end-of-line auto)
       (byte-constant2)
       (byte-goto
-       (comp-emit-jump (comp-lap-to-limple-bb (cl-third inst))))
+       (comp-emit-jump (comp-lap-to-limple-bb (cl-third insn))))
       (byte-goto-if-nil
-       (comp-emit-cond-jump 0 (cl-third inst) nil))
+       (comp-emit-cond-jump 0 (cl-third insn) nil))
       (byte-goto-if-not-nil
-       (comp-emit-cond-jump 0 (cl-third inst) t))
+       (comp-emit-cond-jump 0 (cl-third insn) t))
       (byte-goto-if-nil-else-pop
-       (comp-emit-cond-jump 1 (cl-third inst) nil))
+       (comp-emit-cond-jump 1 (cl-third insn) nil))
       (byte-goto-if-not-nil-else-pop
-       (comp-emit-cond-jump 1 (cl-third inst) t))
+       (comp-emit-cond-jump 1 (cl-third insn) t))
       (byte-return
        (comp-emit (list 'return (comp-slot-next)))
        (comp-mark-block-closed))

diff --git a/src/comp.c b/src/comp.c
index 93d0f81dbc836a8d414bef384f0c3656e88d2611..6436a5db7128b6bd5591fb25f290f7f806011db6 100644 (file)
--- a/src/comp.c
+++ b/src/comp.c
@@ -1138,10 +1138,17 @@ emit_limple_insn (Lisp_Object insn)
     {
       EMACS_UINT clobber_slot = XFIXNUM (FUNCALL1 (comp-mvar-slot, arg0));
       gcc_jit_rvalue *handler = emit_mvar_val (arg0);
+      int h_num;
+      if (EQ (SECOND (args), Qcatcher))
+       h_num = CATCHER;
+      else if (EQ (SECOND (args), Qcondition_case))
+       h_num = CONDITION_CASE;
+      else
+       eassert (false);
       gcc_jit_rvalue *handler_type =
        gcc_jit_context_new_rvalue_from_int (comp.ctxt,
                                             comp.int_type,
-                                            XFIXNUM (SECOND (args)));
+                                            h_num);
       gcc_jit_block *handler_bb = retrive_block (THIRD (args));
       gcc_jit_block *guarded_bb = retrive_block (FORTH (args));
       emit_limple_push_handler (handler, handler_type, handler_bb, guarded_bb,
@@ -2224,6 +2231,8 @@ syms_of_comp (void)
   DEFSYM (Qcond_jump, "cond-jump");
   DEFSYM (Qpush_handler, "push-handler");
   DEFSYM (Qpop_handler, "pop-handler");
+  DEFSYM (Qcondition_case, "condition-case");
+  DEFSYM (Qcatcher, "catcher");
 
   defsubr (&Scomp_init_ctxt);
   defsubr (&Scomp_release_ctxt);

diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el
index 871dede23a62cb063ee8c62509f0fec6c5719cf6..ed3a9b2f9d0177aed18fbaa0c6325c6def054f1f 100644 (file)
--- a/test/src/comp-tests.el
+++ b/test/src/comp-tests.el
@@ -448,26 +448,25 @@
                        (error-message-string err)
                        " catched"))))
 
-    ;; (defun comp-tests-catch-f (f)
-    ;;   (catch 'foo
-    ;;     (funcall f)))
+    (defun comp-tests-catch-f (f)
+      (catch 'foo
+        (funcall f)))
 
-    ;; (defun comp-tests-throw-f (x)
-    ;;   (throw 'foo x))
+    (defun comp-tests-throw-f (x)
+      (throw 'foo x))
 
     (native-compile #'comp-tests-condition-case-0-f)
     (native-compile #'comp-tests-condition-case-1-f)
-    ;; (native-compile #'comp-tests-catch-f)
-    ;; (native-compile #'comp-tests-throw-f)
+    (native-compile #'comp-tests-catch-f)
+    (native-compile #'comp-tests-throw-f)
 
     (should (string= (comp-tests-condition-case-0-f)
                      "arith-error Arithmetic error catched"))
     (should (string= (comp-tests-condition-case-1-f)
-                     "error foo catched")))
-  ;; (should (= (comp-tests-catch-f (lambda () (throw 'foo 3))) 3))
-  ;; (should (= (catch 'foo
-  ;;              (comp-tests-throw-f 3))))
-  )
+                     "error foo catched"))
+    (should (= (comp-tests-catch-f (lambda () (throw 'foo 3))) 3))
+    (should (= (catch 'foo
+                 (comp-tests-throw-f 3))))))
 
 (ert-deftest comp-tests-gc ()
   "Try to do some longer computation to let the gc kick in."