[movitz-cvs] CVS update: movitz/special-operators-cl.lisp

[Frode Vatvedt Fjeld]

Update of /project/movitz/cvsroot/movitz
In directory common-lisp.net:/tmp/cvs-serv9027

Modified Files:
	special-operators-cl.lisp 
Log Message:
Fix non-local go to work across unwind-protects.

Date: Fri Oct  8 12:26:38 2004
Author: ffjeld

Index: movitz/special-operators-cl.lisp
diff -u movitz/special-operators-cl.lisp:1.25 movitz/special-operators-cl.lisp:1.26
--- movitz/special-operators-cl.lisp:1.25	Thu Oct  7 14:52:47 2004
+++ movitz/special-operators-cl.lisp	Fri Oct  8 12:26:38 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Fri Nov 24 16:31:11 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: special-operators-cl.lisp,v 1.25 2004/10/07 12:52:47 ffjeld Exp $
+;;;; $Id: special-operators-cl.lisp,v 1.26 2004/10/08 10:26:38 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -725,20 +725,18 @@
 	  (compiler-values ()
 	    :returns :non-local-exit
 	    :code `((:lexical-control-transfer nil :nothing ,env ,tagbody-env ,label)))
-	;; Perform a lexical "throw" to the tag. Much like a regular throw, except
-	;; no values are transferred, and we step _into_ that dynamic env, not outside it.
+	;; Perform a lexical "throw" to the tag. Just like a regular (dynamic) throw.
 	(let ((save-esp-binding (movitz-binding (save-esp-variable tagbody-env) env))
 	      (label-id (movitz-env-get tag 'go-tag-label-id nil tagbody-env nil)))
 	  (assert label-id)
-	  #+ignore
-	  (compiler-call #'compile-form-unprotected
-	    :forward all
-	    :form `(muerte::exact-throw ,(movitz-env-lexical-catch-tag-variable tagbody-env)
-					0 nil))
 	  (compiler-values ()
 	    :returns :non-local-exit
 	    :code `((:load-lexical ,save-esp-binding :edx)
 		    (:movl :edx :eax)
+		    ,@(when (plusp label-id)
+			;; The target jumper points to the tagbody's label-set.
+			;; Now, install correct jumper within tagbody as target.
+			`((:addl ,(* 4 label-id) (:edx 8))))
 		    (:globally (:call (:edi (:edi-offset dynamic-unwind-next))))
 		    (:jnc '(:sub-program () (:int 63)))
 		    ;; have next-continuation in EAX, final-continuation in EDX
@@ -749,26 +747,8 @@
 		    (:movl (:esp) :eax)	; target stack-frame EBP
 		    (:movl (:eax -4) :esi) ; get target funobj into ESI
 		    (:movl (:esp 8) :eax) ; target jumper number
-		    (:jmp (:esi :eax
-				,(* 4 label-id) ,(slot-offset 'movitz-funobj 'constant0)))))
-	  #+ignore
-	  (compiler-values ()
-	    :returns :non-local-exit
-	    :code (append (compiler-call #'compile-form
-			    :result-mode :eax
-			    :forward all
-			    :form (movitz-env-lexical-catch-tag-variable tagbody-env))
-			  `((:xorl :ebx :ebx)
-			    (:globally (:call (:edi (:edi-offset dynamic-locate-catch-tag))))
-			    (:jnc '(:sub-program () (:int 108)))
-			    (:locally (:bound (:edi (:edi-offset stack-bottom)) :eax))
-			    (:movl :eax :esp)
-			    (:movl (:esp) :ebp)
-			    (:movl (:ebp -4) :esi)
-			    (:locally (:movl :eax (:edi (:edi-offset dynamic-env)))) ; enter dynamic env
-			    (:movl (:esp 8) :ecx) ; label-set base
-			    (:jmp (:esi :ecx ,(+ (slot-offset 'movitz-funobj 'constant0)
-						 (* 4 label-id)))))))))))) ; transfer control, finally.
+		    (:clc)
+		    (:jmp (:esi :eax ,(slot-offset 'movitz-funobj 'constant0))))))))))
 
 (define-special-operator block (&all forward &funobj funobj &form form &env env
 				     &result-mode result-mode)