[movitz-cvs] CVS update: movitz/compiler-protocol.lisp

[Frode Vatvedt Fjeld]

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

Modified Files:
	compiler-protocol.lisp 
Log Message:
Re-worked several aspects of binding/environments: assignment,
type-inference, etc.

Date: Sat Aug 20 22:30:04 2005
Author: ffjeld

Index: movitz/compiler-protocol.lisp
diff -u movitz/compiler-protocol.lisp:1.3 movitz/compiler-protocol.lisp:1.4
--- movitz/compiler-protocol.lisp:1.3	Thu Feb 12 18:51:02 2004
+++ movitz/compiler-protocol.lisp	Sat Aug 20 22:30:03 2005
@@ -1,6 +1,6 @@
 ;;;;------------------------------------------------------------------
 ;;;; 
-;;;;    Copyright (C) 2001-2004, 
+;;;;    Copyright (C) 2001-2005, 
 ;;;;    Department of Computer Science, University of Tromso, Norway.
 ;;;; 
 ;;;;    For distribution policy, see the accompanying file COPYING.
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Wed Oct 10 13:02:03 2001
 ;;;;                
-;;;; $Id: compiler-protocol.lisp,v 1.3 2004/02/12 17:51:02 ffjeld Exp $
+;;;; $Id: compiler-protocol.lisp,v 1.4 2005/08/20 20:30:03 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -159,26 +159,29 @@
 				 ((&funobj funobj-var) (copy-symbol 'funobj) funobj-p)
 				 ((&env env-var) (copy-symbol 'env) env-p)
 				 ((&top-level-p top-level-p-var) (copy-symbol 'top-level-p) top-level-p-p)
-				 ((&result-mode result-mode-var) (copy-symbol 'result-mode) result-mode-p))
+				 ((&result-mode result-mode-var) (copy-symbol 'result-mode) result-mode-p)
+				 ((&extent extent-var) (copy-symbol 'extent) extent-p))
 			   &body defun-body)
   (multiple-value-bind (body docstring)
       (if (and (cdr defun-body)
 	       (stringp (car defun-body)))
 	  (values (cdr defun-body) (list (car defun-body)))
 	(values defun-body nil))
-    `(defun ,name (,form-var ,funobj-var ,env-var ,top-level-p-var ,result-mode-var)
+    `(defun ,name (,form-var ,funobj-var ,env-var ,top-level-p-var ,result-mode-var ,extent-var)
        , at docstring
        (declare (,(if all-p 'ignorable 'ignore)
 		    ,@(unless form-p (list form-var))
 		  ,@(unless funobj-p (list funobj-var))
 		  ,@(unless env-p (list env-var))
 		  ,@(unless top-level-p-p (list top-level-p-var))
-		  ,@(unless result-mode-p (list result-mode-var))))
+		  ,@(unless result-mode-p (list result-mode-var))
+		  ,@(unless extent-p (list extent-var))))
        (macrolet ((default-compiler-values-producer () '',name)
 		  ,@(when all-p
 		      `((,all-var (v) (ecase v (:form ',form-var) (:funobj ',funobj-var)
 					     (:env ',env-var) (:top-level-p ',top-level-p-var)
-					     (:result-mode ',result-mode-var))))))
+					     (:result-mode ',result-mode-var)
+					     (:extent ',extent-var))))))
 	 , at body))))
 
 (defmacro compiler-call (compiler-name &rest all-keys
@@ -186,6 +189,7 @@
 			      ((:form form-var) nil form-p)
 			      ((:funobj funobj-var) nil funobj-p)
 			      ((:env env-var) nil env-p)
+			      ((:extent extent-var) nil extent-p)
 			      ((:top-level-p top-level-p-var) nil top-level-p-p)
 			      ((:result-mode result-mode-var) :ignore result-mode-p))
   (assert (not (and defaults forward)) ()
@@ -208,7 +212,8 @@
 		   ,(if funobj-p funobj-var `(,defaults :funobj))
 		   inner-env
 		   ,(when top-level-p-p top-level-p-var) ; default to nil, no forwarding.
-		   ,(if result-mode-p result-mode-var `(,defaults :result-mode)))))
+		   ,(if result-mode-p result-mode-var `(,defaults :result-mode))
+		   ,(if extent-p extent-var `(,defaults :extent)))))
    (forward
     `(let* ((outer-env ,(if env-p env-var `(,forward :env)))
 	    (inner-env ,(if (not with-stack-used)
@@ -222,15 +227,17 @@
 		,(if funobj-p funobj-var `(,forward :funobj))
 		inner-env
 		,(if top-level-p-p top-level-p-var `(,forward :top-level-p))
-		,(if result-mode-p result-mode-var `(,forward :result-mode)))))
+		,(if result-mode-p result-mode-var `(,forward :result-mode))
+		,(if extent-p extent-var `(,forward :extent)))))
    ((not with-stack-used)
-    `(funcall ,compiler-name ,form-var ,funobj-var ,env-var ,top-level-p-var ,result-mode-var))
+    `(funcall ,compiler-name ,form-var ,funobj-var ,env-var
+	      ,top-level-p-var ,result-mode-var ,extent-var))
    (t (assert env-p () ":env is required when with-stack-used is given.")
       `(funcall ,compiler-name ,form-var ,funobj-var
 		(make-instance 'with-things-on-stack-env
 		  :uplink ,env-var :stack-used ,with-stack-used
 		  :funobj (movitz-environment-funobj ,env-var))
-		,top-level-p-var ,result-mode-var))))
+		,top-level-p-var ,result-mode-var ,extent-var))))
 
 (defmacro define-special-operator (name formals &body body)
   (let* ((movitz-name (intern (symbol-name (translate-program name :cl :muerte.cl))