[armedbear-cvs] r12101 - trunk/abcl/src/org/armedbear/lisp

[Erik Huelsmann]

Author: ehuelsmann
Date: Thu Aug 13 16:51:43 2009
New Revision: 12101

Log:
Convert CATCH and SYNCHRONIZED-ON block-nodes to
CATCH-NODEs and SYNCHRONIZED-NODEs respectively.

Modified:
   trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp
   trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
   trunk/abcl/src/org/armedbear/lisp/jvm.lisp

Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp	Thu Aug 13 16:51:43 2009
@@ -294,7 +294,7 @@
 (defun p1-catch (form)
   (let* ((tag (p1 (cadr form)))
          (body (cddr form))
-         (block (make-block-node '(CATCH)))
+         (block (make-catch-node))
          ;; our subform processors need to know
          ;; they're enclosed in a CATCH block
          (*blocks* (cons block *blocks*))
@@ -311,13 +311,13 @@
       (return-from p1-catch (car result)))
     (push tag result)
     (push 'CATCH result)
-    (setf (block-form block) result)
+    (setf (catch-form block) result)
     block))
 
 (defun p1-threads-synchronized-on (form)
   (let* ((synchronized-object (p1 (cadr form)))
          (body (cddr form))
-         (block (make-block-node '(THREADS:SYNCHRONIZED-ON)))
+         (block (make-synchronized-node))
          (*blocks* (cons block *blocks*))
          result)
     (dolist (subform body)
@@ -325,7 +325,7 @@
         (push (p1 subform) result)
         (when (memq op '(GO RETURN-FROM THROW))
           (return))))
-    (setf (block-form block)
+    (setf (synchronized-form block)
           (list* 'threads:synchronized-on synchronized-object
                  (nreverse result)))
     block))

Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	Thu Aug 13 16:51:43 2009
@@ -7681,7 +7681,7 @@
 
 (defknown p2-threads-synchronized-on (t t) t)
 (defun p2-threads-synchronized-on (block target)
-  (let* ((form (block-form block))
+  (let* ((form (synchronized-form block))
          (*register* *register*)
          (object-register (allocate-register))
          (BEGIN-PROTECTED-RANGE (gensym))
@@ -7694,7 +7694,8 @@
     (astore object-register)
     (emit 'monitorenter)
     (label BEGIN-PROTECTED-RANGE)
-    (compile-progn-body (cddr form) target)
+    (let ((*blocks* (cons block *blocks*)))
+      (compile-progn-body (cddr form) target))
     (emit 'goto EXIT)
     (label END-PROTECTED-RANGE)
     (aload object-register)
@@ -7712,7 +7713,7 @@
 
 (defknown p2-catch-node (t t) t)
 (defun p2-catch-node (block target)
-  (let ((form (block-form block)))
+  (let ((form (catch-form block)))
     (when (= (length form) 2) ; (catch 'foo)
       (when target
         (emit-push-nil)
@@ -7947,6 +7948,9 @@
             (fix-boxing representation nil))
            ((progv-node-p form)
             (p2-progv-node form target representation))
+           ((synchronized-node-p form)
+            (p2-threads-synchronized-on form target)
+            (fix-boxing representation nil))
 ))
         ((constantp form)
          (compile-constant form target representation))

Modified: trunk/abcl/src/org/armedbear/lisp/jvm.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/jvm.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/jvm.lisp	Thu Aug 13 16:51:43 2009
@@ -481,6 +481,7 @@
 "
   (or (unwind-protect-node-p object)
       (catch-node-p object)
+      (synchronized-node-p object)
       (and (block-node-p object)
            (equal (block-name object) '(THREADS:SYNCHRONIZED-ON)))))