[movitz-cvs] CVS movitz

[ffjeld]

Update of /project/movitz/cvsroot/movitz
In directory clnet:/tmp/cvs-serv12394

Modified Files:
	compiler.lisp 
Log Message:
Fixed up layout-program and related functions a bit. Removed remnants
of old &key parsing strategy.


--- /project/movitz/cvsroot/movitz/compiler.lisp	2007/02/20 21:57:13	1.177
+++ /project/movitz/cvsroot/movitz/compiler.lisp	2007/02/22 21:00:21	1.178
@@ -8,7 +8,7 @@
 ;;;; Created at:    Wed Oct 25 12:30:49 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: compiler.lisp,v 1.177 2007/02/20 21:57:13 ffjeld Exp $
+;;;; $Id: compiler.lisp,v 1.178 2007/02/22 21:00:21 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -1484,7 +1484,7 @@
        (new-program nil))
       ((endp pc)
        (assert (not pending-subs) ()
-	 "pending subs: ~S" pending-subs)
+	 "pending sub-programs: ~S" pending-subs)
        (nreverse new-program))
     (let ((i (pop pc)))
       (multiple-value-bind (sub-prg sub-opts)
@@ -2605,15 +2605,11 @@
 (defclass supplied-p-function-argument (function-argument) ())
 
 (defclass rest-function-argument (positional-function-argument) ())
-(defclass hidden-rest-function-argument (rest-function-argument) ())
 
 (defclass keyword-function-argument (non-required-function-argument)
   ((keyword-name
     :initarg :keyword-name
-    :reader keyword-function-argument-keyword-name)
-   (rest-var-name
-    :initarg :rest-var-name
-    :reader keyword-function-argument-rest-var-name)))
+    :reader keyword-function-argument-keyword-name)))
 
 (defclass dynamic-binding (variable-binding) ())
 
@@ -2745,25 +2741,26 @@
 ;;;
 
 
-(defun instruction-sub-program (instruction)
-  "When an instruction contains a sub-program, return that program, and 
-the sub-program options (&optional label) as secondary value."
-  (and (consp instruction)
-       (consp (second instruction))
-       (symbolp (car (second instruction)))
-       (string= 'quote (car (second instruction)))
-       (let ((x (second (second instruction))))
-	 (and (consp x)
-	      (eq :sub-program (car x))
-	      (values (cddr x)
-		      (second x))))))
-
 (defun ignore-instruction-prefixes (instruction)
   (if (and (consp instruction)
 	   (listp (car instruction)))
       (cdr instruction)
     instruction))
 
+(defun instruction-sub-program (instruction)
+  "When an instruction contains a sub-program, return that program, and 
+the sub-program options (&optional label) as secondary value."
+  (let ((instruction (ignore-instruction-prefixes instruction)))
+    (and (consp instruction)
+	 (consp (second instruction))
+	 (symbolp (car (second instruction)))
+	 (string= 'quote (car (second instruction)))
+	 (let ((x (second (second instruction))))
+	   (and (consp x)
+		(eq :sub-program (car x))
+		(values (cddr x)
+			(second x)))))))
+
 (defun instruction-is (instruction &optional operator)
   (and (listp instruction)
        (if (member (car instruction) '(:globally :locally))
@@ -3205,7 +3202,6 @@
 								     (binding-env binding) nil)
 						     (movitz-env-get variable 'ignorable nil
 								     (binding-env binding) nil)
-						     (typep binding 'hidden-rest-function-argument)
 						     (third (gethash binding var-counts)))
 					   (warn "Unused variable: ~S"
 						 (binding-name binding))))
@@ -4410,11 +4406,6 @@
 	    (movitz-env-add-binding env (make-instance 'rest-function-argument
 				       :name formal
 				       :argnum (post-incf arg-pos)))))
-;;;	(when key-vars-p
-;;;	  ;; We need to check at run-time whether keyword checking is supressed or not.
-;;;	  (setf (allow-other-keys-var env)
-;;;	    (movitz-env-add-binding env (make-instance 'located-binding
-;;;					  :name (gensym "allow-other-keys-var-")))))
 	(when key-vars-p
 	  (setf (key-vars-p env) t)
 	  (when (>= 1 (rest-args-position env))
@@ -4436,28 +4427,16 @@
 	      (setf (movitz-env-get name 'ignore nil env) t))))
 	(setf (key-vars env)
 	  (loop for spec in key-vars
-	      with rest-var-name =
-		(or rest-var
-		    (and key-vars
-			 (let ((name (gensym "hidden-rest-var-")))
-			   (movitz-env-add-binding env (make-instance 'hidden-rest-function-argument
-							 :name name
-							 :argnum (post-incf arg-pos)))
-			   name)))
 	      collect
 		(multiple-value-bind (formal keyword-name init-form supplied-p)
 		    (decode-keyword-formal spec)
-		  (let ((formal
-			 (shadow-when-special formal env))
-			(supplied-p-parameter
-			 (or supplied-p
-			     #+ignore (gensym "supplied-p-"))))
+		  (let ((formal (shadow-when-special formal env))
+			(supplied-p-parameter supplied-p))
 		    (movitz-env-add-binding env (make-instance 'keyword-function-argument
 						  :name formal
 						  'init-form init-form
 						  'supplied-p-var supplied-p-parameter
-						  :keyword-name keyword-name
-						  :rest-var-name rest-var-name))
+						  :keyword-name keyword-name))
 		    (when supplied-p-parameter
 		      (movitz-env-add-binding env (make-instance 'supplied-p-function-argument
 						    :name (shadow-when-special supplied-p-parameter env))))
@@ -4830,12 +4809,6 @@
 	(optional-vars (optional-vars env))
 	(rest-var (rest-var env))
 	(key-vars (key-vars env)))
-    (when (and (not rest-var)
-	       key-vars
-	       (not (= 1 (length key-vars))))
-      (setf rest-var
-	(keyword-function-argument-rest-var-name
-	 (movitz-binding (decode-keyword-formal (first key-vars)) env))))
     (values
      (append
       (loop for optional in optional-vars
@@ -6753,9 +6726,8 @@
 	 (cond
 	  ((typep binding 'rest-function-argument)
 	   (assert (eq :edx init-with-register))
-	   (assert (or (typep binding 'hidden-rest-function-argument)
-		       (movitz-env-get (binding-name binding)
-				       'dynamic-extent nil (binding-env binding)))
+	   (assert (movitz-env-get (binding-name binding)
+				   'dynamic-extent nil (binding-env binding))
 	       ()
 	     "&REST variable ~S must be dynamic-extent." (binding-name binding))
 	   (setf (need-normalized-ecx-p (find-function-env (binding-env binding)