Update of /project/movitz/cvsroot/movitz
In directory common-lisp.net:/tmp/cvs-serv9504
Modified Files:
special-operators.lisp
Log Message:
Changed exact-throw, the basic operator for dynamic control transfer,
quite a bit. The (ill-specified) primitive-function
dynamic-locate-catch-tag is removed, its essential job is now
performed by the normal function find-catch-tag.
Date: Fri Nov 12 15:51:45 2004
Author: ffjeld
Index: movitz/special-operators.lisp
diff -u movitz/special-operators.lisp:1.42 movitz/special-operators.lisp:1.43
--- movitz/special-operators.lisp:1.42 Thu Oct 21 22:41:56 2004
+++ movitz/special-operators.lisp Fri Nov 12 15:51:44 2004
@@ -8,7 +8,7 @@
;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org>
;;;; Created at: Fri Nov 24 16:22:59 2000
;;;;
-;;;; $Id: special-operators.lisp,v 1.42 2004/10/21 20:41:56 ffjeld Exp $
+;;;; $Id: special-operators.lisp,v 1.43 2004/11/12 14:51:44 ffjeld Exp $
;;;;
;;;;------------------------------------------------------------------
@@ -1175,7 +1175,10 @@
finally (error "No compiler-typecase clause matched compile-time type ~S." keyform-type)))))
(define-special-operator muerte::exact-throw (&all all-throw &form form &env env &funobj funobj)
- (destructuring-bind (tag context value-form)
+ "Perform a dynamic control transfer to catch-env-slot context (evaluated),
+with values from value-form. Error-form, if provided, is evaluated in case the context
+is zero (i.e. not found)."
+ (destructuring-bind (context value-form &optional error-form)
(cdr form)
(let* ((local-env (make-local-movitz-environment env funobj :type 'let-env))
(dynamic-slot-binding
@@ -1186,43 +1189,46 @@
(movitz-env-add-binding local-env
(make-instance 'located-binding
:name (gensym "continuation-step-")))))
- (with-labels (throw (save-tag-var save-context-var))
- (compiler-values ()
- :returns :non-local-exit
- :code (append (compiler-call #'compile-form
- :forward all-throw
- :result-mode :multiple-values
- :form `(muerte.cl:let ((,save-tag-var ,tag)
- (,save-context-var ,context))
- (muerte.cl:multiple-value-prog1
- ,value-form
- (muerte::with-inline-assembly (:returns :nothing)
- (:compile-two-forms (:eax :ebx) ,save-tag-var ,save-context-var)
- (:globally (:call (:edi (:edi-offset dynamic-locate-catch-tag))))
- (:jnc '(:sub-program () (:int 108)))
- (:store-lexical ,dynamic-slot-binding :eax :type t)
- (:globally (:call (:edi (:edi-offset dynamic-unwind-next))))
- (:store-lexical ,next-continuation-step-binding :eax :type t)
- ))))
- ;; now outside of m-v-prog1's cloak, with final dynamic-slot in ..
- ;; ..unwind it and transfer control.
- ;;
- ;; * 12 dynamic-env uplink
- ;; * 8 target jumper number
- ;; * 4 target catch tag
- ;; * 0 target EBP
- `((:load-lexical ,dynamic-slot-binding :edx)
- (:locally (:movl :edx (:edi (:edi-offset raw-scratch0)))) ; final continuation
- (:load-lexical ,next-continuation-step-binding :edx) ; next continuation-step
- (:locally (:movl :esi (:edi (:edi-offset scratch1))))
- (:locally (:movl :edx (:edi (:edi-offset dynamic-env)))) ; exit dynamic-env
- (:movl :edx :esp) ; enter non-local jump stack mode.
+ (compiler-values ()
+ :returns :non-local-exit
+ :code (append (compiler-call #'compile-form
+ :forward all-throw
+ :result-mode dynamic-slot-binding
+ :form context)
+ (compiler-call #'compile-form
+ :forward all-throw
+ :result-mode :multiple-values
+ :form `(muerte.cl:multiple-value-prog1
+ ,value-form
+ (muerte::with-inline-assembly (:returns :nothing)
+ (:load-lexical ,dynamic-slot-binding :eax)
+ ,@(when error-form
+ `((:testl :eax :eax)
+ (:jz '(:sub-program ()
+ (:compile-form (:result-mode :ignore)
+ ,error-form)))))
+ (:locally (:call (:edi (:edi-offset dynamic-unwind-next))))
+ (:store-lexical ,next-continuation-step-binding :eax :type t)
+ )))
+ ;; now outside of m-v-prog1's cloak, with final dynamic-slot in ..
+ ;; ..unwind it and transfer control.
+ ;;
+ ;; * 12 dynamic-env uplink
+ ;; * 8 target jumper number
+ ;; * 4 target catch tag
+ ;; * 0 target EBP
+ `((:load-lexical ,dynamic-slot-binding :edx)
+ (:locally (:movl :edx (:edi (:edi-offset raw-scratch0)))) ; final continuation
+ (:load-lexical ,next-continuation-step-binding :edx) ; next continuation-step
+ (:locally (:movl :esi (:edi (:edi-offset scratch1))))
+ (:locally (:movl :edx (:edi (:edi-offset dynamic-env)))) ; exit dynamic-env
+ (:movl :edx :esp) ; enter non-local jump stack mode.
- (:movl (:esp) :edx) ; target stack-frame EBP
- (:movl (:edx -4) :esi) ; get target funobj into ESI
+ (:movl (:esp) :edx) ; target stack-frame EBP
+ (:movl (:edx -4) :esi) ; get target funobj into ESI
- (:movl (:esp 8) :edx) ; target jumper number
- (:jmp (:esi :edx ,(slot-offset 'movitz-funobj 'constant0))))))))))
+ (:movl (:esp 8) :edx) ; target jumper number
+ (:jmp (:esi :edx ,(slot-offset 'movitz-funobj 'constant0)))))))))
(define-special-operator muerte::with-basic-restart (&all defaults &form form &env env)