[movitz-cvs] CVS update: movitz/environment.lisp

[Frode Vatvedt Fjeld]

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

Modified Files:
	environment.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:13 2005
Author: ffjeld

Index: movitz/environment.lisp
diff -u movitz/environment.lisp:1.10 movitz/environment.lisp:1.11
--- movitz/environment.lisp:1.10	Thu Dec  9 15:03:28 2004
+++ movitz/environment.lisp	Mon Jan  3 12:55:13 2005
@@ -1,6 +1,6 @@
 ;;;;------------------------------------------------------------------
 ;;;; 
-;;;;    Copyright (C) 2000-2004
+;;;;    Copyright (C) 2000-2005
 ;;;;    Department of Computer Science, University of Tromso, Norway
 ;;;; 
 ;;;; Filename:      environment.lisp
@@ -9,7 +9,7 @@
 ;;;; Created at:    Fri Nov  3 11:40:15 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: environment.lisp,v 1.10 2004/12/09 14:03:28 ffjeld Exp $
+;;;; $Id: environment.lisp,v 1.11 2005/01/03 11:55:13 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -101,11 +101,16 @@
     :initarg :num-specials
     :accessor num-specials)))
 
+(defclass progv-env (with-things-on-stack-env)
+  ((stack-used
+    :initform t)
+   (num-specials
+    :initform t)))
+
 (defun make-stack-use-env (stack-used)
   (make-instance 'with-things-on-stack-env
     :stack-used stack-used))
 
-
 (defclass let-env (with-things-on-stack-env)
   ((bindings
     :initform nil
@@ -121,6 +126,45 @@
     :initform nil
     :accessor special-variable-shadows)))
 
+(defclass with-dynamic-extent-scope-env (let-env)
+  ((save-esp-binding
+    :initarg :save-esp-binding
+    :accessor save-esp-binding)
+   (base-binding
+    :initarg :base-binding
+    :accessor base-binding)
+   (scope-tag
+    :initarg :scope-tag
+    :reader dynamic-extent-scope-tag)
+   (stack-used
+    :initform t)
+   (members
+    :initform nil
+    :accessor dynamic-extent-scope-members)))
+
+(defun dynamic-extent-allocation (env)
+  (loop for e = env then (movitz-environment-uplink e)
+      while e
+      do (when (typep e 'with-dynamic-extent-allocation-env)
+	   (return e))))
+
+(defun dynamic-extent-object-offset (scope-env object)
+  (loop with offset = 0
+      for x in (dynamic-extent-scope-members scope-env)
+      do (if (eq x object)
+	     (return (* 8 offset))
+	   (incf offset (truncate (+ (sizeof x) 4) 8)))))
+
+(defmethod print-object ((env with-dynamic-extent-scope-env) stream)
+  (print-unreadable-object (env stream :type t)
+    (princ (dynamic-extent-scope-tag env) stream))
+  env)
+
+(defclass with-dynamic-extent-allocation-env (movitz-environment)
+  ((scope
+    :initarg :scope
+    :reader allocation-env-scope)))
+
 (defclass funobj-env (let-env)
   ()
   (:documentation "A funobj-env represents the (possibly null)
@@ -189,7 +233,7 @@
     t)
    (t (sub-env-p (movitz-environment-uplink sub-env) env))))
 
-(defmethod num-dynamic-slots ((x let-env))
+(defmethod num-dynamic-slots ((x with-things-on-stack-env))
   (num-specials x))
 
 (defmethod print-object ((object let-env) stream)