condition system for Parenscript: HANDLER-BIND, HANDLER-CASE, RESTART…

…-CASE, RESTART-BIND, INVOKE-RESTART

paren-psos.asd

@@ -20,11 +20,13 @@
 			 ;; (:file "parse-lambda-list" :depends-on ("packages"))
 			 (:file "util-macrology" :depends-on ("lisp-integration"))
 			 (:file "psos-macrology" :depends-on ("util-macrology" "lisp-integration"))
+			 (:file "conditions-macrology" :depends-on ("util-macrology" "lisp-integration"))
 
 			 (:module "paren"
 				  :components
 				  ((:parenscript-file "package")
-				   (:parenscript-file "psos" :depends-on ("package")))))))
+				   (:parenscript-file "psos" :depends-on ("package"))
+                                   (:parenscript-file "paren-conditions" :depends-on ("psos")))))))
 
   :depends-on ("parenscript" "closer-mop" "paren-util" "rjson"))
 
@@ -41,6 +43,11 @@
 				  :components ((:parenscript-file "psos-test"))))))
   :depends-on ("parenscript" "paren-psos" "cl-spidermonkey" "hu.dwim.stefil"))
 
+(defmethod asdf:perform ((o asdf:test-op) (c (eql (asdf:find-system :paren-psos))))
+  (asdf:operate 'asdf:load-op :paren-psos-test)
+  (funcall (intern (symbol-name '#:paren-psos-tests)
+                   (find-package '#:psos-tests))))
+
 #+nil
 (defsystem :paren-psos-test
   :description "Lisp and Parenscript tests for the Parenscript Object System."

src/conditions-macrology.lisp

@@ -0,0 +1,104 @@
+(in-package :psos)
+
+(defpsmacro handler-bind (bindings &body body)
+  (with-ps-gensyms (local-handlers)
+    `(let ((,local-handlers (list ,@(mapcar #'(lambda (binding)
+                                                (destructuring-bind (type handler)
+                                                    binding
+                                                  `(create 'type ,type
+                                                           'fn ,handler)))
+                                            bindings))))
+       (let ((*original-handlers* *active-handlers*))
+         (declare (special *original-handlers*))
+         (let ((*active-handlers* (append ,local-handlers *original-handlers*)))
+           (declare (special *active-handlers*))
+           ,@body)))))
+
+(defpsmacro restart-bind (bindings &body body)
+  (with-ps-gensyms (local-restarts)
+    `(let ((,local-restarts (list ,@(mapcar #'(lambda (binding)
+                                                (destructuring-bind (name handler)
+                                                    binding
+                                                  `(create 'name ',name
+                                                           'fn ,handler)))
+                                            bindings))))
+       (let ((*active-restarts* (append ,local-restarts *active-restarts*)))
+         (declare (special *active-restarts*))
+         ,@body))))
+
+(defpsmacro restart-case (form &rest clauses)
+  (with-ps-gensyms (restart-block local-restarts)
+    `(block ,restart-block
+       (let ((,local-restarts (list ,@(mapcar #'(lambda (clause)
+                                                  (destructuring-bind (name lambda-list &body body)
+                                                      clause
+                                                    ;; todo strip out :report, :interactive, :test
+                                                    `(create 'name ',name
+                                                             'fn (lambda ()
+                                                                   (return-from ,restart-block
+                                                                     (apply (lambda ,lambda-list
+                                                                              ,@body)
+                                                                            arguments))))))
+
+                                              clauses))))
+         (let ((*active-restarts* (append ,local-restarts *active-handlers*)))
+           (declare (special *active-restarts*))
+           ,form)))))
+
+(defpsmacro restart-case (form &rest clauses)
+  (with-ps-gensyms (args-to-restart local-restarts)
+    `(let ((,local-restarts
+            (list ,@(mapcar #'(lambda (clause)
+                                (destructuring-bind (name lambda-list &body body)
+                                    clause
+                                  ;; todo strip out :report, :interactive, :test
+                                  `(create 'name ',name
+                                           'fn (lambda ()
+                                                 (let ((,args-to-restart arguments))
+                                                   (throw (create 'ps-signal-p t
+                                                                  'continuation (lambda ()
+                                                                                  (apply (lambda ,lambda-list
+                                                                                           ,@body)
+                                                                                         ,args-to-restart)))))))))
+                            clauses))))
+
+       (ps:try (let ((*active-restarts* (append ,local-restarts *active-restarts*)))
+                 (declare (special *active-restarts*))
+                 ,form)
+               (:catch (err)
+                 (if (and err (getprop err 'ps-signal-p))
+                     (funcall (getprop err 'continuation))
+                     (throw err)))))))
+
+(defpsmacro handler-case (form &rest clauses)
+  (with-ps-gensyms (local-handlers args-to-handler)
+    `(let ((,local-handlers 
+            (list ,@(mapcar #'(lambda (clause)
+                                (destructuring-bind (type lambda-list &body body)
+                                    clause
+                                  ;; todo strip out :report, :interactive, :test
+                                  `(create 'type ,type
+                                           'fn (lambda ()
+                                                 (let ((,args-to-handler arguments))
+                                                   (throw (create 'ps-signal-p t
+                                                                  'continuation (lambda ()
+                                                                                  (apply (lambda ,lambda-list
+                                                                                           ,@body)
+                                                                                         ,args-to-handler)))))))))
+                              clauses))))
+       (ps:try (let ((*active-handlers* (append ,local-handlers *active-handlers*)))
+                 (declare (special *active-handlers*))
+                 ,form)
+               (:catch (err)
+                 (if (and err (getprop err 'ps-signal-p))
+                     (funcall (getprop err 'continuation))
+                     (throw err)))))))
+
+
+
+;; the following is a lot more like handler-case
+;       (ps:try 
+;        (progn ,@body)))))
+;        (:catch (err)
+;          (invoke-handler-or-rethrow err ,activated-handlers ,original-handlers))))))
+

src/paren/paren-conditions.paren

@@ -0,0 +1,92 @@
+(in-package :psos)
+
+(defvar *active-handlers* (array)
+  "List of handler specs bound by HANDLER-BIND where each member of
+  the array is an object with keys 'TYPE and 'FN.  When a signal
+  is raised, handlers are checked first to last and ")
+
+(defvar *original-handlers* (array)
+  "List of handler specs bound by HANDLER-BIND where each member of
+  the array is an object with keys 'TYPE and 'FN.  When a signal
+  is raised, handlers are checked first to last and ")
+
+(defvar *active-restarts* (array)
+  "List of restart specs bound by HANDLER-BIND where each member of
+the array is an object with keys 'NAME and 'FN.")
+
+
+#+nil
+(defun invoke-handler-or-rethrow (err activated-handlers original-handlers)
+  "If ERR is a signal, searches the activated-handlers for a handler
+with an appropriate type.  IF one iis found that "
+  (if (not (and err (getprop err 'ps-signal-p)))
+      ;; re-raise throws we aren't supposed to inspect
+      (throw err)
+
+      (let* ((*active-handlers* original-handlers)
+             (err-class (class-of err))
+             (handler-fn nil))
+
+        (dolist (handler-spec activated-handlers)
+          (when (is-subclass-of (getprop handler-spec 'type) err-class)
+
+            (setf handler-fn (getprop handler-spec 'fn))))
+
+        (unless handler-fn
+          (pslog (:error "Failed to find an appropriate handler for error %o") err)
+          ;; todo raise rror
+          (return))
+        (funcall handler-fn err))))
+
+(defun invoke-handler-or-throw (err activated-handlers original-handlers)
+  "If ERR is a signal, searches the activated-handlers for a handler
+with an appropriate type.  IF one iis found that "
+  (if (not (and err (getprop err 'ps-signal-p)))
+      ;; re-raise throws we aren't supposed to inspect
+      (throw err)
+
+      (let* ((*active-handlers* original-handlers)
+             (err-class (class-of err))
+             (handler-fn nil))
+
+        (dolist (handler-spec activated-handlers)
+          (when (is-subclass-of (getprop handler-spec 'type) err-class)
+;          (when (is-subclass-of err-class (getprop handler-spec 'type))
+            (setf handler-fn (getprop handler-spec 'fn))
+            (break)))
+
+        (unless handler-fn
+          (pslog (:error "Failed to find an appropriate handler for error %o") err)
+          (throw (+ "Failed to find an appropriate handler for " err))
+          ;; todo raise error
+          (return))
+        (funcall handler-fn err))))
+
+(defun invoke-restart (designator &rest args)
+  "If ERR is a signal, searches the activated-handlers for a handler
+with an appropriate type.  IF one iis found that "
+  (let* ((restart-fn nil)
+         (string? (eql "string" (ps:typeof designator))))
+    (dolist (spec *active-restarts*)
+      (when (or (and string? (eql designator (getprop spec 'name)))
+                (eql designator spec))
+        (setf restart-fn (getprop spec 'fn))
+        (break)))
+
+    (unless restart-fn
+      (pslog (:error "Failed to find an appropriate restart to match %o") designator)
+      (throw (+ "Failed to find an appropriate restart to match " designator))
+      ;; todo raise error
+      (return))
+
+    (apply restart-fn args)))
+
+(defclass condition ()
+  ())
+
+(defclass standard-error (condition)
+  ())
+
+(defun signal (thing)
+  (setf (getprop thing 'ps-signal-p) t)
+  (invoke-handler-or-throw thing *active-handlers* *original-handlers*))

src/paren/psos.paren

@@ -307,7 +307,7 @@ the second argument is the function to be called when this method is called"
   (return concrete-function))
 
 (defun is-subclass-of (specializer test-class)
-  ""
+  "Returns T if TEST-CLASS is a subclass of SPECIALIZER."
   (return
     (if (=== specializer test-class)
 	t

test/test-conditions.lisp

@@ -0,0 +1,120 @@
+(in-package :paren-psos-tests)
+
+(defsuite paren-conditions-tests nil
+  (with-js-context (context)
+    (compile-and-evaluate-js "var window = this;" :filename "fakewindow.js")
+    (compile-and-evaluate-js (system-js) :filename "/tmp/paren-psos.js")
+    (run-child-tests)))
+
+(in-suite paren-conditions-tests)
+
+(deftest test-conditions-metaobjects ()
+  (ps-forms-equal-lisp-forms
+    (t (and condition t))))
+
+(deftest test-restart-case ()
+  (declare (optimize (debug 3)))
+  (ps-forms-equal-lisp-forms
+    (5 (funcall
+        (lambda ()
+          (restart-case (progn (invoke-restart 'thingoo 4) 10)
+            (thingoo (num)
+              (+ num 1))))))
+    (5 (funcall
+        (lambda ()
+          (restart-case (progn (+ (invoke-restart 'thingoo 5) 10))
+            (thingoo (num)
+              num)))))
+    ("enter-okay-unwind-restart-exit" 
+     (funcall
+      (lambda ()
+        (let ((r "enter-"))
+          (restart-case (try
+                         (progn
+                           (setf r (+ r "okay-"))
+                           (+ (invoke-restart 'thingoo 5) 10)
+                           (setf r (+ r "NEVER_GET_HERE")))
+                         (:finally
+                          (setf r (+ r "unwind-"))
+                          ))
+            (thingoo (num)
+              (setf r (+ r "restart-"))
+              num))
+          (setf r (+ r "exit"))
+          r))))))
+
+(deftest test-restart-bind ()
+  (declare (optimize (debug 3)))
+  (ps-forms-equal-lisp-forms
+    (10 (funcall
+         (lambda ()
+           (restart-bind ((xxx (lambda (thing)
+                                 20)))
+                         (invoke-restart 'xxx 4) 10))))
+    (12 (funcall
+         (lambda ()
+           (+ 1
+              (funcall 
+               (lambda ()
+                 (restart-bind ((xxx (lambda (thing)
+                                       20)))
+                               (invoke-restart 'xxx 4) 11)))))))))
+
+
+(deftest test-handler-bind ()
+  (declare (optimize (debug 3)))
+  (ps-forms-equal-lisp-forms
+    (6 (funcall
+         (lambda ()
+           (handler-bind ((condition (lambda (x)
+                                       1)))
+             (+ (signal (make-instance 'condition))
+                5)))))
+    (4 (progn
+         (defclass mine (condition)
+           ((x :initarg :x :initform 1 :accessor mine-x)))
+
+         (funcall
+          (lambda ()
+            (handler-bind ((mine (lambda (m)
+                                   (mine-x m)))
+                           (condition (lambda (x)
+                                        10)))
+              (+ (signal (make-instance 'mine))
+                 3))))))
+    (13 (progn
+          (funcall
+           (lambda ()
+             (handler-bind ((condition (lambda (x)
+                                         10)))
+               (+ (signal (make-instance 'mine))
+                  3))))))))
+
+
+
+(deftest test-handler-case ()
+  (declare (optimize (debug 3)))
+  (ps-forms-equal-lisp-forms
+    (17 (funcall
+         (lambda ()
+           (handler-case (signal (make-instance 'condition))
+             (condition (err) 17)))))
+    ("abcd" (funcall
+             (lambda ()
+               (let ((r "a"))
+                 (handler-case 
+                     (try
+                      (progn
+                        (setf r (+ r "b"))
+                        ;; signal should invoke a non-local exit, and
+                        ;; the handler should execute after unwinding
+                        (signal (make-instance 'condition))
+                        (setf r (+ r "x")))
+                      (:finally
+                        (setf r (+ r "c"))))
+                   (condition (err)
+                     (setf r (+ r "d"))
+                     17))
+                 r))))))
+
+