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

[Frode Vatvedt Fjeld]

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

Modified Files:
	compiler.lisp 
Log Message:
Rearranging compiler code somewhat. Still no change in compiler
functionality.

Date: Wed Feb  4 05:33:14 2004
Author: ffjeld

Index: movitz/compiler.lisp
diff -u movitz/compiler.lisp:1.10 movitz/compiler.lisp:1.11
--- movitz/compiler.lisp:1.10	Tue Feb  3 14:17:24 2004
+++ movitz/compiler.lisp	Wed Feb  4 05:33:14 2004
@@ -8,7 +8,7 @@
 ;;;; Created at:    Wed Oct 25 12:30:49 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: compiler.lisp,v 1.10 2004/02/03 19:17:24 ffjeld Exp $
+;;;; $Id: compiler.lisp,v 1.11 2004/02/04 10:33:14 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -108,7 +108,7 @@
 
 (defconstant +code-vector-entry-factor+ 1)
 
-(defclass movitz-funobj-pass1 (movitz-heap-object)
+(defclass movitz-funobj-pass1 ()
   ((name
     :initarg :name
     :accessor movitz-funobj-name)
@@ -119,13 +119,14 @@
     :accessor function-envs)
    (funobj-env
     :initarg :funobj-env
-    :accessor funobj-env)
-   (body-compiler-values
-    :accessor body-compiler-values))
+    :accessor funobj-env))
   (:documentation "This class is used for funobjs during the first compiler pass.
 Before the second pass, such objects will be change-class-ed to proper movitz-funobjs.
 This way, we ensure that no undue side-effects on the funobj occur during pass 1."))
 
+(defclass movitz-funobj-pass1-numargs-case (movitz-funobj-pass1) ())
+(defclass movitz-funobj-pass1-1req1opt (movitz-funobj-pass1) ())
+
 (defmethod print-object ((object movitz-funobj-pass1) stream)
   (print-unreadable-object (object stream :type t :identity t)
     (when (slot-boundp object 'name)
@@ -140,6 +141,7 @@
     (coerce lambda-form 'function)))
 
 (defun make-compiled-funobj (name lambda-list declarations form env top-level-p funobj)
+  "Compiler entry-point for making a (lexically) top-level function."
   (handler-bind (((or warning error)
 		  (lambda (c)
 		    (declare (ignore c))
@@ -151,22 +153,32 @@
 			      name muerte.cl:*compile-file-pathname*)))))
     (register-function-code-size
      (make-compiled-funobj-pass2
-      (make-compiled-funobj-pass1 name lambda-list declarations form env top-level-p funobj)))))
+      (make-compiled-funobj-pass1 name lambda-list declarations
+				  form env top-level-p funobj)))))
 
 (defun make-compiled-funobj-pass1 (name lambda-list declarations form env top-level-p funobj)
   "Entry-point for first-pass compilation."
   (with-retries-until-true (retry-pass1 "Retry first-pass compilation of ~S." name)
     ;; First-pass is mostly functional, so it can safely be restarted.
-    (funcall (cond
-	      ((let ((sub-form (cddr form)))
-		 (and (consp (car sub-form))
-		      (eq 'muerte::numargs-case (caar sub-form))))
-	       'make-compiled-function-pass1-numarg-case)
-	      (t 'make-compiled-function-pass1))
-	     name lambda-list declarations form env top-level-p funobj)))
+    (multiple-value-bind (required-vars optional-vars rest-var key-vars)
+	(decode-normal-lambda-list lambda-list)
+      ;; There are several main branches through the function
+      ;; compiler, and this is where we decide which to take.
+      (funcall (cond
+		((let ((sub-form (cddr form)))
+		   (and (consp (car sub-form))
+			(eq 'muerte::numargs-case (caar sub-form))))
+		 'make-compiled-function-pass1-numarg-case)
+		((and (= 1 (length required-vars))
+		      (= 1 (length optional-vars))
+		      (null key-vars)
+		      (not rest-var))
+		 'make-compiled-function-pass1)
+		(t 'make-compiled-function-pass1))
+	       name lambda-list declarations form env top-level-p funobj))))
 
 (defun make-compiled-function-pass1-numarg-case (name lambda-list declarations form env top-level-p funobj)
-  (let* ((funobj (or funobj (make-instance 'movitz-funobj-pass1)))
+  (let* ((funobj (or funobj (make-instance 'movitz-funobj-pass1-numargs-case)))
 	 (funobj-env (make-local-movitz-environment env funobj :type 'funobj-env)))
     (setf (movitz-funobj-name funobj) name
 	  (movitz-funobj-lambda-list funobj) (movitz-read (lambda-list-simplify lambda-list))
@@ -244,6 +256,7 @@
      (resolve-sub-functions funobj)))))
 
 (defun analyze-bindings (toplevel-funobj)
+  "Figure out usage of bindings in a toplevel funobj."
   (let ((bindings ()))
     (labels ((type-is-t (type-specifier)
 	       (or (eq type-specifier t)