diff --git a/code/c-call.lisp b/code/c-call.lisp
index ec27554fca0b2240c69da4399d602bdc0054f439..4844c8cd9bd672a7fc87a1909e5d8be61af60aa4 100644
--- a/code/c-call.lisp
+++ b/code/c-call.lisp
@@ -22,16 +22,18 @@
 		   char unsigned-char short unsigned-short
 		   int unsigned-int long unsigned-long
 		   void def-c-routine def-c-variable
-		   def-c-procedure reset-foreign-pointers))
+		   def-c-procedure))
 
 #-new-compiler
 (eval-when (compile)
   (setq lisp::*bootstrap-defmacro* t))
 
+#+nil
 (defvar foreign-routines-defined NIL
   "List of symbol/routine name pairs used to reset code pointers
   for foreign routines.")
 
+#+nil
 (defvar foreign-variables-defined NIL
   "List of symbol/variable name pairs used to reset pointers to
   foreign variables.")
@@ -158,7 +160,8 @@
 (proclaim '(function get-c-type (t) c-type))
 (defun get-c-type (spec)
   (cond ((gethash spec *c-type-names*))
-	((memq spec '(c-procedure short-float long-float))
+	((member spec
+		 '(c-procedure short-float long-float null-terminated-string))
 	 (let ((size (if (eq spec 'long-float) 64 32)))
 	   (make-primitive-type
 	    :description spec
@@ -234,6 +237,7 @@
   "Return the size in bits of the C-Type described by Spec."
   (c-type-size (get-c-type spec)))
 
+#-new-compiler
 (pushnew 'clc::fold-transform (get 'c-sizeof 'clc::clc-transforms))
 
 
@@ -430,29 +434,35 @@
   (name "" :type string)
   (function-name nil :type symbol)
   ;;
-  ;; Symbol name of the variable holding the code pointer for the routine.
-  (code nil :type symbol)
-  ;;
   ;; The number of words of arguments.
   (arg-size 0 :type unsigned-byte)
   ;;
-  ;; The global Alien var that we build the arguments in.  This is also the
-  ;; type of the Alien.
-  (arg-alien nil :type symbol)
+  ;; The name of the record that describes all the stuff on the stack.
+  (stack-record nil :type symbol)
   ;;
-  ;; The number of words of stack allocated for reference args.
-  (result-size 0 :type unsigned-byte)
+  ;; The name of the alien :copy args are allocated in.
+  (copy-args-buffer nil :type (or null symbol))
   ;;
-  ;;  Similar to Arg-Alien, but we receive results in it.
-  (result-alien nil :type symbol)
-  ;;
-  ;; List of Arg-Info structures.
+  ;; List of Arg-Info structures describing the args.
   (args nil :type list)
   ;;
   ;; The specified return-type for the function value.  Null if Void was
   ;; specified.
-  (return-type nil :type (or c-type null)))
-
+  (return-type nil :type (or c-type null))
+  ;;
+  ;; The SC the return value is passed in.
+  return-sc
+  ;;
+  ;; The vop we should use to coerce the return value.
+  return-move-vop
+  ;;
+  ;; The type for the return value, after the move vop and before any lisp
+  ;; level coerce code.
+  return-lisp-type
+  ;;
+  ;; Generate the lisp-level code to coerce the return value (if any)
+  return-coerce-generator
+  )
 
 (defstruct arg-info
   ;;
@@ -466,18 +476,165 @@
   mode
   options
   ;;
-  ;; Names of the operators that access this arg in the Args and Results
-  ;; Aliens.
-  (operator nil :type symbol)
-  (result-operator nil :type symbol)
+  ;; Where we pass this arg.  Either a storage class or :stack
+  allocation
+  ;;
+  ;; Either the offset in the storage class or stack.
+  offset
+  ;;
+  ;; Either the vop necessary to do the move, or the stack operator.
+  accessor
+  ;;
+  ;; Either operator to get at the arg, or NIL if it's :in.
+  buffer
+  ;;
+  ;; Either the name for :in, or some form for others.
+  passing-form
   )
 
 
-;;;
-;;;    A list of top-level forms that are emitted before the Defun.  This is
-;;; built in reverse order.
-;;;
-(defvar *output-forms*)
+(defun anotate-foreign-call (info)
+  (let ((offset 0))
+    (dolist (arg (routine-info-args info))
+      (setf (arg-info-allocation arg) :stack)
+      (setf (arg-info-offset arg) offset)
+      (let ((size (if (eq (arg-info-mode arg) :in)
+		      (c-sizeof 'system-area-pointer)
+		      (c-type-size (arg-info-type arg)))))
+	(setf offset (align-offset (+ offset size)
+				   (find-alignment size)))))
+    (setf (routine-info-arg-size info) offset))
+  (multiple-value-bind
+      (sc move-vop lisp-type)
+      (let ((type (routine-info-return-type info)))
+	(etypecase type
+	  (null)
+	  (primitive-type
+	   (let* ((descr (c-type-description type))
+		  (name (if (atom descr) descr (car descr)))
+		  (arg (if (consp descr) (cadr descr))))
+	     (ecase name
+	       (signed-byte 
+		(values 'c::signed-reg 'c::move descr))
+	       (unsigned-byte
+		(values 'c::unsigned-reg 'c::move descr))
+	       (null-terminated-string
+		(setf (routine-info-return-coerce-generator info)
+		      #'(lambda (form)
+			  `(import-string ,form)))
+		(values 'c::sap-reg 'c::move 'system-area-pointer))
+	       (boolean
+		(setf (routine-info-return-coerce-generator info)
+		      #'(lambda (form)
+			  `(not (zerop ,form))))
+		(values 'c::signed-reg 'c::move 'fixnum))
+	       ((system-area-pointer alien)
+		(when (eq name 'alien)
+		  (unless (> (length descr) 2)
+		    (error "Alien return types must include the size: ~S"
+			   descr))
+		  (setf (routine-info-return-coerce-generator info)
+			#'(lambda (form)
+			    `(make-alien ',arg ',(caddr descr) ,form))))
+		(values 'c::sap-reg 'c::move 'system-area-pointer))
+	       ((enumeration simple-string port short-float long-float)
+		(error "Can't return ~S yet." descr)))))
+	  (record-type
+	   (error "Can't return ~S yet." (c-type-description type)))
+	  ((or array-type pointer-type)
+	   (unless (c-type-size type)
+	     (error "Can't return arrays of unknown size: ~S"
+		    (c-type-description type)))
+	   (setf (routine-info-return-coerce-generator info)
+		 #'(lambda (form)
+		     `(make-alien ',(c-type-description type)
+				  ',(c-type-size type)
+				  ,form)))
+	   (values 'c::sap-ref 'c::move 'system-area-pointer))))
+    (setf (routine-info-return-sc info) sc)
+    (setf (routine-info-return-move-vop info) move-vop)
+    (setf (routine-info-return-lisp-type info) lisp-type))
+  (undefined-value))
+
+(defun pick-names (info)
+  (setf (routine-info-stack-record info)
+	(symbolicate (routine-info-function-name info) "-STACK-FRAME"))
+  (dolist (arg (routine-info-args info))
+    (unless (eq (arg-info-mode arg) :in)
+      (setf (arg-info-buffer arg)
+	    (symbolicate (routine-info-function-name info)
+			 "-"
+			 (arg-info-name arg)
+			 "-BUFFER")))
+    (when (eq (arg-info-allocation arg) :stack)
+      (setf (arg-info-accessor arg)
+	    (symbolicate (routine-info-function-name info)
+			 "-"
+			 (arg-info-name arg)
+			 (if (eq (arg-info-mode arg) :in)
+			     "-DATA"
+			     "-POINTER"))))))
+
+(defun compute-c-call-forms (info)
+  (let ((lisp-args nil)
+	(top-level-forms nil)
+	(arg-set-forms nil)
+	(result-get-forms nil))
+    (dolist (arg (routine-info-args info))
+      (cond ((arg-info-buffer arg)
+	     (unless (pointer-type-p (arg-info-type arg))
+	       (error "~S argument ~S must be a pointer type."
+		      (arg-info-mode arg)
+		      (arg-info-name arg)))
+	     (let* ((type (pointer-type-to (arg-info-type arg)))
+		    (size (c-type-size type))
+		    (offset (align-offset (routine-info-arg-size info)
+					  (find-alignment size))))
+	       (setf (routine-info-arg-size info)
+		     (+ offset size))
+	       (push `(defoperator (,(arg-info-buffer arg)
+				    ,(c-type-description (arg-info-type arg)))
+				   ((foo ,(routine-info-stack-record info)))
+			`(alien-index (alien-value ,foo) ,,offset ,,size))
+		     top-level-forms)
+	       (setf (arg-info-passing-form arg)
+		     `(alien-sap (,(arg-info-buffer arg)
+				  (alien-value stack))))))
+	    (t
+	     (setf (arg-info-passing-form arg) (arg-info-name arg))))
+
+      (unless (eq (arg-info-mode arg) :out)
+	(push (arg-info-name arg) lisp-args)
+	(when (arg-info-buffer arg)
+	  (push `(setf (alien-access (,(arg-info-buffer arg)
+				      (alien-value stack)))
+		       ,(arg-info-name arg))
+		arg-set-forms)))
+
+      (when (eq (arg-info-allocation arg) :stack)
+	(let* ((type (arg-info-type arg))
+	       (descr (c-type-description type))
+	       (size (c-type-size type)))
+	  (push `(defoperator (,(arg-info-accessor arg) ,descr)
+			      ((foo ,(routine-info-stack-record info)))
+		   `(alien-index (alien-value ,foo)
+				 ,,(arg-info-offset arg)
+				 ,,size))
+		top-level-forms))
+	(push `(setf (alien-access (,(arg-info-accessor arg)
+				    (alien-value stack)))
+		     ,(arg-info-passing-form arg))
+	      arg-set-forms))
+
+      (when (member (arg-info-mode arg) '(:out :in-out))
+	(push `(alien-access (,(arg-info-buffer arg) stack))
+	      result-get-forms)))
+	     
+    (values (nreverse top-level-forms)
+	    (nreverse lisp-args)
+	    (nreverse arg-set-forms)
+	    (nreverse result-get-forms))))
+	    
 
 (defmacro def-c-routine (name (return-type &key) &rest specs)
   "Def-C-Routine Name (Return-Type Option*)
@@ -508,8 +665,8 @@
         the interface function.
 
   :Copy
-        Similar to :In, except that the argument values are stored in a
-        preallocated object, and a pointer to the object is passed instead of
+        Similar to :In, except that the argument values are stored in on
+        the stack, and a pointer to the object is passed instead of
         the values themselves.
 
   :In-Out
@@ -550,8 +707,43 @@
     (unless (eq return-type 'void)
       (setf (routine-info-return-type info) (get-c-type return-type)))
 
+    (anotate-foreign-call info)
+    (pick-names info)
+
+    (multiple-value-bind
+	(top-level-forms lisp-args arg-set-forms result-get-forms)
+	(compute-c-call-forms info)
+      (let ((call-form `(call-foreign-function
+			 ,(routine-info-name info)
+			 ',info
+			 ,@(mapcar #'arg-info-passing-form
+				   (remove :stack (routine-info-args info)
+					   :key #'arg-info-allocation)))))
+	(when (routine-info-return-coerce-generator info)
+	  (setf call-form
+		(funcall (routine-info-return-coerce-generator info)
+			 call-form)))
+	`(progn
+	   ,@top-level-forms
+	   (defun ,(routine-info-function-name info) ,lisp-args
+	     (declare (optimize (speed 3) (safety 0)))
+	     (with-stack-alien (stack ,(routine-info-stack-record info)
+				      ,(routine-info-arg-size info))
+	       ,@arg-set-forms
+	       ,@(if (null (routine-info-return-type info))
+		     (if (null result-get-forms)
+			 `(,call-form
+			   (undefined-value))
+			 `(,call-form
+			   (values ,@result-get-forms)))
+		     (if (null result-get-forms)
+			 `(,call-form)
+			 `((values ,call-form
+				   ,@result-get-forms)))))))))))
+
+#|
+
     (let ((*output-forms* ()))
-      (link-routine-entry info)
       (allocate-arguments info)
       (multiple-value-bind (arg-names stores value-names values binds)
 			   (access-arguments info)
@@ -822,6 +1014,8 @@
     (t
      (error "Don't know how to hack ~S return type." type))))
 
+|#
+
 
 ;;; Make-Doc-String  --  Internal
 ;;;
@@ -839,24 +1033,8 @@
 		(cons 'return-value values)
 		values))))
 
-;;; Link-Routine-Entry  --  Internal
-;;;
-;;;    Emit stuff needed to look up a foreign routine and stash the code
-;;; pointer in a variable.
-;;;
-(proclaim '(function link-routine-entry (routine-info) void))
-(defun link-routine-entry (info)
-  (let ((name (symbolicate (routine-info-function-name info) "-code"))
-	(item (gensym)))
-    (push `(defparameter ,name (get-code-pointer ,(routine-info-name info)))
-	  *output-forms*)
-    (push `(let ((,item (cons ',name ',(routine-info-name info))))
-	     (when (not (member ,item foreign-routines-defined :test #'equal))
-	       (push ,item foreign-routines-defined)))
-	  *output-forms*)
-    (setf (routine-info-code info) name)))
-
 
+
 ;;; Def-C-Variable defines a global C-Variable, so that it is available to
 ;;; Lisp.  It accepts the name of the variable (as a string) and the type
 ;;; of the variable.
@@ -870,13 +1048,9 @@
 	 (c-type (if (primitive-type-p c-info)
 		     (c-type-description c-info)
 		     type))
-	 (c-size (c-type-size c-info))
-	 (item (gensym)))
-    `(let ((,item (cons ',symbol ',name)))
-       (when (not (member ,item foreign-variables-defined :test #'equal))
-	 (push ,item foreign-variables-defined))
-       (defalien ,symbol ,c-type ,c-size
-	 (lisp::sap-int (get-data-pointer ,name))))))
+	 (c-size (c-type-size c-info)))
+    `(defalien ,symbol ,c-type ,c-size
+       (%primitive c::foreign-symbol-address ',name))))
 
 #|
 ;;; Def-C-Procedure defines data structures etc. so that C can be passed