diff --git a/code/alieneval.lisp b/code/alieneval.lisp
index 08cf6ec56ec9d531886ea8bde24b3c897cf62c45..f658f93902e13cc840ace8219dea6f3b7749f2ae 100644
--- a/code/alieneval.lisp
+++ b/code/alieneval.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/alieneval.lisp,v 1.53 2003/01/23 21:05:33 toy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/alieneval.lisp,v 1.54 2003/05/14 13:22:16 toy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -21,7 +21,8 @@
 	  system-area-pointer def-alien-type def-alien-variable sap-alien
 	  extern-alien with-alien slot deref addr cast alien-sap alien-size
 	  alien-funcall def-alien-routine make-alien free-alien
-	  null-alien))
+	  null-alien
+	  def-callback callback))
 
 (in-package "ALIEN-INTERNALS")
 (in-package "ALIEN")
@@ -2034,3 +2035,320 @@
 		       (values ,@temps ,@(results))))
 		  `(values (alien-funcall ,lisp-name ,@(alien-args))
 			   ,@(results))))))))
+
+;;;; Alien callback support
+;;;;
+;;;; This is basically the implementation posted by Helmut Eller,
+;;;; posted to cmucl-imp on 04/13/2003.  It has been modified to live
+;;;; in the ALIEN package and to fit the same style as the ALIEN
+;;;; package.
+
+;;; This package provides a mechanism for defining callbacks: lisp
+;;; functions which can be called from foreign code.  The user
+;;; interface consists of the macros DEFCALLBACK and CALLBACK.  (See
+;;; the doc-strings for details.)
+;;;
+;;; Below are two examples.  The first example defines a callback FOO
+;;; and calls it with alien-funcall.  The second illustrates the use
+;;; of the libc qsort function.
+;;;
+;;; The implementation generates a piece machine code -- a
+;;; "trampoline" -- for each callback function.  A pointer to this
+;;; trampoline can then be passed to foreign code.  The trampoline is
+;;; allocated with malloc and is not moved by the GC.
+;;;
+;;; When called, the trampoline passes a pointer to the arguments
+;;; (essentially the stack pointer) together with an index to
+;;; CALL-CALLACK.  CALL-CALLBACK uses the index to find the
+;;; corresponding lisp function and calls this function with the
+;;; argument pointer.  The lisp function uses the pointer to copy the
+;;; arguments form the stack to local variables.  On return, the lisp
+;;; function stores the result into the location given by the argument
+;;; pointer, and the trampoline code copies the return value from
+;;; there into the right return register.
+;;;
+;;; The address of CALL-CALLBACK is used in every trampoline and must
+;;; not be moved by the gc.  It is therefore necessary to either
+;;; include this package into the image (core) or to purify before
+;;; creating any trampolines (or to invent some other trick).
+;;;
+;;; Examples: 
+
+#|
+;;; Example 1:
+
+(defcallback foo (int (arg1 int) (arg2 int))
+  (format t "~&foo: ~S, ~S~%" arg1 arg2)
+  (+ arg1 arg2))
+
+(alien-funcall (sap-alien (callback foo) (function int int int))
+	       555 444444)
+
+;;; Example 2:
+
+(def-alien-routine qsort void
+  (base (* t))
+  (nmemb int)
+  (size int)
+  (compar (* (function int (* t) (* t)))))
+
+(defcallback my< (int (arg1 (* double))
+		      (arg2 (* double)))
+  (let ((a1 (deref arg1))
+	(a2 (deref arg2)))
+    (cond ((= a1 a2)  0)
+	  ((< a1 a2) -1)
+	  (t         +1))))
+
+(let ((a (make-array 10 :element-type 'double-float
+		     :initial-contents '(0.1d0 0.5d0 0.2d0 1.2d0 1.5d0
+					 2.5d0 0.0d0 0.1d0 0.2d0 0.3d0))))
+  (print a)
+  (qsort (sys:vector-sap a)
+	 (length a)
+	 (alien-size double :bytes)
+	 (callback my<))
+  (print a))
+
+|#
+
+(defstruct (callback 
+	     (:constructor make-callback (trampoline lisp-fn return-type)))
+  "A callback consists of a piece assembly code -- the trampoline --
+and a lisp function.  We store the return-type, so we can detect
+incompatible redefinitions."
+  (trampoline (required-argument) :type system-area-pointer)
+  (lisp-fn (required-argument) :type (function (fixnum) (values)))
+  (return-type (required-argument) :type alien::alien-type))
+
+(declaim (type (vector callback) *callbacks*))
+(defvar *callbacks* (make-array 10 :element-type 'callback
+				:fill-pointer 0 :adjustable t)
+  "Vector of all callbacks.")
+
+(defun call-callback (index sp-fixnum ret-addr)
+  (declare (type fixnum index sp-fixnum ret-addr)
+	   (optimize speed))
+  (funcall (callback-lisp-fn (aref *callbacks* index))
+	   sp-fixnum ret-addr))
+
+(defun create-callback (lisp-fn return-type)
+  (let* ((index (fill-pointer *callbacks*))
+	 (tramp (vm:make-callback-trampoline index return-type))
+	 (cb (make-callback tramp lisp-fn return-type)))
+    (vector-push-extend cb *callbacks*)
+    cb))
+
+#+nil
+(defun address-of-call-into-lisp ()
+  (sys:sap-int (alien-sap (extern-alien "call_into_lisp" (function (* t))))))
+
+(defun address-of-call-callback ()
+  (kernel:get-lisp-obj-address #'call-callback))
+
+(defun address-of-funcall3 ()
+  (sys:sap-int (alien-sap (extern-alien "funcall3" (function (* t))))))
+
+;;; Some abbreviations for alien-type classes.  The $ suffix is there
+;;; to prevent name clashes.
+
+(deftype void$ () '(satisfies alien-void-type-p))
+(deftype integer$ () 'alien::alien-integer-type)
+(deftype integer-64$ () '(satisfies alien-integer-64-type-p))
+(deftype signed-integer$ () '(satisfies alien-signed-integer-type-p))
+(deftype pointer$ () 'alien::alien-pointer-type)
+(deftype single$ () 'alien::alien-single-float-type)
+(deftype double$ () 'alien::alien-double-float-type)
+(deftype sap$ () '(satisfies alien-sap-type=))
+
+(defun alien-sap-type= (type)
+  (alien::alien-type-= type 
+		       (alien::parse-alien-type 'system-area-pointer)))
+
+(defun alien-void-type-p (type)
+  (and (alien::alien-values-type-p type)
+       (null (alien::alien-values-type-values type))))
+
+(defun alien-integer-64-type-p (type)
+  (and (alien::alien-integer-type-p type)
+       (= (alien::alien-type-bits type) 64)))
+
+(defun alien-signed-integer-type-p (type)
+  (and (alien::alien-integer-type-p type)
+       (alien::alien-integer-type-signed type)))
+
+(defun segment-to-trampoline (segment length)
+  (let* ((code (alien-funcall 
+		(extern-alien "malloc" (function system-area-pointer unsigned))
+		length))
+	 (fill-pointer code))
+    (new-assem:segment-map-output segment
+				  (lambda (sap length)
+				    (kernel:system-area-copy sap 0 fill-pointer 0
+							     (* length vm:byte-bits))
+				    (setf fill-pointer (sys:sap+ fill-pointer length))))
+    code))
+
+(defun symbol-trampoline (symbol)
+  (callback-trampoline (symbol-value symbol)))
+
+(defmacro callback (name)
+  "Return the trampoline pointer for the callback NAME."
+  `(symbol-trampoline ',name))
+
+(defun compatible-return-types-p (type1 type2)
+  (flet ((machine-rep (type)
+	   (etypecase type
+	     (integer-64$ :dword)
+	     ((or integer$ pointer$ sap$) :word)
+	     (single$ :single)
+	     (double$ :double)
+	     (void$ :void))))
+    (eq (machine-rep type1) (machine-rep type2))))
+	       
+(defun define-callback-function (name lisp-fn return-type)
+  (declare (type symbol name)
+	   (type function lisp-fn))
+  (flet ((register-new-callback () 
+	   (setf (symbol-value name)
+		 (create-callback lisp-fn return-type))))
+    (if (and (boundp name)
+	     (callback-p (symbol-value name)))
+	;; try do redefine the existing callback
+	(let ((callback (find (symbol-trampoline name) *callbacks*
+			      :key #'callback-trampoline :test #'sys:sap=)))
+	  (cond (callback
+		 (let ((old-type (callback-return-type callback)))
+		   (cond ((compatible-return-types-p old-type return-type)
+			  ;; (format t "~&; Redefining callback ~A~%" name)
+			  (setf (callback-lisp-fn callback) lisp-fn)
+			  (setf (callback-return-type callback) return-type)
+			  callback)
+			 (t
+			  (let ((e (format nil "~
+Attempt to redefine callback with incompatible return type.
+   Old type was: ~A 
+    New type is: ~A" old-type return-type))
+				(c (format nil "~
+Create new trampoline (old trampoline calls old lisp function).")))
+			    (cerror c e)
+			    (register-new-callback))))))
+		(t (register-new-callback))))
+	(register-new-callback))))
+
+(defun word-aligned-bits (type)
+  (alien::align-offset (alien::alien-type-bits type) vm:word-bits))
+
+(defun argument-size (spec)
+  (let ((type (alien::parse-alien-type spec)))
+    (typecase type
+      ((or integer$ single$ double$ pointer$ sap$)
+       (ceiling (word-aligned-bits type) vm:byte-bits))
+      (t (error "Unsupported argument type: ~A" spec)))))
+
+(defun parse-return-type (spec)
+  (let ((alien::*values-type-okay* t))
+    (alien::parse-alien-type spec)))
+
+(defun return-exp (spec sap body)
+  (flet ((store (spec) `(setf (deref (sap-alien ,sap (* ,spec))) ,body)))
+    (let ((type (parse-return-type spec)))
+      (typecase type
+	(void$ body)
+	(signed-integer$ 
+	 (store `(signed ,(word-aligned-bits type))))
+	(integer$
+	 (store `(unsigned ,(word-aligned-bits type))))
+	((or single$ double$ pointer$ sap$)
+	 (store spec))
+	(t (error "Unsupported return type: ~A" spec))))))
+
+#+nil
+(defmacro def-callback (name (return-type &rest arg-specs) &body body)
+  "(defcallback NAME (RETURN-TYPE {(ARG-NAME ARG-TYPE)}*) {FORM}*)
+
+Define a function which can be called by foreign code.  The pointer
+returned by (callback NAME), when called by foreign code, invokes the
+lisp function.  The lisp function expects alien arguments of the
+specified ARG-TYPEs and returns an alien of type RETURN-TYPE.
+
+If (callback NAME) is already a callback function pointer, its value
+is not changed (though it's arranged that an updated version of the
+lisp callback function will be called).  This feature allows for
+incremental redefinition of callback functions."
+  (let ((sp-fixnum (gensym (string :sp-fixnum)))
+	(ret-addr (gensym (string :ret-addr)))
+	(sp (gensym (string :sp))))
+    `(progn
+      (defun ,name (,sp-fixnum ,ret-addr)
+	(declare (type fixnum ,sp-fixnum)
+		 (type fixnum ,ret-addr))
+	;; We assume sp-fixnum is word aligned and pass it untagged to
+	;; this function.  The shift compensates this.
+	(let ((,sp (sys:int-sap (ldb (byte vm:word-bits 0) (ash ,sp-fixnum 2)))))
+	  (declare (ignorable ,sp))
+	  ;; Copy all arguments to local variables.
+	  (with-alien ,(loop for offset = 0 then (+ offset 
+						    (argument-size type))
+			     for (name type) in arg-specs
+			     collect `(,name ,type
+				       :local (deref (sap-alien 
+						      (sys:sap+ ,sp ,offset)
+						      (* ,type)))))
+	    ,(return-exp return-type `(sys:sap+ ,ret-addr 0) `(progn ,@body))
+	    (values))))
+      (define-callback-function 
+	  ',name #',name ',(parse-return-type return-type)))))
+
+(defmacro def-callback (name (return-type &rest arg-specs) &body body)
+  "(defcallback NAME (RETURN-TYPE {(ARG-NAME ARG-TYPE)}*) {FORM}*)
+
+Define a function which can be called by foreign code.  The pointer
+returned by (callback NAME), when called by foreign code, invokes the
+lisp function.  The lisp function expects alien arguments of the
+specified ARG-TYPEs and returns an alien of type RETURN-TYPE.
+
+If (callback NAME) is already a callback function pointer, its value
+is not changed (though it's arranged that an updated version of the
+lisp callback function will be called).  This feature allows for
+incremental redefinition of callback functions."
+  (let ((sp-fixnum (gensym (string :sp-fixnum-)))
+	(ret-addr (gensym (string :ret-addr-)))
+	(sp (gensym (string :sp-)))
+	(ret (gensym (string :ret-))))
+    `(progn
+      (defun ,name (,sp-fixnum ,ret-addr)
+	(declare (type fixnum ,sp-fixnum ,ret-addr))
+	;; We assume sp-fixnum is word aligned and pass it untagged to
+	;; this function.  The shift compensates this.
+	(let ((,sp (sys:int-sap (ldb (byte vm:word-bits 0) (ash ,sp-fixnum 2))))
+	      (,ret (sys:int-sap (ldb (byte vm:word-bits 0) (ash ,ret-addr 2)))))
+	  (declare (ignorable ,sp))
+	  ;; Copy all arguments to local variables.
+	  (with-alien ,(loop for offset = 0 then (+ offset 
+						    (alien::argument-size type))
+			     for (name type) in arg-specs
+			     collect `(,name ,type
+				       :local ,(vm:callback-accessor-form type sp offset)))
+	    ,(alien::return-exp return-type `(sys:sap+ ,ret 0) `(progn ,@body))
+	    (values))))
+      (alien::define-callback-function 
+	  ',name #',name ',(alien::parse-return-type return-type)))))
+
+;;; dumping support
+
+(defun restore-callbacks ()
+  ;; Create new trampolines on reload.
+  (loop for cb across *callbacks*
+	for i from 0
+	do (setf (callback-trampoline cb)
+		 (vm:make-callback-trampoline i (callback-return-type cb)))))
+
+;; *after-save-initializations* contains
+;; new-assem::forget-output-blocks, and the assembler may not work
+;; before forget-output-blocks was called.  We add 'restore-callback at
+;; the end of *after-save-initializations* to sidestep this problem.
+(setf *after-save-initializations*
+      (append *after-save-initializations* (list 'restore-callbacks)))
+
+;;; callback.lisp ends here
diff --git a/code/exports.lisp b/code/exports.lisp
index abc5f9f45c7d7feb64a0c9ca4addf3b070ac4541..c1dca5c9035e2bcc08393c905531657847e584ae 100644
--- a/code/exports.lisp
+++ b/code/exports.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/exports.lisp,v 1.208 2003/05/13 15:22:49 emarsden Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/exports.lisp,v 1.209 2003/05/14 13:22:16 toy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -819,6 +819,8 @@
 	   #+sparc "FIXNUM-TAG-BITS"
 	   #+sparc "FIXNUM-TAG-MASK"
 	   #+sparc "PSEUDO-ATOMIC-TRAP"
+	   #+sparc "GET-FP-OPERANDS"
+	   "CALLBACK-ACCESSOR-FORM" "MAKE-CALLBACK-TRAMPOLINE"
 	   ))
 
 (defpackage "CONDITIONS")
@@ -1270,26 +1272,26 @@
 	   "NOTE-NEXT-INSTRUCTION"
 	   "SET-SLOT"
 	   "LOCATION-NUMBER"
-"BYTE-FASL-FILE-VERSION"
-"*COMPILE-COMPONENT*"
-"BLOCK-NUMBER"
-"DYNCOUNT-INFO-COUNTS"
-"BACKEND-BYTE-FASL-FILE-IMPLEMENTATION"
-"IR2-BLOCK-BLOCK"
-"DISASSEM-BYTE-COMPONENT"
-"LITTLE-ENDIAN-FASL-FILE-IMPLEMENTATION"
-"DYNCOUNT-INFO-COSTS"
-"FUNCALLABLE-INSTANCE-LEXENV"
-"DISASSEM-BYTE-FUN"
-"VOP-BLOCK"
-"BACKEND-BYTE-FASL-FILE-TYPE"
-"BIG-ENDIAN-FASL-FILE-IMPLEMENTATION"
-"*ASSEMBLY-OPTIMIZE*"
-"LARGE-ALLOC"
-"%SET-FUNCTION-SELF"
-"IR2-COMPONENT-DYNCOUNT-INFO"
-"DYNCOUNT-INFO" "DYNCOUNT-INFO-P")
-)
+	   "BYTE-FASL-FILE-VERSION"
+	   "*COMPILE-COMPONENT*"
+	   "BLOCK-NUMBER"
+	   "DYNCOUNT-INFO-COUNTS"
+	   "BACKEND-BYTE-FASL-FILE-IMPLEMENTATION"
+	   "IR2-BLOCK-BLOCK"
+	   "DISASSEM-BYTE-COMPONENT"
+	   "LITTLE-ENDIAN-FASL-FILE-IMPLEMENTATION"
+	   "DYNCOUNT-INFO-COSTS"
+	   "FUNCALLABLE-INSTANCE-LEXENV"
+	   "DISASSEM-BYTE-FUN"
+	   "VOP-BLOCK"
+	   "BACKEND-BYTE-FASL-FILE-TYPE"
+	   "BIG-ENDIAN-FASL-FILE-IMPLEMENTATION"
+	   "*ASSEMBLY-OPTIMIZE*"
+	   "LARGE-ALLOC"
+	   "%SET-FUNCTION-SELF"
+	   "IR2-COMPONENT-DYNCOUNT-INFO"
+	   "DYNCOUNT-INFO" "DYNCOUNT-INFO-P")
+  )
 (defpackage "XREF"
   (:export "INIT-XREF-DATABASE"
            "REGISTER-XREF"
@@ -1377,13 +1379,15 @@
 (defpackage "ALIEN"
             (:import-from "LISP" "*" "ARRAY" "DOUBLE-FLOAT" "FUNCTION"
              "BOOLEAN" "INTEGER" "LONG-FLOAT" "SINGLE-FLOAT" "UNION" "VALUES")
+	    (:import-from "VM" "CALLBACK-ACCESSOR-FORM" "MAKE-CALLBACK-TRAMPOLINE")
             (:export "*" "ADDR" "ALIEN" "ALIEN-FUNCALL" "ALIEN-SAP"
              "ALIEN-SIZE" "ARRAY" "BOOLEAN" "CAST" "DEF-ALIEN-ROUTINE"
              "DEF-ALIEN-TYPE" "DEF-ALIEN-VARIABLE" "DEF-BUILTIN-ALIEN-TYPE"
              "DEREF" "DOUBLE-FLOAT" "ENUM" "EXTERN-ALIEN" "FUNCTION" "INTEGER"
              "LONG-FLOAT" "SAP-ALIEN" "SIGNED" "SINGLE-FLOAT" "SLOT" "STRUCT"
 	     "UNION" "UNSIGNED" "VALUES" "WITH-ALIEN" "FREE-ALIEN" "NULL-ALIEN"
-	     "MAKE-ALIEN" "LOAD-FOREIGN" "SYSTEM-AREA-POINTER"))
+	     "MAKE-ALIEN" "LOAD-FOREIGN" "SYSTEM-AREA-POINTER"
+	     "DEF-CALLBACK" "CALLBACK"))
 
 (dolist
     (name
diff --git a/compiler/sparc/c-call.lisp b/compiler/sparc/c-call.lisp
index 90c30d6859f7572aaf795e029d30ec8f37d39810..2188ce47078402a2805c25944ce5782e3b5aa950 100644
--- a/compiler/sparc/c-call.lisp
+++ b/compiler/sparc/c-call.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/c-call.lisp,v 1.16 2002/10/24 20:38:58 toy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/c-call.lisp,v 1.17 2003/05/14 13:22:17 toy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -284,3 +284,213 @@
 	      (t
 	       (inst li temp delta)
 	       (inst add nsp-tn temp)))))))
+
+;;; Support for callbacks to Lisp.
+(export '(make-callback-trampoline callback-accessor-form))
+
+#+nil
+(defun compute-accessor (type sp offset)
+  (cond ((eq type 'double)
+	 ;; Due to sparc calling conventions, a double doesn't have to
+	 ;; be aligned on a double word boundary.  We have to get the
+	 ;; two words separately and create the double from them.
+	 `(kernel:make-double-float (alien:deref (sap-alien (sys:sap+ ,sp ,offset) (* int)))
+	                            (alien:deref (sap-alien (sys:sap+ ,sp (+ ,offset 4))
+						  (* c-call:unsigned-int)))))
+	(t
+	 `(deref (sap-alien (sys:sap+ ,sp ,offset) (* ,type))))))
+
+(defun callback-accessor-form (type sp offset)
+  (cond ((eq type 'double)
+	 ;; Due to sparc calling conventions, a double doesn't have to
+	 ;; be aligned on a double word boundary.  We have to get the
+	 ;; two words separately and create the double from them.
+	 `(kernel:make-double-float (alien:deref (sap-alien (sys:sap+ ,sp ,offset) (* int)))
+	                            (alien:deref (sap-alien (sys:sap+ ,sp (+ ,offset 4))
+						  (* c-call:unsigned-int)))))
+	(t
+	 `(deref (sap-alien (sys:sap+ ,sp ,offset) (* ,type))))))
+
+#+nil
+(defmacro def-callback (name (return-type &rest arg-specs) &body body)
+  "(defcallback NAME (RETURN-TYPE {(ARG-NAME ARG-TYPE)}*) {FORM}*)
+
+Define a function which can be called by foreign code.  The pointer
+returned by (callback NAME), when called by foreign code, invokes the
+lisp function.  The lisp function expects alien arguments of the
+specified ARG-TYPEs and returns an alien of type RETURN-TYPE.
+
+If (callback NAME) is already a callback function pointer, its value
+is not changed (though it's arranged that an updated version of the
+lisp callback function will be called).  This feature allows for
+incremental redefinition of callback functions."
+  (let ((sp-fixnum (gensym (string :sp-fixnum-)))
+	(ret-addr (gensym (string :ret-addr-)))
+	(sp (gensym (string :sp-)))
+	(ret (gensym (string :ret-))))
+    `(progn
+      (defun ,name (,sp-fixnum ,ret-addr)
+	(declare (type fixnum ,sp-fixnum ,ret-addr))
+	;; We assume sp-fixnum is word aligned and pass it untagged to
+	;; this function.  The shift compensates this.
+	(let ((,sp (sys:int-sap (ldb (byte vm:word-bits 0) (ash ,sp-fixnum 2))))
+	      (,ret (sys:int-sap (ldb (byte vm:word-bits 0) (ash ,ret-addr 2)))))
+	  (declare (ignorable ,sp))
+	  ;; Copy all arguments to local variables.
+	  (with-alien ,(loop for offset = 0 then (+ offset 
+						    (alien::argument-size type))
+			     for (name type) in arg-specs
+			     collect `(,name ,type
+				       :local ,(compute-accessor type sp offset)))
+	    ,(alien::return-exp return-type `(sys:sap+ ,ret 0) `(progn ,@body))
+	    (values))))
+      (alien::define-callback-function 
+	  ',name #',name ',(alien::parse-return-type return-type)))))
+
+(defun make-callback-trampoline (index return-type)
+  "Cons up a piece of code which calls call-callback with INDEX and a
+pointer to the arguments."
+  (flet ((def-reg-tn (offset)
+	     (c:make-random-tn :kind :normal
+			     :sc (c:sc-or-lose 'vm::unsigned-reg)
+			     :offset offset)))
+    (let* ((segment (make-segment))
+	   ;; Window save area (16 registers)
+	   (window-save-size (* 16 vm:word-bytes))
+	   ;; Structure return pointer area (1 register)
+	   (struct-return-size vm:word-bytes)
+	   ;; Register save area (6 registers)
+	   (reg-save-area-size (* 6 vm:word-bytes))
+	   ;; Local var.  Should be large enough to hold a double-float or long
+	   (return-value-size (* 2 vm:word-bytes))
+	   ;; Frame size: the register window, the arg save area, the
+	   ;; structure return area, and return-value-area, all
+	   ;; rounded to a multiple of eight.
+	   (framesize (* 8 (ceiling (+ window-save-size struct-return-size reg-save-area-size
+				       return-value-size)
+				    8)))
+	   ;; Offset from FP where the first arg is located.
+	   (arg0-save-offset (+ window-save-size struct-return-size))
+	   ;; Establish the registers we need
+	   (%g0 (def-reg-tn vm::zero-offset))
+	   (%o0 (def-reg-tn vm::nl0-offset))
+	   (%o1 (def-reg-tn vm::nl1-offset))
+	   (%o2 (def-reg-tn vm::nl2-offset))
+	   (%o3 (def-reg-tn vm::nl3-offset))
+	   (%o7 (def-reg-tn vm::nargs-offset))
+	   (%sp (def-reg-tn vm::nsp-offset)) ; aka %o6
+	   (%l0 (def-reg-tn vm::a0-offset))
+	   (%i0 (def-reg-tn vm::cname-offset))
+	   (%i1 (def-reg-tn vm::lexenv-offset))
+	   (%i2 (def-reg-tn vm::l0-offset))
+	   (%i3 (def-reg-tn vm::nfp-offset))
+	   (%i4 (def-reg-tn vm::cfunc-offset))
+	   (%i5 (def-reg-tn vm::code-offset))
+	   (%fp (def-reg-tn 30 #+nil vm::fp-offset))
+	   (%i7 (def-reg-tn vm::lip-offset))
+	   (f0-s (c:make-random-tn :kind :normal
+				   :sc (c:sc-or-lose 'vm::single-reg)
+				   :offset 0))
+	   (f0-d (c:make-random-tn :kind :normal
+				   :sc (c:sc-or-lose 'vm::double-reg)
+				   :offset 0))
+	   )
+      ;; The generated assembly roughly corresponds to this C code:
+      ;;
+      ;;        tramp(int a0, int a1, int a2, int a3, int a4, int a5, ...)
+      ;;	{
+      ;;	  double result;
+      ;;	  funcall3(call-callback, <index>, &a0, &result);
+      ;;	  return <cast> result;
+      ;;	}
+      ;;
+      ;; Except, of course, the result is the appropriate result type
+      ;; for the trampoline.
+      ;;	       
+      (assemble (segment)
+		;; Save old %fp, etc. establish our call frame with local vars
+		;; %i contains the input args
+		(inst save %sp %sp (- framesize))
+		;; The stack frame now looks like
+		;;
+		;; TOP (high memory)
+		;;
+		;; argn
+		;; ...
+		;; arg6
+		;; arg5
+		;; arg4
+		;; arg3
+		;; arg2
+		;; arg1
+		;; arg0
+		;; struct_return
+		;; window-save-area	<- %fp + 64
+		;;			<- %fp
+		;; local-vars-extra-args	(8-bytes)
+		;; arg5-save
+		;; arg4-save
+		;; arg3-save
+		;; arg2-save
+		;; arg1-save
+		;; arg0-save
+		;; struct_return		
+		;; window-save-area
+		;;			<- %sp
+
+		;; Save all %i arg register values on the stack.  (We
+		;; might not always need to save all, but this is safe
+		;; and easy.)
+		(inst st %i0 %fp (+ arg0-save-offset (* 0 vm:word-bytes)))
+		(inst st %i1 %fp (+ arg0-save-offset (* 1 vm:word-bytes)))
+		(inst st %i2 %fp (+ arg0-save-offset (* 2 vm:word-bytes)))
+		(inst st %i3 %fp (+ arg0-save-offset (* 3 vm:word-bytes)))
+		(inst st %i4 %fp (+ arg0-save-offset (* 4 vm:word-bytes)))
+		(inst st %i5 %fp (+ arg0-save-offset (* 5 vm:word-bytes)))
+
+		;; Set up our args to call funcall3
+		;;
+		;; %o0 = address of call-callback
+		;; %o1 = index
+		;; %o2 = pointer to the arguments of the caller (address
+		;;       of arg0 above)
+		;; %o3 = pointer to return area
+
+		(inst li %o0 (alien::address-of-call-callback))
+		(inst li %o1 (ash index vm:fixnum-tag-bits))
+		(inst add %o2 %fp arg0-save-offset)
+		(inst add %o3 %fp (- return-value-size))
+
+		;; And away we go to funcall3!
+		(let ((addr (alien::address-of-funcall3)))
+		  (inst sethi %l0 (ldb (byte 22 10) addr))
+		  (inst jal %o7 %l0 (ldb (byte 10 0) addr))
+		;;(inst li %l0 (address-of-funcall3))
+		;;(inst jal %o7 %l0)
+		(inst nop)
+		)
+
+		;; Ok, we're back.  The value returned is actually stored in the args
+		(etypecase return-type
+		  (alien::integer-64$
+		   ;; A 64-bit bignum.
+		   )
+		  ((or alien::integer$ alien::pointer$ alien::sap$)
+		   (inst ld %i0 %fp (- return-value-size)))
+		  (alien::single$
+		   ;; Get the FP value into F0
+		   (inst ldf f0-s %fp (- return-value-size))
+		   )
+		  (alien::double$
+		   (inst lddf f0-d %fp (- return-value-size)))
+		  (alien::void$
+		   ))
+
+		(inst jal %g0 %i7 8)
+		(inst restore %g0 %g0 %g0)
+		)
+      (let ((length (finalize-segment segment)))
+	(prog1 (alien::segment-to-trampoline segment length)
+	  (release-segment segment))))))
+
+
diff --git a/compiler/x86/c-call.lisp b/compiler/x86/c-call.lisp
index 1183fbdba4dd7e5bb66b581a1215dfefe58f97f7..1783b423df75206c3d588fc09a1e350216f53668 100644
--- a/compiler/x86/c-call.lisp
+++ b/compiler/x86/c-call.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
- "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/c-call.lisp,v 1.12 2002/08/27 22:18:28 moore Exp $")
+ "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/c-call.lisp,v 1.13 2003/05/14 13:22:17 toy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -299,3 +299,94 @@
 				    (ash symbol-value-slot word-shift)
 				    (- other-pointer-type)))
 	      delta)))))
+
+;;; Support for callbacks to Lisp.
+(export '(make-callback-trampoline callback-accessor-form))
+
+(defun callback-accessor-form (type sp offset)
+  `(alien:deref (sap-alien 
+		 (sys:sap+ ,sp ,offset)
+		 (* ,type))))
+
+#+nil
+(defmacro def-callback (name (return-type &rest arg-specs) &body body)
+  "(defcallback NAME (RETURN-TYPE {(ARG-NAME ARG-TYPE)}*) {FORM}*)
+
+Define a function which can be called by foreign code.  The pointer
+returned by (callback NAME), when called by foreign code, invokes the
+lisp function.  The lisp function expects alien arguments of the
+specified ARG-TYPEs and returns an alien of type RETURN-TYPE.
+
+If (callback NAME) is already a callback function pointer, its value
+is not changed (though it's arranged that an updated version of the
+lisp callback function will be called).  This feature allows for
+incremental redefinition of callback functions."
+  (let ((sp-fixnum (gensym (string :sp-fixnum-)))
+	(ret-addr (gensym (string :ret-addr-)))
+	(sp (gensym (string :sp-)))
+	(ret (gensym (string :ret-))))
+    `(progn
+      (defun ,name (,sp-fixnum ,ret-addr)
+	(declare (type fixnum ,sp-fixnum)
+		 (type fixnum ,ret-addr))
+	;; We assume sp-fixnum is word aligned and pass it untagged to
+	;; this function.  The shift compensates this.
+	(let ((,sp (sys:int-sap (ldb (byte vm:word-bits 0) (ash ,sp-fixnum 2))))
+	      (,ret (sys:int-sap (ldb (byte vm:word-bits 0) (ash ,ret-addr 2)))))
+	  (declare (ignorable ,sp))
+	  ;; Copy all arguments to local variables.
+	  (with-alien ,(loop for offset = 0 then (+ offset 
+						    (alien::argument-size type))
+			     for (name type) in arg-specs
+			     collect `(,name ,type
+				       :local (alien:deref (sap-alien 
+							    (sys:sap+ ,sp ,offset)
+							    (* ,type)))))
+	    ,(alien::return-exp return-type `(sys:sap+ ,ret 0) `(progn ,@body))
+	    (values))))
+      (alien::define-callback-function 
+	  ',name #',name ',(alien::parse-return-type return-type)))))
+
+
+(defun make-callback-trampoline (index return-type)
+  "Cons up a piece of code which calls call-callback with INDEX and a
+pointer to the arguments."
+  (let* ((segment (make-segment))
+	 (eax x86::eax-tn)
+	 (edx x86::edx-tn)
+	 (ebp x86::ebp-tn)
+	 (esp x86::esp-tn)
+	 ([ebp-8] (x86::make-ea :dword :base ebp :disp -8))
+	 ([ebp-4] (x86::make-ea :dword :base ebp :disp -4)))
+    (assemble (segment)
+	      (inst push ebp)			    ; save old frame pointer
+	      (inst mov  ebp esp)		    ; establish new frame
+	      (inst mov  eax esp)		    ; 
+	      (inst sub  eax 8)		            ; place for result 
+	      (inst push eax)			    ; arg2
+	      (inst add  eax 16)		    ; arguments  
+	      (inst push eax)			    ; arg1
+	      (inst push (ash index 2))		    ; arg0
+	      (inst push (alien::address-of-call-callback))     ; function
+	      (inst mov  eax (alien::address-of-funcall3))
+	      (inst call eax)
+	      ;; now put the result into the right register
+	      (etypecase return-type
+		(alien::integer-64$
+		 (inst mov eax [ebp-8])
+		 (inst mov edx [ebp-4]))
+		((or alien::integer$ alien::pointer$ alien::sap$)
+		 (inst mov eax [ebp-8]))
+		(alien::single$
+		 (inst fld  [ebp-8]))
+		(alien::double$
+		 (inst fldd [ebp-8]))
+		(alien::void$ ))
+	      (inst mov esp ebp)		   ; discard frame
+	      (inst pop ebp)			   ; restore frame pointer
+	      (inst ret))
+    (let* ((length (finalize-segment segment)))
+      (prog1 (alien::segment-to-trampoline segment length)
+	(release-segment segment)))))
+
+