From 5f56a67a3e4c6564540ad6e79a91ee9b10be56fd Mon Sep 17 00:00:00 2001
From: jjgarcia <jjgarcia>
Date: Tue, 8 Jun 2004 14:46:21 +0000
Subject: [PATCH] Changed the structure of the data in *LINKING-CALLS*. Now
 function objects are stored, together with C variable/function names.

---
 src/cmp/cmpcall.lsp | 29 +++++++++++++----------------
 src/cmp/cmpdefs.lsp |  2 +-
 src/cmp/cmpeval.lsp |  2 +-
 src/cmp/cmptop.lsp  | 24 +++++++++++++-----------
 4 files changed, 28 insertions(+), 29 deletions(-)

diff --git a/src/cmp/cmpcall.lsp b/src/cmp/cmpcall.lsp
index fb2deadd0..5cc6bd760 100644
--- a/src/cmp/cmpcall.lsp
+++ b/src/cmp/cmpcall.lsp
@@ -207,24 +207,21 @@
 
 (defun call-loc (fname loc narg args)
   (if (eq args 'ARGS-PUSHED)
-      `(CALL-ARGS-PUSHED ,loc ,narg)
+      `(CALL-ARGS-PUSHED ,fname ,loc ,narg)
       `(CALL-NORMAL ,loc ,(coerce-locs args))))
 
 (defun emit-linking-call (fname narg args &aux i)
-  (cond ((null *linking-calls*)
-	 (cmpwarn "Emitting linking call for ~a" fname)
-	 (push (list fname 0 (add-symbol fname))
-	       *linking-calls*)
-	 (setq i 0))
-	((setq i (assoc fname *linking-calls*))
-	 (setq i (second i)))
-	(t (setq i (1+ (cadar *linking-calls*)))
-	   (cmpwarn "Emitting linking call for ~a" fname)
-	   (push (list fname i (add-symbol fname))
-		 *linking-calls*)))
-  (let ((fun (make-fun :name fname :global t :lambda 'NIL
-		       :cfun (format nil "(*LK~d)" i)
-		       :minarg 0 :maxarg call-arguments-limit)))
+  (let ((fun (second (assoc fname *linking-calls*))))
+    (unless fun
+      (let* ((i (length *linking-calls*))
+	     (var-name (format nil "LK~d" i))
+	     (c-name (format nil "LKF~d" i)))
+	(cmpnote "Emitting linking call for ~a" fname)
+	(setf fun (make-fun :name fname :global t :lambda 'NIL
+			    :cfun (format nil "(*LK~d)" i)
+			    :minarg 0 :maxarg call-arguments-limit))
+	(setf *linking-calls* (cons (list fname fun (add-symbol fname) c-name var-name)
+				    *linking-calls*))))
     (unwind-exit (call-loc fname fun narg args))))
 
 (defun call-exported-function (fname narg args fun-c-name minarg maxarg in-core)
@@ -320,7 +317,7 @@
 	 (lex-lvl (fun-level fun))
 	 (fun-c-name (fun-cfun fun))
 	 (fun-lisp-name (fun-name fun)))
-    (when (or (plusp lex-lvl) closure-p)
+    (when (or (plusp lex-lvl) (fun-closure fun))
       (error "WT-CALL-ARGS-PUSHED used with lexical closure.")
       (when (fun-closure fun)
 	(wt "cl_stack_push(env~d" *env-lvl* ")," narg "++,"))
diff --git a/src/cmp/cmpdefs.lsp b/src/cmp/cmpdefs.lsp
index a1f0dbbd5..4d7f60b3a 100644
--- a/src/cmp/cmpdefs.lsp
+++ b/src/cmp/cmpdefs.lsp
@@ -365,7 +365,7 @@ The default value is NIL.")
 
 (defvar *global-vars* nil)
 (defvar *global-funs* nil)		; holds	{ fun }*
-(defvar *linking-calls* nil)		; holds { ( global-fun-name vv ) }*
+(defvar *linking-calls* nil)		; holds { ( global-fun-name fun symbol c-fun-name var-name ) }*
 (defvar *local-funs* nil)		; holds { fun }*
 (defvar *top-level-forms* nil)		; holds { top-level-form }*
 ;;;
diff --git a/src/cmp/cmpeval.lsp b/src/cmp/cmpeval.lsp
index 7900b48b2..a15a9a5ea 100644
--- a/src/cmp/cmpeval.lsp
+++ b/src/cmp/cmpeval.lsp
@@ -248,7 +248,7 @@
 		(when (eq 'VAR (c1form-name y))
 		  ;; it's a variable, propagate type
 		  (setf (var-type (c1form-arg 0 y)) new-type))
-		(setf (c1form-primary-type y) new-type))))
+		(setf (c1form-type y) new-type))))
 	(make-c1form* 'SYS:STRUCTURE-SET :type (c1form-primary-type y)
 		      :args x (add-symbol name) (third args) y))
       (c1call-global 'SYS:STRUCTURE-SET args)))
diff --git a/src/cmp/cmptop.lsp b/src/cmp/cmptop.lsp
index 47e1df3a5..e405c523f 100644
--- a/src/cmp/cmptop.lsp
+++ b/src/cmp/cmptop.lsp
@@ -155,21 +155,23 @@
 		(wt-h "#else")
 		(wt-h "static cl_object VV[VM];")
 		(wt-h "#endif"))))))
-  (when *linking-calls*
-    (dotimes (i (length *linking-calls*))
-      (declare (fixnum i))
-      (wt-h "static cl_object LKF" i "(cl_narg, ...);")
-      (wt-h "static cl_object (*LK" i ")(cl_narg, ...)=LKF" i ";"))
-    )
+  (dolist (l *linking-calls*)
+    (let* ((c-name (fourth l))
+	   (var-name (fifth l)))
+      (wt-h "static cl_object " c-name "(cl_narg, ...);")
+      (wt-h "static cl_object (*" var-name ")(cl_narg, ...)=" c-name ";")))
+
   ;;; Global entries for directly called functions.
   (dolist (x *global-entries*)
     (apply 'wt-global-entry x))
-  
+
   ;;; Initial functions for linking calls.
-  (dolist (x *linking-calls*)
-    (let ((i (second x)))
-      (wt-nl1 "static cl_object LKF" i
-	      "(cl_narg narg, ...) {TRAMPOLINK(narg," (third x) ",&LK" i ",Cblock);}")))
+  (dolist (l *linking-calls*)
+    (let* ((var-name (fifth l))
+	   (c-name (fourth l))
+	   (lisp-name (third l)))
+      (wt-nl1 "static cl_object " c-name "(cl_narg narg, ...)"
+	      "{TRAMPOLINK(narg," lisp-name ",&" var-name ",Cblock);}")))
 
   (wt-h "#ifdef __cplusplus")
   (wt-h "}")