From 6578ad223515dc2c1ddf49346f4baf7c3bee37c4 Mon Sep 17 00:00:00 2001 From: Red Daly Date: Wed, 18 Aug 2010 19:26:02 -0700 Subject: [PATCH] condition system for Parenscript: HANDLER-BIND, HANDLER-CASE, RESTART-CASE, RESTART-BIND, INVOKE-RESTART --- paren-psos.asd | 9 ++- src/conditions-macrology.lisp | 104 +++++++++++++++++++++++++++ src/paren/paren-conditions.paren | 92 ++++++++++++++++++++++++ src/paren/psos.paren | 2 +- test/test-conditions.lisp | 120 +++++++++++++++++++++++++++++++ 5 files changed, 325 insertions(+), 2 deletions(-) create mode 100644 src/conditions-macrology.lisp create mode 100644 src/paren/paren-conditions.paren create mode 100644 test/test-conditions.lisp diff --git a/paren-psos.asd b/paren-psos.asd index d2788d6..13ac1e0 100644 --- a/paren-psos.asd +++ b/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." diff --git a/src/conditions-macrology.lisp b/src/conditions-macrology.lisp new file mode 100644 index 0000000..294a0b3 --- /dev/null +++ b/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)))))) + \ No newline at end of file diff --git a/src/paren/paren-conditions.paren b/src/paren/paren-conditions.paren new file mode 100644 index 0000000..076b31d --- /dev/null +++ b/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*)) \ No newline at end of file diff --git a/src/paren/psos.paren b/src/paren/psos.paren index b60cc1f..8d00fcc 100644 --- a/src/paren/psos.paren +++ b/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 diff --git a/test/test-conditions.lisp b/test/test-conditions.lisp new file mode 100644 index 0000000..33cf648 --- /dev/null +++ b/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)))))) + + \ No newline at end of file