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

[Frode Vatvedt Fjeld]

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

Modified Files:
	special-operators.lisp 
Log Message:
Started support for stack-allocating functions (of dynamic
extent). Primary purpose is to evaluate e.g. handler-case without
having to cons up a function for each handler.

Date: Mon Jan  3 12:55:51 2005
Author: ffjeld

Index: movitz/special-operators.lisp
diff -u movitz/special-operators.lisp:1.45 movitz/special-operators.lisp:1.46
--- movitz/special-operators.lisp:1.45	Sat Nov 20 00:03:49 2004
+++ movitz/special-operators.lisp	Mon Jan  3 12:55:36 2005
@@ -1,6 +1,6 @@
 ;;;;------------------------------------------------------------------
 ;;;; 
-;;;;    Copyright (C) 20012000, 2002-2004,
+;;;;    Copyright (C) 20012000, 2002-2005,
 ;;;;    Department of Computer Science, University of Tromso, Norway
 ;;;; 
 ;;;; Filename:      special-operators.lisp
@@ -8,7 +8,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Fri Nov 24 16:22:59 2000
 ;;;;                
-;;;; $Id: special-operators.lisp,v 1.45 2004/11/19 23:03:49 ffjeld Exp $
+;;;; $Id: special-operators.lisp,v 1.46 2005/01/03 11:55:36 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -1148,15 +1148,15 @@
 	  :form keyform
 	  :result-mode :eax
 	  :forward all)
+;;;      (declare (ignore keyform-type))
 ;;;      (warn "keyform type: ~S" keyform-type)
 ;;;      (warn "clause-types: ~S" (mapcar #'car clauses))
-      (declare (ignore keyform-type))
+      #+ignore
       (let ((clause (find 'muerte.cl::t clauses :key #'car)))
 	(assert clause)
 	(compiler-call #'compile-implicit-progn
 	  :form (cdr clause)
 	  :forward all))
-      #+ignore
       (loop for (clause-type . clause-forms) in clauses
 	  when (movitz-subtypep (type-specifier-primary keyform-type) clause-type)
 	  return (compiler-call #'compile-implicit-progn
@@ -1317,3 +1317,56 @@
 	:returns returns
 	:code `((:eql ,x ,y ,returns))))))
 			     
+
+(define-special-operator muerte::with-dynamic-extent-scope
+    (&all all &form form &env env &funobj funobj)
+  (destructuring-bind ((scope-tag) &body body)
+      (cdr form)
+    (let* ((save-esp-binding (make-instance 'located-binding
+			       :name (gensym "dynamic-extent-save-esp-")))
+	   (base-binding (make-instance 'located-binding
+			   :name (gensym "dynamic-extent-base-")))
+	   (scope-env
+	    (make-local-movitz-environment env funobj
+					   :type 'with-dynamic-extent-scope-env
+					   :scope-tag scope-tag
+					   :save-esp-binding save-esp-binding
+					   :base-binding base-binding)))
+      (movitz-env-add-binding scope-env save-esp-binding)
+      (movitz-env-add-binding scope-env base-binding)
+      (compiler-values-bind (&code body-code &all body-values)
+	  (compiler-call #'compile-implicit-progn
+	    :env scope-env
+	    :form body
+	    :forward all)
+	(compiler-values (body-values)
+	  :code (append `((:init-lexvar ,save-esp-binding
+					:init-with-register :esp
+					:init-with-type fixnum)
+			  (:enter-dynamic-scope ,scope-env)
+			  (:init-lexvar ,base-binding
+					:init-with-register :esp
+					:init-with-type fixnum))
+			body-code
+			`((:load-lexical ,save-esp-binding :esp))))))))
+
+(define-special-operator muerte::with-dynamic-extent-allocation
+    (&all all &form form &env env &funobj funobj)
+  (destructuring-bind ((scope-tag) &body body)
+      (cdr form)
+    (let* ((scope-env (loop for e = env then (movitz-environment-uplink e)
+			  unless e
+			  do (error "Dynamic-extent scope ~S not seen." scope-tag)
+			  when (and (typep e 'with-dynamic-extent-scope-env)
+				    (eq scope-tag (dynamic-extent-scope-tag e)))
+			  return e))
+	   (allocation-env
+	    (make-local-movitz-environment env funobj
+					   :type 'with-dynamic-extent-allocation-env
+					   :scope scope-env)))
+      (compiler-call #'compile-implicit-progn
+	:form body
+	:forward all
+	:env allocation-env))))
+						       
+