diff --git a/code/foreign.lisp b/code/foreign.lisp
index 402ba4b4a3e3f75276543be7bd8658450131282a..1be9c026f168cb812642d568ad8dae4e49d2ddbb 100644
--- a/code/foreign.lisp
+++ b/code/foreign.lisp
@@ -1,93 +1,183 @@
-;;; -*- Log: code.log; Package: Extensions -*-
-
+;;; -*- Package: SYSTEM -*-
+;;;
 ;;; **********************************************************************
 ;;; This code was written as part of the Spice Lisp project at
 ;;; Carnegie-Mellon University, and has been placed in the public domain.
 ;;; If you want to use this code or any part of Spice Lisp, please contact
 ;;; Scott Fahlman (FAHLMAN@CMUC). 
 ;;; **********************************************************************
-
-;;; Functions for dealing with foreign function calls in Common Lisp.
-
-;;; Written by David B. McDonald, January 1987.
-
-;;; *******************************************************************
-(in-package "EXTENSIONS" :nicknames '("EXT") :use '("LISP" "SYSTEM"))
-
-(export '(load-foreign get-code-pointer get-data-pointer))
-
-(defconstant Unix-OMagic #x107)
-(defconstant Unix-NMagic #x108)
-(defconstant Unix-ZMagic #x10b)
-
-(defconstant Unix-header-size 32)
-(defconstant Symbol-Table-Entry-Size 12)
-
-(defconstant n_undf #x0)
-(defconstant n_abs #x2)
-(defconstant n_text #x4)
-(defconstant n_data #x6)
-(defconstant n_bss #x8)
-(defconstant n_comm #x12)
-(defconstant n_fn #x1f)
-(defconstant n_ext #x1)
-
-(defvar file-count 0
-  "Number of foreign function files loaded into the current Lisp.")
-
-(defvar temporary-foreign-files NIL
-  "List of dotted pairs containing location and size of object code
-   loaded so that foreign functions can be called.")
-
-(proclaim '(fixnum file-count))
-
-(defstruct unix-ste
-  (type 0 :type fixnum)
-  (location 0))
-
-
-(defvar foreign-symbols (make-hash-table :size 1000 :test #'equal))
-
-(defmacro read-cword (sap offset)
-  `(let ((rsap ,sap)
-	 (roff ,offset))
-     (declare (fixnum roff))
-     (setq roff (the fixnum (ash roff 1)))
-     (logior (ash (%primitive 16bit-system-ref rsap roff) 16)
-	     (%primitive 16bit-system-ref rsap (the fixnum (1+ roff))))))
-
-(defun read-miscop-free-pointer ()
-  (let ((aa lisp::alloctable-address)
-	(in (ash lisp::%assembler-code-type lisp::%alloc-ref-type-shift)))
-    (declare (fixnum in))
-    (logand (+ (logior (%primitive 16bit-system-ref aa (the fixnum (1+ in)))
-		       (ash (%primitive 16bit-system-ref aa in) 16)) 3)
-	    (lognot 3))))
-
-(defun write-miscop-free-pointer (value)
-  (let ((aa lisp::alloctable-address)
-	(in (ash lisp::%assembler-code-type lisp::%alloc-ref-type-shift))
-	(vl (logand value #xFFFF))
-	(vh (logand (ash value -16) #xFFFF)))
-    (declare (fixnum in))
-    (%primitive 16bit-system-set aa (the fixnum (1+ in)) vl)
-    (%primitive 16bit-system-set aa in vh)))
-
-;;; Load-foreign accepts a file or a list of files to be loaded into the
-;;; currently running Lisp core.  These files should be standard object
-;;; files created by you favourite compiler (e.g., cc).  It accepts two
-;;; optional parameters: libraries is a list of libraries to search
-;;; for unresolved references (default is the standard C library), and
-;;; env which is a list of Unix environment strings (default is what
-;;; lisp started with).  Load-foreign runs ld creating an object file
-;;; that has been linked so that it can be loaded into a predetermined
-;;; location in memory.
+;;;
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/foreign.lisp,v 1.3 1991/01/31 01:20:54 wlott Exp $
+;;;
+;;; Load-foreign and support routines.
+;;;
+(in-package "SYSTEM")
+
+(export '(load-foreign))
+
+(defconstant foreign-segment-start #x00C00000)
+(defconstant foreign-segment-size  #x00400000)
+
+(defvar *previous-linked-object-file* nil)
+(defvar *foreign-segment-free-pointer* foreign-segment-start)
+
+(defun pick-temporary-file-name (&optional (base "/tmp/tmp~D~C"))
+  (let ((code (char-code #\A)))
+    (loop
+      (let ((name (format nil base (mach:unix-getpid) (code-char code))))
+	(multiple-value-bind
+	    (fd errno)
+	    (mach:unix-open name
+			    (logior mach:o_wronly mach:o_creat mach:o_excl)
+			    #o666)
+	  (cond ((not (null fd))
+		 (mach:unix-close fd)
+		 (return name))
+		((not (= errno mach:eexist))
+		 (error "Could not create temporary file ~S: ~A"
+			name (mach:get-unix-error-msg errno)))
+		
+		((= code (char-code #\Z))
+		 (setf code (char-code #\a)))
+		((= code (char-code #\z))
+		 (return nil))
+		(t
+		 (incf code))))))))
+
+#+sparc
+(ext:def-c-record exec
+  (magic ext:unsigned-long)
+  (text ext:unsigned-long)
+  (data ext:unsigned-long)
+  (bss ext:unsigned-long)
+  (syms ext:unsigned-long)
+  (entry ext:unsigned-long)
+  (trsize ext:unsigned-long)
+  (drsize ext:unsigned-long))
+
+(defun allocate-space-in-foreign-segment (bytes)
+  (let* ((pagesize-1 (1- (gr-call* mach:vm_statistics *task-self*)))
+	 (memory-needed (logandc2 (+ bytes pagesize-1) pagesize-1))
+	 (addr (int-sap *foreign-segment-free-pointer*))
+	 (new-ptr (+ *foreign-segment-free-pointer* bytes)))
+    (when (> new-ptr (+ foreign-segment-start foreign-segment-size))
+      (error "Not enough memory left."))
+    (setf *foreign-segment-free-pointer* new-ptr)
+    (gr-call* mach:vm_allocate *task-self* addr memory-needed nil)
+    addr))
+
+#+sparc
+(defun load-object-file (name)
+  (format t ";;; Loading object file...~%")
+  (multiple-value-bind (fd errno) (mach:unix-open name mach:o_rdonly 0)
+    (unless fd
+      (error "Could not open ~S: ~A" name (mach:get-unix-error-msg errno)))
+    (unwind-protect
+	(with-stack-alien (header exec #.(ext:c-sizeof 'exec))
+	  (mach:unix-read fd
+			  (alien-sap (alien-value header))
+			  (truncate (alien-size (alien-value header))
+				    (bytes 1)))
+	  (let* ((len-of-text-and-data
+		  (+ (alien-access (exec-text (alien-value header)))
+		     (alien-access (exec-data (alien-value header)))))
+		 (memory-needed
+		  (+ len-of-text-and-data
+		     (alien-access (exec-bss (alien-value header)))))
+		 (addr (allocate-space-in-foreign-segment memory-needed)))
+	    (mach:unix-read fd addr len-of-text-and-data)))
+      (mach:unix-close fd))))
+
+#+pmax
+(ext:def-c-record filehdr
+  (magic ext:unsigned-short)
+  (nscns ext:unsigned-short)
+  (timdat ext:long)
+  (symptr ext:long)
+  (nsyms ext:long)
+  (opthdr ext:unsigned-short)
+  (flags ext:unsigned-short))
+
+#+pmax
+(ext:def-c-record aouthdr
+  (magic ext:short)
+  (vstamp ext:short)
+  (tsize ext:long)
+  (dsize ext:long)
+  (bsize ext:long)
+  (entry ext:long)
+  (text_start ext:long)
+  (data_start ext:long))
+
+#+pmax
+(defconstant filhsz 20)
+#+pmax
+(defconstant aouthsz 56)
+#+pmax
+(defconstant scnhsz 40)
+
+#+pmax
+(defun load-object-file (name)
+  (format t ";;; Loading object file...~%")
+  (multiple-value-bind (fd errno) (mach:unix-open name mach:o_rdonly 0)
+    (unless fd
+      (error "Could not open ~S: ~A" name (mach:get-unix-error-msg errno)))
+    (unwind-protect
+	(with-stack-alien (filehdr filehdr #.(ext:c-sizeof 'filehdr))
+	  (with-stack-alien (aouthdr aouthdr #.(ext:c-sizeof 'aouthdr))
+	    (mach:unix-read fd
+			    (alien-sap (alien-value filehdr))
+			    (truncate (alien-size (alien-value filehdr))
+				      (bytes 1)))
+	    (mach:unix-read fd
+			    (alien-sap (alien-value aouthdr))
+			    (truncate (alien-size (alien-value aouthdr))
+				      (bytes 1)))
+	    (let* ((len-of-text-and-data
+		    (+ (alien-access (aouthdr-tsize (alien-value aouthdr)))
+		       (alien-access (aouthdr-dsize (alien-value aouthdr)))))
+		   (memory-needed
+		    (+ len-of-text-and-data
+		       (alien-access (aouthdr-bsize (alien-value aouthdr)))))
+		   (addr (allocate-space-in-foreign-segment memory-needed))
+		   (pad-size-1 (if (< (alien-access
+				       (aouthdr-vstamp (alien-value aouthdr)))
+				      23)
+				   7 15)))
+	      (mach:unix-lseek fd
+			       (logandc2 (+ filhsz aouthsz
+					    (* scnhsz
+					       (alien-access
+						(filehdr-nscns
+						 (alien-value filehdr))))
+					    pad-size-1)
+					 pad-size-1)
+			       mach:l_set)
+	      (mach:unix-read fd addr len-of-text-and-data))))
+      (mach:unix-close fd))))
+
+(defun parse-symbol-table (name)
+  (format t ";;; Parsing symbol table...~%")
+  (let ((symbol-table (make-hash-table :test #'equal)))
+    (with-open-file (file name)
+      (loop
+	(let ((line (read-line file nil nil)))
+	  (unless line
+	    (return))
+	  (let* ((symbol (subseq line 11))
+		 (address (parse-integer line :end 8 :radix 16))
+		 (old-address (gethash symbol lisp::*foreign-symbols*)))
+	    (unless (or (null old-address) (= address old-address))
+	      (warn "~S moved from #x~8,'0X to #x~8,'0X.~%"
+		    symbol old-address address))
+	    (setf (gethash symbol symbol-table) address)))))
+    (setf lisp::*foreign-symbols* symbol-table)))
 
 (defun load-foreign (files &optional
 			   (libraries '("-lc"))
-			   (linker "/usr/cs/bin/ld")
-			   (base-file "/usr/misc/.lisp/bin/lisp")
-			   (env lisp::original-lisp-environment))
+			   (linker "/usr/misc/.cmucl/lib/load-foreign.csh")
+			   (base-file "/usr/misc/.cmucl/bin/lisp")
+			   (env ext:*environment-list*))
   "Load-foreign loads a list of C object files into a running Lisp.  The
   files argument should be a single file or a list of files.  The files
   may be specified as namestrings or as pathnames.  The libraries
@@ -100,181 +190,40 @@
   start up code for Lisp.  The env argument is the Unix environment
   variable definitions for the invocation of the linker.  The default is
   the environment passed to Lisp."
-  (if (null (listp files)) (setq files (list files)))
-  (format t "[Loading foreign files ~A ...~%" files)
-  (let ((tfl (if files (format nil "/tmp/L~d.~d"
-			       (mach:unix-getuid)
-			       (the fixnum (+ (the fixnum (mach:unix-getpid))
-					      file-count)))
-		 base-file))
-	(ofl (get-last-loaded-file file-count base-file))
-	(addr (read-miscop-free-pointer)))
-    (when files
-      (setq file-count (the fixnum (1+ file-count)))
-      (format t "  [Running ld ...")
-      (force-output t)
-      (let ((nfiles ()))
-	(dolist (f files)
-	  (let* ((pn (merge-pathnames f *default-pathname-defaults*))
-		 (tn (probe-file pn)))
-	    (push (if tn (namestring tn) f) nfiles)))
-	(setf files (nreverse nfiles)))
-      (run-program linker `("-N" "-A" ,ofl "-T"
-			    ,(format nil "~X" (+ addr unix-header-size))
-			    "-o" ,tfl ,@files ,@libraries)
-		   :env env :wait t :output t :error t)
-      (push tfl temporary-foreign-files)
-      (format t " done.]~%"))
-    (multiple-value-bind (res dev ino mode nlnk uid gid rdev len)
-			 (mach:unix-stat tfl)
-      (declare (ignore ino mode nlnk uid gid rdev))
-      (when (null res)
-	(error "Could not stat intermediate file ~a, unix error: ~A."
-	       tfl (mach:get-unix-error-msg dev)))
-      (format t "  [Reading Unix object file ...")
-      (force-output t)
-      (multiple-value-bind (fd err) (mach:unix-open tfl mach:o_rdonly 0)
-	(when (null fd)
-	  (error "Failed to open intermediate file ~A, unix error: ~A."
-		 (mach:get-unix-error-msg err)))
-	(multiple-value-bind (bytes err2)
-			     (mach:unix-read fd (int-sap addr)
-					     len)
-	  (when (or (null bytes) (not (eq bytes len)))
-	    (if (null bytes)
-		(error "Read of intermediate file ~A failed, unix error: ~A"
-		       tfl (mach:get-unix-error-msg err2))
-		(error "Read of intermediate file ~A only read ~d of ~d bytes."
-		       tfl bytes len))))
-	(mach:unix-close fd)))
-    (format t " done.]~%")
-    (let ((fsize (logand (+ (load-object-file tfl addr files) 4) (lognot 3))))
-      (when files (write-miscop-free-pointer (+ addr fsize)))))
-  (format t "done.]~%"))
-
-;;; Get-last-loaded-file attempts to find the file that was last loaded into
-;;; Lisp.  If one is found, load-foreign uses it as the bases for the initial
-;;; symbol table.  Otherwise, it uses the lisp startup code.
-
-(defun get-last-loaded-file (fc base-file)
-  (declare (fixnum fc))
-  (do ((i (the fixnum (1- fc)) (1- i)))
-      ((< i 0) base-file)
-    (declare (fixnum i))
-    (let ((tfl (format nil "/tmp/L~d.~d" (mach:unix-getuid)
-		       (the fixnum (+ (the fixnum (mach:unix-getpid)) i)))))
-      (if (probe-file tfl) (return tfl)))))
-
-;;; Load-object-file, actually loads the object file created by ld.
-;;; It makes sure that it is a legal object file.
-
-(defun load-object-file (file addr flag)
-  (format t "  [Loading symbol table information ...")
-  (force-output t)
-  (let* ((sap (int-sap addr))
-	 (magic (read-cword sap 0))
-	 (text-size (read-cword sap 1))
-	 (idata-size (read-cword sap 2))
-	 (udata-size (read-cword sap 3))
-	 (symtab-size (read-cword sap 4))
-	 (epoint (read-cword sap 5))
-	 (treloc-size (read-cword sap 6))
-	 (dreloc-size (read-cword sap 7))
-	 (load-size (+ text-size idata-size udata-size unix-header-size))
-	 (symstart (+ text-size idata-size (if flag unix-header-size 2048)))
-	 (strstart (+ symstart (the fixnum symtab-size))))
-    (declare (fixnum magic text-size idata-size udata-size
-		     symtab-size symstart strstart treloc-size
-		     dreloc-size)
-	     (ignore epoint))
-    (unless (or (null flag)
-		(and (= magic unix-OMagic) (= treloc-size 0) (= dreloc-size 0)))
-      (error "File ~A is not a legal Unix object file." file))
-    (read-symbol-table (%primitive sap+ sap symstart) symtab-size (%primitive sap+ sap strstart))
-    (setq load-size (logand (the fixnum (+ load-size 8192)) (lognot 8191)))
-    (do ((ind (truncate (+ text-size idata-size unix-header-size) 2)
-	      (1+ ind))
-	 (end (truncate udata-size 2)))
-	((>= ind end))
-      (%primitive 16bit-system-set sap ind 0))
-    (format t " done.]~%")
-    load-size))
-
-;;; Read-symbol-table reads the symbol table out of the object, making
-;;; external symbols available to Lisp, so that they can be used to
-;;; link to the C routines.
-
-(defun read-symbol-table (symstart symtab-size strstart)
-  (let ((end (%primitive sap+ symstart symtab-size)))
-    (do* ((se symstart (%primitive sap+ se symbol-table-entry-size))
-	  (si (logior (ash (%primitive 16bit-system-ref se 0) 16)
-		      (%primitive 16bit-system-ref se 1))
-	      (logior (ash (%primitive 16bit-system-ref se 0) 16)
-		      (%primitive 16bit-system-ref se 1)))
-	  (st (%primitive 8bit-system-ref se 4)
-	      (%primitive 8bit-system-ref se 4))
-	  (sv (logior (ash (%primitive 16bit-system-ref se 4) 16)
-		      (%primitive 16bit-system-ref se 5))
-	      (logior (ash (%primitive 16bit-system-ref se 4) 16)
-		      (%primitive 16bit-system-ref se 5))))
-	 ((not (%primitive pointer< se end)))
-      (declare (fixnum st))
-      (when (or (= st (logior n_text n_ext))
-		(= st (logior n_data n_ext))
-		(= st (logior n_bss n_ext)))
-	(let* ((strend (%primitive find-character strstart si (+ si 512) 0)))
-	  (when (null strend)
-	    (error "Symbol table string didn't terminate."))
-	  (let ((strlen (the fixnum (- (the fixnum strend) (the fixnum si))))
-		(offset 0)
-		(code NIL)
-		(str NIL))
-	    (declare (fixnum strlen offset))
-	    (when (eq (%primitive 8bit-system-ref strstart si) (char-code #\_))
-	      (setq offset (the fixnum (1+ offset)))
-	      (when (eq (%primitive 8bit-system-ref strstart
-				    (the fixnum (1+ (the fixnum si))))
-			(char-code #\.))
-		(setq code T)
- 		(setq offset (the fixnum (1+ offset)))))
-	    (setq str (make-string (the fixnum (- strlen offset))))
-	    (%primitive byte-blt strstart
-			(the fixnum (+ (the fixnum si) offset)) str 0 strlen)
-	    (if (let ((x (ash sv (- (+ clc::type-shift-16 16)))))
-		  (not (<= clc::first-pointer-type x clc::last-pointer-type)))
-		(let ((ste (gethash str foreign-symbols))
-		      (loc (int-sap sv)))
-		  (cond ((null ste)
-			 (setf (gethash str foreign-symbols)
-			       (make-unix-ste :type (if code
-							(logior n_text
-								n_ext) st)
-					      :location (if code nil loc))))
-			(code
-			 (setf (unix-ste-type ste) (logior n_text n_ext)))
-			(T
-			 (setf (unix-ste-location ste) loc)))))))))))
-
-;;; Get-code-pointer accepts a simple string which should be the name
-;;; of a C routine that has already been loaded into the Lisp core image.
-;;; This name should use the correct capitalization of the C name without
-;;; the default underscore.
-(defun get-code-pointer (name)
-  (let ((ste (gethash name foreign-symbols)))
-    (when (null ste)
-      (error "There is no foreign function named ~A loaded." name))
-    (when (not (eq (unix-ste-type ste) (logior n_text n_ext)))
-      (error "~A is a foreign external variable, not a foreign function." name))
-    (unix-ste-location ste)))
+  (let ((output-file (pick-temporary-file-name))
+	(symbol-table-file (pick-temporary-file-name))
+	(error-output (make-string-output-stream)))
+    (format t ";;; Running ~A...~%" linker)
+    (force-output)
+    (let ((proc (ext:run-program linker
+				 (list* (or *previous-linked-object-file*
+					    base-file)
+					(format nil "~X"
+						*foreign-segment-free-pointer*)
+					output-file
+					symbol-table-file
+					(append (if (atom files)
+						    (list files)
+						    files)
+						libraries))
+				 :env env
+				 :input nil
+				 :output error-output
+				 :error :output)))
+      (unless proc
+	(error "Could not run ~S" linker))
+      (unless (zerop (ext:process-exit-code proc))
+	(system:serve-all-events 0)
+	(error "~S failed:~%~A"
+	       linker (get-output-stream-string error-output)))
+      (load-object-file output-file)
+      (parse-symbol-table symbol-table-file)
+      (mach:unix-unlink symbol-table-file)
+      (let ((old-file *previous-linked-object-file*))
+	(setf *previous-linked-object-file* output-file)
+	(when old-file
+	  (mach:unix-unlink old-file)))))
+  (format t ";;; Done.~%"))
 
 
-;;; Get-data-pointer is similar to get-code-pointer, except it returns the
-;;; address of a foreign global variable.
 
-(defun get-data-pointer (name)
-  (let ((ste (gethash name foreign-symbols)))
-    (when (null ste)
-      (error "There is no foreign variable named ~A loaded." name))
-    (when (eq (unix-ste-type ste) (logior n_text n_ext))
-      (error "~A is a foreign function, not a foreign variable." name))
-    (unix-ste-location ste)))