C2 functions now receive the C1FORM as an argument.

src/cmp/cmpblock.lsp

@@ -44,7 +44,7 @@
 			:args blk body)
 	  body))))
 
-(defun c2block (blk body)
+(defun c2block (c1form blk body)
   (if (plusp (var-ref (blk-var blk)))
       (let* ((blk-var (blk-var blk))
 	     (*env-lvl* *env-lvl*))
@@ -103,7 +103,7 @@
 	  (when var (add-to-read-nodes var output))
 	  output)))))
 
-(defun c2return-from (blk type val var)
+(defun c2return-from (c1form blk type val var)
   (declare (ignore var))
   (case type
     (CCB

src/cmp/cmpcall.lsp

@@ -68,7 +68,7 @@
 	  (t
 	   (cmperr "Malformed function name: ~A" fun)))))
 
-(defun c2funcall (form args)
+(defun c2funcall (c1form form args)
   (let* ((*inline-blocks* 0)
          (*temp* *temp*)
          (form-type (c1form-primary-type form))
@@ -83,13 +83,13 @@
 ;;;   ARGS is the list of arguments
 ;;;   LOC is either NIL or the location of the function object
 ;;;
-(defun c2call-global (fname args &optional (return-type T))
+(defun c2call-global (c1form fname args)
   (let ((fun (find fname *global-funs* :key #'fun-name :test #'same-fname-p)))
     (when (and fun (c2try-tail-recursive-call fun args))
       (return-from c2call-global))
     (let* ((*inline-blocks* 0)
            (*temp* *temp*))
-      (unwind-exit (call-global-loc fname fun args return-type
+      (unwind-exit (call-global-loc fname fun args (c1form-type c1form)
                                     (loc-type *destination*)))
       (close-inline-blocks))))
 

src/cmp/cmpcatch.lsp

@@ -20,7 +20,7 @@
   (make-c1form* 'CATCH :sp-change t :type t :args (c1expr (first args))
 		(c1progn (rest args))))
 
-(defun c2catch (tag body)
+(defun c2catch (c1form tag body)
   (let* ((new-destination (tmp-destination *destination*)))
     (let* ((*destination* 'VALUE0))
       (c2expr* tag))
@@ -54,7 +54,7 @@
     (make-c1form* 'UNWIND-PROTECT :type (c1form-type form) :sp-change t
 		  :args form (c1progn (rest args)))))
 
-(defun c2unwind-protect (form body)
+(defun c2unwind-protect (c1form form body)
   (let* ((sp (make-lcl-var :rep-type :cl-index))
 	 (nargs (make-lcl-var :rep-type :cl-index))
 	 (*unwind-exit* `((STACK ,sp) ,@*unwind-exit*)))
@@ -90,7 +90,7 @@
   (check-args-number 'THROW args 2 2)
   (make-c1form* 'THROW :args (c1expr (first args)) (c1expr (second args))))
 
-(defun c2throw (tag val &aux loc)
+(defun c2throw (c1form tag val &aux loc)
   (case (c1form-name tag)
     ((VAR LOCATION) (setq loc (c1form-arg 0 tag)))
     (t (setq loc (make-temp-var))

src/cmp/cmpeval.lsp

@@ -159,11 +159,7 @@
     (let* ((name (c1form-name form))
            (args (c1form-args form))
            (dispatch (gethash name *c2-dispatch-table*)))
-      (if (or (eq name 'LET) (eq name 'LET*))
-          (let ((*volatile* (c1form-volatile* form)))
-            (declare (special *volatile*))
-            (apply dispatch args))
-          (apply dispatch args)))))
+      (apply dispatch form args))))
 
 (defun c2expr* (form)
   (let* ((*exit* (next-label))
@@ -190,7 +186,7 @@
 		  (output-type (and output-form (c1form-type output-form))))
 	     (make-c1form* 'PROGN :type output-type :args fl)))))
 
-(defun c2progn (forms)
+(defun c2progn (c1form forms)
   ;; c1progn ensures that the length of forms is not less than 1.
   (do ((l forms (cdr l))
        (lex *lex*))

src/cmp/cmpexit.lsp

@@ -204,7 +204,8 @@
     (let* ((*destination* 'TRASH)
 	   (*exit* (next-label))
 	   (*unwind-exit* (cons *exit* *unwind-exit*)))
-      (c2psetq (cdr *tail-recursion-info*) args)
+      (c2psetq nil ;; We do not provide any C2FORM
+	       (cdr *tail-recursion-info*) args)
       (wt-label *exit*))
     (unwind-no-exit 'TAIL-RECURSION-MARK)
     (wt-nl "goto TTL;")

src/cmp/cmpffi.lsp

@@ -583,7 +583,7 @@
 	       (wt "cl_env_copy->nvalues=" (length output-vars) ";")
 	       'VALUES))))))
 
-(defun c2c-inline (arguments &rest rest)
+(defun c2c-inline (c1form arguments &rest rest)
   (let ((*inline-blocks* 0)
         (*temp* *temp*))
     (unwind-exit (apply #'produce-inline-loc (inline-args arguments) rest))

src/cmp/cmpflet.lsp

@@ -160,10 +160,10 @@
 	    (setf recompute t finish nil))))
       t)))
 
-(defun c2locals (funs body labels ;; labels is T when deriving from labels
-		      &aux block-p
-		      (*env* *env*)
-		      (*env-lvl* *env-lvl*) env-grows)
+(defun c2locals (c1form funs body labels ;; labels is T when deriving from labels
+		 &aux block-p
+		 (*env* *env*)
+		 (*env-lvl* *env-lvl*) env-grows)
   ;; create location for each function which is returned,
   ;; either in lexical:
   (dolist (fun funs)
@@ -256,7 +256,7 @@
 			   (var-kind var) 'LEXICAL))))))
     fun))
 
-(defun c2call-local (fun args &optional narg)
+(defun c2call-local (c1form fun args)
   (declare (type fun fun))
   (unless (c2try-tail-recursive-call fun args)
     (let ((*inline-blocks* 0)

src/cmp/cmpform.lsp

@@ -190,7 +190,6 @@
           (*compile-file-position* (c1form-file-position ,form))
           (*current-toplevel-form* (c1form-toplevel-form ,form))
           (*current-form* (c1form-form ,form))
-          (*current-c2form* ,form)
           (*cmp-env* (c1form-env ,form)))
      ,@body))
 

src/cmp/cmpglobals.lsp

@@ -38,7 +38,6 @@
 ;;;
 (defvar *current-form* '|compiler preprocess|)
 (defvar *current-toplevel-form* '|compiler preprocess|)
-(defvar *current-c2form* nil)
 (defvar *compile-file-position* -1)
 (defvar *first-error* t)
 (defvar *active-protection* nil)

src/cmp/cmpif.lsp

@@ -81,7 +81,7 @@
      ,@body
      (wt-label ,label))))
 
-(defun c2if (fmla form1 form2)
+(defun c2if (c1form fmla form1 form2)
   ;; FIXME! Optimize when FORM1 or FORM2 are constants
   (with-exit-label (normal-exit)
     (with-exit-label (false-label)
@@ -105,7 +105,7 @@
                  (:object '((:object) (:object) "Null(#0)?Ct:Cnil" nil t))
                  (otherwise (return-from negate-argument nil)))))))
 
-(defun c2fmla-not (arg)
+(defun c2fmla-not (c1form arg)
   (let ((dest *destination*))
     (cond ((and (consp dest) (eq (car dest) 'JUMP-TRUE))
            (let ((*destination* `(JUMP-FALSE ,@(cdr dest))))
@@ -129,7 +129,7 @@
   (let ((dest *destination*))
     (and (consp dest) (eq (car dest) 'JUMP-FALSE))))
 
-(defun c2fmla-and (butlast last)
+(defun c2fmla-and (c1form butlast last)
   (if (jump-false-destination?)
       (progn
 	(mapc #'c2expr* butlast)
@@ -141,7 +141,7 @@
 	  (c2expr last))
 	(unwind-exit nil))))
 
-(defun c2fmla-or (butlast last)
+(defun c2fmla-or (c1form butlast last)
   (cond ((jump-true-destination?)
 	 (mapc #'c2expr* butlast)
 	 (c2expr last))

src/cmp/cmplet.lsp

@@ -241,8 +241,9 @@
     (baboon :format-control "In REPLACEABLE, variable ~A not found. Form:~%~A"
             :format-arguments (list (var-name var) *current-form*))))
 
-(defun c2let* (vars forms body
+(defun c2let* (c1form vars forms body
 	       &aux
+	       (*volatile* (c1form-volatile* c1form))
 	       (*unwind-exit* *unwind-exit*)
 	       (*env* *env*)
 	       (*env-lvl* *env-lvl*)

src/cmp/cmpmulti.lsp

@@ -58,7 +58,7 @@
 (defun c1values (args)
   (make-c1form* 'VALUES :args (c1args* args)))
 
-(defun c2values (forms)
+(defun c2values (c1form forms)
   (when (and (eq *destination* 'RETURN-OBJECT)
              (rest forms)
              (consp *current-form*)
@@ -224,7 +224,7 @@
 	(when labels (wt-label label))))
     output))
 
-(defun c2multiple-value-setq (vars form)
+(defun c2multiple-value-setq (c1form vars form)
   (multiple-value-bind (min-values max-values)
       (c1form-values-number form)
     (unwind-exit 
@@ -257,7 +257,7 @@
                       :local-vars vars
                       :args vars init-form body)))))
 
-(defun c2multiple-value-bind (vars init-form body)
+(defun c2multiple-value-bind (c1form vars init-form body)
   ;; 0) Compile the form which is going to give us the values
   (let ((*destination* 'VALUES)) (c2expr* init-form))
 

src/cmp/cmpprop.lsp

@@ -105,7 +105,7 @@ of the occurrences in those lists."
 			     values-type))
     (values values-type assumptions)))
 
-(defun p1call-global (c1form assumptions fname args &optional (return-type t))
+(defun p1call-global (c1form assumptions fname args)
   (loop for v in args
      do (multiple-value-bind (arg-type local-ass)
             (p1propagate v assumptions)
@@ -116,7 +116,7 @@ of the occurrences in those lists."
 		       type (c1form-type c1form))
                (return (values type assumptions)))))
 
-(defun p1call-local (c1form assumptions fun args &optional (return-type t))
+(defun p1call-local (c1form assumptions fun args)
   (loop for v in args
      do (multiple-value-bind (arg-type local-ass)
             (p1propagate v assumptions)

src/cmp/cmpspecial.lsp

@@ -52,7 +52,7 @@
   (setq args (progv symbols values (c1progn (cdr args))))
   (make-c1form 'COMPILER-LET args symbols values args))
 
-(defun c2compiler-let (symbols values body)
+(defun c2compiler-let (c1form symbols values body)
   (progv symbols values (c2expr body)))
 
 (defun c1function (args &aux fd)
@@ -82,7 +82,7 @@
 	       (make-c1form 'FUNCTION lambda-form 'CLOSURE lambda-form funob))))
 	  (t (cmperr "The function ~s is illegal." fun)))))
 
-(defun c2function (kind funob fun)
+(defun c2function (c1form kind funob fun)
   (case kind
     (GLOBAL
      (unwind-exit (list 'FDEFINITION fun)))

src/cmp/cmpstack.lsp

@@ -35,7 +35,7 @@
 		    :type (c1form-type body)
 		    :args body)))
 
-(defun c2with-stack (body)
+(defun c2with-stack (c1form body)
   (let* ((new-destination (tmp-destination *destination*))
 	 (*temp* *temp*))
     (wt-nl "{ struct ecl_stack_frame _ecl_inner_frame_aux;")
@@ -65,7 +65,7 @@
 		  (c1expr `(c-inline (,frame-var) (t) :void "ecl_stack_frame_push_values(#0)"
 				     :one-liner t :side-effects t)))))
 
-(defun c2stack-push-values (form push-statement)
+(defun c2stack-push-values (c1form form push-statement)
   (let ((*destination* 'VALUES))
     (c2expr* form))
   (c2expr push-statement))

src/cmp/cmpstructures.lsp

@@ -79,7 +79,7 @@
 			    nil)))
 	(c1call-global 'sys:structure-ref args))))
 
-(defun c2structure-ref (form name-vv index unsafe)
+(defun c2structure-ref (c1form form name-vv index unsafe)
   (let* ((*inline-blocks* 0)
          (*temp* *temp*)
 	 (loc (first (coerce-locs (inline-args (list form))))))
@@ -125,8 +125,7 @@
 		      :args x (add-symbol name) (third args) y))
       (c1call-global 'SYS:STRUCTURE-SET args)))
 
-(defun c2structure-set (x name-vv index y
-			  &aux locs (*inline-blocks* 0))
+(defun c2structure-set (c1form x name-vv index y)
   ;; the third argument here *c1t* is just a hack to ensure that
   ;; a variable is introduced for y if it is an expression with side effects
   (let* ((*inline-blocks* 0)

src/cmp/cmptables.lsp

@@ -168,6 +168,8 @@
     (value0 . set-value0-loc)
     (return . set-return-loc)
     (trash . set-trash-loc)
+
+    (the . set-the-loc)
     ))
 
 (defconstant +wt-loc-dispatch-alist+
@@ -187,6 +189,7 @@
     (character-value . wt-character)
     (value . wt-value)
     (keyvars . wt-keyvars)
+    (the . wt-the)
 
     (fdefinition . wt-fdefinition)
     (make-cclosure . wt-make-closure)
@@ -222,8 +225,6 @@
 
     (let* . c2let*)
 
-    (multiple-value-call . c2multiple-value-call) ; c2
-    (multiple-value-prog1 . c2multiple-value-prog1) ; c2
     (values . c2values) ; c2
     (multiple-value-setq . c2multiple-value-setq) ; c2
     (multiple-value-bind . c2multiple-value-bind) ; c2

src/cmp/cmptag.lsp

@@ -123,7 +123,7 @@
   (make-c1form* 'TAGBODY :local-vars (list tag-var)
 		:args tag-var body))
 
-(defun c2tagbody (tag-loc body)
+(defun c2tagbody (c1form tag-loc body)
   (declare (type var tag-loc))
   (if (null (var-kind tag-loc))
       ;; only local goto's
@@ -209,7 +209,7 @@
 	(incf (tag-ref tag))
 	(add-to-read-nodes var (make-c1form* 'GO :args tag (or ccb clb unw)))))))
 
-(defun c2go (tag nonlocal)
+(defun c2go (c1form tag nonlocal)
   (if nonlocal
       (let ((var (tag-var tag)))
 	(wt-nl "cl_go(" var ",MAKE_FIXNUM(" (tag-index tag) "));"))

src/cmp/cmptop.lsp

@@ -73,9 +73,8 @@
                 (*compile-file-position* (c1form-file-position form))
                 (*current-toplevel-form* (c1form-form form))
                 (*current-form* (c1form-form form))
-                (*current-c2form* form)
                 (*cmp-env* (c1form-env form)))
-            (apply def (c1form-args form)))
+            (apply def form (c1form-args form)))
           (cmperr "Unhandled T2FORM found at the toplevel:~%~4I~A"
                   form)))))
 
@@ -299,10 +298,10 @@ return f2;
 	  (t
 	   (c1progn 'NIL)))))
 
-(defun t2compiler-let (symbols values body)
+(defun t2compiler-let (c1form symbols values body)
   (progv symbols values (c2expr body)))
 
-(defun t2progn (args)
+(defun t2progn (c1form args)
   (mapc #'t2expr args))
 
 (defun exported-fname (name)
@@ -510,7 +509,7 @@ return f2;
 (defun p1ordinary (c1form assumptions form)
   (p1propagate form assumptions))
 
-(defun t2ordinary (form)
+(defun t2ordinary (c1form form)
   (let* ((*exit* (next-label))
 	 (*unwind-exit* (list *exit*))
          (*destination* 'TRASH))
@@ -554,19 +553,19 @@ return f2;
 	   (setf loc (add-object (cmp-eval form)))))
     (make-c1form* 'LOCATION :type t :args loc)))
 
-(defun t2load-time-value (vv-loc form)
+(defun t2load-time-value (c1form vv-loc form)
   (let* ((*exit* (next-label)) (*unwind-exit* (list *exit*))
          (*destination* vv-loc))
     (c2expr form)
     (wt-label *exit*)))
 
-(defun t2make-form (vv-loc form)
+(defun t2make-form (c1form vv-loc form)
   (let* ((*exit* (next-label)) (*unwind-exit* (list *exit*))
          (*destination* vv-loc))
     (c2expr form)
     (wt-label *exit*)))
 
-(defun t2init-form (vv-loc form)
+(defun t2init-form (c1form vv-loc form)
   (let* ((*exit* (next-label)) (*unwind-exit* (list *exit*))
          (*destination* 'TRASH))
     (c2expr form)
@@ -811,7 +810,7 @@ return f2;
 (defun p1fset (c1form assumptions fun fname macro pprint c1forms)
   (p1propagate (fun-lambda fun) assumptions))
 
-(defun c2fset (fun fname macro pprint c1forms)
+(defun c2fset (c1form fun fname macro pprint c1forms)
   (when (fun-no-entry fun)
     (wt-nl "(void)0; /* No entry created for "
 	   (format nil "~A" (fun-name fun))
@@ -822,7 +821,7 @@ return f2;
   (unless (and (not (fun-closure fun))
 	       (eq *destination* 'TRASH))
     (return-from c2fset
-      (c2call-global 'SI:FSET c1forms (c1form-primary-type (second c1forms)))))
+      (c2call-global c1form 'SI:FSET c1forms)))
   (let ((*inline-blocks* 0)
 	(loc (data-empty-loc)))
     (push (list loc fname fun) *global-cfuns-array*)

src/cmp/cmptype-assert.lsp

@@ -32,7 +32,7 @@
 			:type (reduce #'type-or types)
 			:args var expressions)))))
 
-(defun c2compiler-typecase (var expressions)
+(defun c2compiler-typecase (c1form var expressions)
   (loop with var-type = (var-type var)
      for (type form) in expressions
      when (or (member type '(t otherwise))
@@ -122,7 +122,7 @@
 			   :type type
 			   :args type form (c1expr full-check)))))))
 
-(defun c2checked-value (type value let-form)
+(defun c2checked-value (c1form type value let-form)
   (c2expr (if (subtypep (c1form-primary-type value) type)
 	      value
 	      let-form)))      

src/cmp/cmpvar.lsp

@@ -262,9 +262,10 @@
     (or (eq kind 'global)
         (eq kind 'special))))
 
-(defun c2var (vref) (unwind-exit vref))
+(defun c2var (c1form vref)
+  (unwind-exit vref))
 
-(defun c2location (loc) (unwind-exit loc))
+(defun c2location (c1form loc) (unwind-exit loc))
 
 (defun wt-var (var &aux (var-loc (var-loc var))) ; ccb
   (declare (type var var))
@@ -284,28 +285,28 @@
     (t (var-kind var))))
 
 (defun set-var (loc var &aux (var-loc (var-loc var))) ;  ccb
-  (if (var-p var)
-    (case (var-kind var)
-      (CLOSURE
-       (wt-nl)(wt-env var-loc)(wt "= ")
-       (wt-coerce-loc (var-rep-type var) loc)
-       (wt #\;))
-      (LEXICAL
-       (wt-nl)(wt-lex var-loc)(wt "= ")
-       (wt-coerce-loc (var-rep-type var) loc)
-       (wt #\;))
-      ((SPECIAL GLOBAL)
-       (if (safe-compile)
-	   (wt-nl "cl_set(" var-loc ",")
-	   (wt-nl "ECL_SETQ(cl_env_copy," var-loc ","))
-       (wt-coerce-loc (var-rep-type var) loc)
-       (wt ");"))
-      (t
-       (wt-nl var-loc "= ")
-       (wt-coerce-loc (var-rep-type var) loc)
-       (wt #\;))
-    )
-    (baboon)))
+  (unless (var-p var)
+    (baboon))
+  (case (var-kind var)
+    (CLOSURE
+     (wt-nl)(wt-env var-loc)(wt "= ")
+     (wt-coerce-loc (var-rep-type var) loc)
+     (wt #\;))
+    (LEXICAL
+     (wt-nl)(wt-lex var-loc)(wt "= ")
+     (wt-coerce-loc (var-rep-type var) loc)
+     (wt #\;))
+    ((SPECIAL GLOBAL)
+     (if (safe-compile)
+	 (wt-nl "cl_set(" var-loc ",")
+	 (wt-nl "ECL_SETQ(cl_env_copy," var-loc ","))
+     (wt-coerce-loc (var-rep-type var) loc)
+     (wt ");"))
+    (t
+     (wt-nl var-loc "= ")
+     (wt-coerce-loc (var-rep-type var) loc)
+     (wt #\;))
+    ))
 
 (defun wt-lex (lex)
   (if (consp lex)
@@ -369,10 +370,10 @@
 					     :args name form)))
       `(setf name ,form)))
 
-(defun c2setq (vref form)
+(defun c2setq (c1form vref form)
   (let ((*destination* vref)) (c2expr* form))
   (if (eq (c1form-name form) 'LOCATION)
-    (c2location (c1form-arg 0 form))
+    (c2location form (c1form-arg 0 form))
     (unwind-exit vref))
   )
 
@@ -384,7 +385,7 @@
     (make-c1form* 'PROGV :type (c1form-type forms)
 		  :args symbols values forms)))
 
-(defun c2progv (symbols values body)
+(defun c2progv (c1form symbols values body)
   (let* ((*lcl* *lcl*)
          (lcl (next-lcl))
          (sym-loc (make-lcl-var))
@@ -434,7 +435,7 @@
 			`(checked-value ,form ,type)))
 	    forms))))
 
-(defun c2psetq (vrefs forms &aux (*lcl* *lcl*) (saves nil) (blocks 0))
+(defun c2psetq (c1form vrefs forms &aux (*lcl* *lcl*) (saves nil) (blocks 0))
   ;; similar to inline-args
   (do ((vrefs vrefs (cdr vrefs))
        (forms forms (cdr forms))