diff --git a/compiler/rt/c-call.lisp b/compiler/rt/c-call.lisp
index 7bd6edbe1901c5d51a50a06650e224dceefb0636..9d07ce891f59786c3f45db5dd60e99dccd15b4c9 100644
--- a/compiler/rt/c-call.lisp
+++ b/compiler/rt/c-call.lisp
@@ -7,7 +7,7 @@
 ;;; Lisp, please contact Scott Fahlman (Scott.Fahlman@CS.CMU.EDU)
 ;;; **********************************************************************
 ;;;
-;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/rt/c-call.lisp,v 1.3 1991/04/21 19:52:56 wlott Exp $
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/rt/c-call.lisp,v 1.4 1992/03/09 20:42:20 wlott Exp $
 ;;;
 ;;; This file contains the VOPs and other necessary machine specific support
 ;;; routines for call-out to C.
@@ -19,133 +19,163 @@
 (in-package "RT")
 
 
+
+;;;; Make-call-out-argument-tns and support stuff.
 
 (defun c-call-wired-tn (primitive-type sc-name offset)
   (make-wired-tn (primitive-type-or-lose primitive-type)
 		 (sc-number-or-lose sc-name)
 		 offset))
 
-(def-vm-support-routine make-call-out-nsp-tn ()
-  (c-call-wired-tn 'positive-fixnum 'word-pointer-reg nsp-offset))
-
-
-(def-vm-support-routine make-call-out-argument-tns (arg-types)
-  (let ((nargs 0))
-    (collect ((tns))
-      (dolist (type arg-types)
-	(multiple-value-bind
-	    (ptype reg-sc stack-sc)
-	    (ecase (if (consp type) (car type) type)
-	      ((unsigned-byte port)
-	       (values 'unsigned-byte-32 'unsigned-reg 'unsigned-stack))
-	      (signed-byte
-	       (values 'signed-byte-32 'signed-reg 'signed-stack))
-	      (system-area-pointer
-	       (values 'system-area-pointer 'sap-reg 'sap-stack)))
-	  ;; C expects 4 register args and the 5th arg at the top of the stack.
-	  ;; We can't put args in registers, because we need those registers
-	  ;; for something else.  So we put them just beyond the end of the
-	  ;; stack and the trampoline code will move them into place.
-	  (tns (c-call-wired-tn ptype stack-sc nargs))
-	  (incf nargs)))
-      (values (tns)
-	      (* nargs word-bytes)))))
-
-(def-vm-support-routine make-call-out-result-tn (type)
-  (let ((offset nl0-offset))
-    (labels
-	((frob (type)
-	   (let ((name (if (consp type) (car type) type)))
-	     (prog1
-		 (ecase name
-		   ((unsigned-byte port)
-		    (c-call-wired-tn 'unsigned-byte-32 'unsigned-reg offset))
-		   (signed-byte
-		    (c-call-wired-tn 'signed-byte-32 'signed-reg offset))
-		   (system-area-pointer
-		    (c-call-wired-tn 'system-area-pointer 'sap-reg offset))
-		   (values
-		    (when (consp type)
-		      (mapcar #'frob (cdr type)))))
-	       (incf offset)))))
-      (frob type))))
-
-(deftransform ext::call-foreign-function
-	      ((name return-type arg-types &rest args)
-	       (string * list &rest t))
-  (assert (c::constant-continuation-p name))
-  (assert (c::constant-continuation-p return-type))
-  (assert (c::constant-continuation-p arg-types))
-  (let ((name (c::continuation-value name))
-	(return-type (c::continuation-value return-type))
-	(arg-types (c::continuation-value arg-types)))
+
+(defstruct arg-state
+  (stack-frame-size 0))
+
+(defun int-arg (state prim-type stack-sc)
+  ;; C expects 4 register args and the 5th arg at the top of the stack.
+  ;; We can't put args in registers, because we need those registers
+  ;; for something else.  So we put them just beyond the end of the
+  ;; stack and the trampoline code will move them into place.
+  (let ((frame-size (arg-state-stack-frame-size state)))
+    (setf (arg-state-stack-frame-size state) (1+ frame-size))
+    (c-call-wired-tn prim-type stack-sc frame-size)))
+
+(defun int-result (state prim-type reg-sc)
+  (let ((reg-num (arg-state-stack-frame-size state)))
+    (setf (arg-state-stack-frame-size state) (1+ reg-num))
+    (c-call-wired-tn prim-type reg-sc reg-num)))
+
+(def-alien-type-method (integer :arg-tn) (type state)
+  (if (alien-integer-type-signed type)
+      (int-arg state 'signed-byte-32 'signed-stack)
+      (int-arg state 'unsigned-byte-32 'unsigned-stack)))
+
+(def-alien-type-method (integer :result-tn) (type state)
+  (if (alien-integer-type-signed type)
+      (int-result state 'signed-byte-32 'signed-reg)
+      (int-result state 'unsigned-byte-32 'unsigned-reg)))
+
+(def-alien-type-method (alien::sap :arg-tn) (type state)
+  (declare (ignore type))
+  (int-arg state 'system-area-pointer 'sap-stack))
+
+(def-alien-type-method (alien::sap :result-tn) (type state)
+  (declare (ignore type))
+  (int-result state 'system-area-pointer 'sap-reg))
+
+(def-alien-type-method (values :result-tn) (type state)
+  (mapcar #'(lambda (type)
+	      (invoke-alien-type-method :result-tn type state))
+	  (alien-values-type-values type)))
+
+(def-vm-support-routine make-call-out-argument-tns (type)
+  (declare (type alien-function-type type))
+  (let ((arg-state (make-arg-state)))
+    (collect ((arg-tns))
+      (dolist (arg-type (alien-function-type-arg-types type))
+	(arg-tns (invoke-alien-type-method :arg-tn arg-type arg-state)))
+      (values (c-call-wired-tn 'positive-fixnum 'word-pointer-reg nsp-offset)
+	      (* (arg-state-stack-frame-size arg-state) word-bytes)
+	      (arg-tns)
+	      (invoke-alien-type-method
+	       :result-tn
+	       (alien-function-type-result-type type)
+	       (make-arg-state :frame-size nl0-offset))))))
+
+
+;;;; Deftransforms to convert uses of %alien-funcall into cononical form.
+
+(deftransform %alien-funcall ((function type &rest args)
+			      (t * &rest t))
+  (assert (c::constant-continuation-p type))
+  (let* ((type (c::continuation-value type))
+	 (arg-types (alien-function-type-arg-types type))
+	 (result-type (alien-function-type-result-type type)))
     (assert (= (length arg-types) (length args)))
-    (if (member 'double-float arg-types)
-	(let ((new-args nil)
-	      (lambda-vars nil)
-	      (new-types nil))
+    (if (some #'alien::alien-double-float-type-p arg-types)
+	(collect ((new-args) (lambda-vars) (new-arg-types))
 	  (dolist (type arg-types)
 	    (let ((arg (gensym)))
-	      (push arg lambda-vars)
-	      (case type
-		(double-float
-		 (push `(double-float-high-bits ,arg) new-args)
-		 (push '(signed-byte 32) new-types)
-		 (push `(double-float-low-bits ,arg) new-args)
-		 (push '(unsigned-byte 32) new-types))
+	      (lambda-vars arg)
+	      (typecase type
+		(alien::alien-double-float-type
+		 (new-args `(double-float-high-bits ,arg))
+		 (new-args `(double-float-low-bits ,arg))
+		 (new-arg-types (parse-alien-type '(signed 32)))
+		 (new-arg-types (parse-alien-type '(unsigned 32))))
 		(t
-		 (push arg new-args)
-		 (push type new-types)))))
-	  `(lambda (name return-type arg-types ,@(nreverse lambda-vars))
-	     (declare (ignore name return-type arg-types))
-	     (ext::call-foreign-function ,name ',return-type
-					 ',(nreverse new-types)
-					 ,@(nreverse new-args))))
+		 (new-args arg)
+		 (new-arg-types type)))))
+	  `(lambda (function type ,@(lambda-vars))
+	     (declare (ignore type))
+	     (%alien-funcall function
+			     ',(alien::make-alien-function-type
+				:arg-types (new-arg-types)
+				:result-type result-type)
+			     ,@(new-args))))
 	(c::give-up))))
 
-(deftransform ext::call-foreign-function
-	      ((name return-type arg-types &rest args)
-	       (string t * &rest t))
-  (assert (c::constant-continuation-p name))
-  (assert (c::constant-continuation-p return-type))
-  (assert (c::constant-continuation-p arg-types))
-  (let ((name (c::continuation-value name))
-	(return-type (c::continuation-value return-type))
-	(arg-types (c::continuation-value arg-types))
-	(arg-names (mapcar #'(lambda (x) (declare (ignore x)) (gensym)) args)))
-    (case return-type
-      (double-float
-       `(lambda (name return-type arg-types ,@arg-names)
-	  (declare (ignore name return-type arg-types))
-	  (multiple-value-bind
-	      (hi lo)
-	      (ext::call-foreign-function ,name
-					  '(values signed-byte unsigned-byte)
-					  ',arg-types
-					  ,@arg-names)
-	    (make-double-float hi lo))))
-      (single-float
-       `(lambda (name return-type arg-types ,@arg-names)
-	  (make-single-float
-	   (ext::call-foreign-function ,name 'signed-byte ',arg-types
-				       ,@arg-names))))
-      (t
-       (c::give-up)))))
+(deftransform %alien-funcall ((function type &rest args)
+			      (* t &rest t))
+  (assert (c::constant-continuation-p type))
+  (let* ((type (c::continuation-value type))
+	 (arg-types (alien-function-type-arg-types type))
+	 (result-type (alien-function-type-result-type type)))
+    (assert (= (length arg-types) (length args)))
+    (flet ((make-arg-name-list ()
+	     (mapcar #'(lambda (x) (declare (ignore x)) (gensym))
+		     arg-types)))
+      (typecase result-type
+	(alien::alien-double-float-type
+	 (let ((arg-names (make-arg-name-list)))
+	   `(lambda (function type ,@arg-names)
+	      (declare (ignore type))
+	      (multiple-value-bind
+		  (hi lo)
+		  (%alien-funcall function
+				  ',(parse-alien-type
+				     `(function (values (signed 32)
+							(unsigned 32))
+						,@arg-types))
+				  ,@arg-names)
+	      (make-double-float hi lo)))))
+	(alien::alien-single-float-type
+	 (let ((arg-names (make-arg-name-list)))
+	   `(lambda (function type ,@arg-names)
+	      (declare (ignore type))
+	      (make-single-float
+	       (%alien-function function
+				',(parse-alien-type
+				   `(function (signed 32) ,@arg-types))
+				,@arg-names)))))
+	(t
+	 (c::give-up))))))
+
+
+;;;; Vops.
+
 
 (define-vop (foreign-symbol-address)
+  (:translate foreign-symbol-address)
+  (:policy :fast-safe)
+  (:args)
+  (:arg-types (:constant simple-string))
   (:info foreign-symbol)
   (:results (res :scs (sap-reg)))
+  (:result-types system-area-pointer)
   (:generator 2
     (inst cai res (make-fixup (concatenate 'simple-string "_" foreign-symbol)
 			      :foreign))))
 
 (define-vop (call-out)
-  (:args (args :more t))
+  (:args (function :scs (sap-reg) :target nl0)
+	 (args :more t))
   (:results (results :more t))
   (:ignore args results)
   (:save-p t)
   (:info function)
-  (:temporary (:sc any-reg :offset nl0-offset :to (:result 0)) nl0)
+  (:temporary (:sc any-reg :offset nl0-offset
+		   :from (:argument 0) :to (:result 0)) nl0)
   (:temporary (:sc any-reg :offset lra-offset) lra)
   (:temporary (:sc any-reg :offset code-offset) code)
   (:temporary (:scs (sap-reg) :to (:result 0)) temp)
@@ -154,11 +184,10 @@
   (:generator 0
     (let ((lra-label (gen-label))
 	  (cur-nfp (current-nfp-tn vop)))
+      (move nl0 function)
       (when cur-nfp
 	(store-stack-tn cur-nfp nfp-save))
       (inst compute-lra-from-code lra code lra-label)
-      (inst cai nl0
-	    (make-fixup (concatenate 'simple-string "_" function) :foreign))
       (inst cai temp (make-fixup "call_into_c" :foreign))
       (inst b temp)