diff --git a/code/alieneval.lisp b/code/alieneval.lisp
index 87ccb5f2b0fe6acffd6ac3af845323e9ac563297..fe2cecabd0533fe7954ce6ac20dfbb28d52cd0cc 100644
--- a/code/alieneval.lisp
+++ b/code/alieneval.lisp
@@ -1,4 +1,4 @@
-;;; -*- Log: code.log; Package: Lisp -*-
+;;; -*- Package: ALIEN -*-
 ;;;
 ;;; **********************************************************************
 ;;; This code was written as part of the CMU Common Lisp project at
@@ -7,1436 +7,1762 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/alieneval.lisp,v 1.12 1991/11/06 15:47:51 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/alieneval.lisp,v 1.13 1992/02/14 23:44:11 wlott Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
 ;;;    This file contains any the part of the Alien implementation that
 ;;; is not part of the compiler.
 ;;;
-(in-package "LISP")
-(in-package "SYSTEM")
-(export '(*alien-eval-when* make-alien alien-type alien-size alien-address
-	  copy-alien dispose-alien defalien alien-value alien-bind
-	  defoperator alien-index alien-indirect bits bytes words
-	  long-words port perq-string boolean defenumeration enumeration
-	  system-area-pointer pointer alien alien-access alien-assign
-	  alien-sap define-alien-stack with-stack-alien
-	  null-terminated-string c-procedure unstructured
-	  sap+ sap- sap-ref-sap sap-ref-32 sap-ref-16 sap-ref-8
-	  sap-ref-single sap-ref-double))
-(in-package "KERNEL")
-(export '(%set-sap-ref-sap %set-sap-ref-32 %set-sap-ref-16
-	  %set-sap-ref-8 %set-sap-ref-single %set-sap-ref-double))
-
-(in-package "LISP")
-
-(defun concat-pnames* (name1 name2)
-  (if name1
-      (make-symbol (concatenate 'simple-string (symbol-name name1)
-				(symbol-name name2)))
-      name2))
-
-#-new-compiler
-(eval-when (compile)
-  (setq lisp::*bootstrap-defmacro* :both))
-
-;;; The number of bits corresponding to a change of 1 in the value of a SAP.
-;;;
-(defconstant alien-address-unit vm:byte-bits)
-(defconstant alien-address-shift (1- (integer-length alien-address-unit)))
+(in-package "ALIEN")
+(use-package "EXT")
+(use-package "SYSTEM")
+
+(export '(alien * array struct union enum function integer signed unsigned
+	  boolean values single-float double-float
+	  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))
+
+(in-package "ALIEN-INTERNALS")
+(in-package "ALIEN")
+
+(export '(alien alien-value parse-alien-type unparse-alien-type
+	  alien-type-= alien-subtype-p alien-typep
+
+	  def-alien-type-class def-alien-type-translator def-alien-type-method
+	  invoke-alien-type-method
+
+	  alien-type alien-type-p alien-type-bits alien-type-alignment
+	  alien-integer-type alien-integer-type-p alien-integer-type-signed
+	  alien-boolean-type alien-boolean-type-p
+	  alien-enum-type alien-enum-type-p
+	  alien-pointer-type alien-pointer-type-p alien-pointer-type-to
+	  make-alien-pointer-type
+	  alien-array-type alien-array-type-p alien-array-type-element-type
+	  alien-array-type-dimensions	  
+	  alien-record-type alien-record-type-p alien-record-type-fields
+	  alien-record-field alien-record-field-p alien-record-field-name
+	  alien-record-field-type alien-record-field-offset
+	  alien-function-type alien-function-type-p
+	  alien-function-type-result-type alien-function-type-arg-types
+	  alien-values-type alien-values-type-p alien-values-type-values
+
+	  %set-slot %slot-addr %set-deref %deref-addr
+
+	  %heap-alien %set-heap-alien %heap-alien-addr
+	  heap-alien-info heap-alien-info-p heap-alien-info-type
+	  heap-alien-info-sap-form
+
+	  local-alien %set-local-alien %local-alien-addr
+	  local-alien-info local-alien-info-p local-alien-info-type
+	  local-alien-info-force-to-memory-p
+	  %local-alien-forced-to-memory-p
+	  make-local-alien dispose-local-alien note-local-alien-type
+
+	  %cast %sap-alien align-offset
+
+	  extract-alien-value deposit-alien-value naturalize deport
+	  compute-lisp-rep-type compute-alien-rep-type
+	  compute-extract-lambda compute-deposit-lambda
+	  compute-naturalize-lambda compute-deport-lambda)
+	"ALIEN-INTERNALS")
 
-;;; The address pointed to by the SAP in an alien is always a multiple of this
-;;; number of bits.
-;;;
-(defconstant alien-alignment vm:word-bits)
 
+
+;;;; Utility functions.
 
-(defvar *alien-eval-when* '(compile load eval)
-  "This is a list of the times to eval Alien compiler info.")
+(defun align-offset (offset alignment)
+  (let ((extra (rem offset alignment)))
+    (if (zerop extra) offset (+ offset (- alignment extra)))))
 
-(defun %print-alien-value (s stream d)
-  (declare (ignore d))
-  (let ((offset (alien-value-offset s)))
-    (format
-     stream
-     "#<Alien value, Address = #x~X~:[+~D/~D~;~2*~], Size = ~D, Type = ~S>"
-     (sap-int (alien-value-sap s)) (zerop offset) offset alien-address-unit
-     (alien-value-size s) (alien-value-type s))))
+(defun guess-alignment (bits)
+  (cond ((null bits) nil)
+	((> bits 16) 32)
+	((> bits 8) 16)
+	((> bits 1) 8)
+	(t 1)))
+
+
+;;;; Alien-type-info stuff.
+
+(eval-when (compile eval load)
+
+(defstruct (alien-type-class
+	    (:print-function %print-alien-type-class))
+  (name nil :type symbol)
+  (include nil :type (or null alien-type-class))
+  (unparse nil :type (or null function))
+  (type= nil :type (or null function))
+  ;; subtypep?
+  (lisp-rep nil :type (or null function))
+  (alien-rep nil :type (or null function))
+  (extract-gen nil :type (or null function))
+  (deposit-gen nil :type (or null function))
+  (naturalize-gen nil :type (or null function))
+  (deport-gen nil :type (or null function))
+  ;; Cast?
+  (arg-tn nil :type (or null function))
+  (result-tn nil :type (or null function)))
+
+(defun %print-alien-type-class (type-class stream depth)
+  (declare (ignore depth))
+  (print-unreadable-object (type-class stream :type t)
+    (prin1 (alien-type-class-name type-class) stream)))
+
+(defvar *alien-type-classes* (make-hash-table :test #'eq))
+
+(defun alien-type-class-or-lose (name)
+  (or (gethash name *alien-type-classes*)
+      (error "No alien type class ~S" name)))
+
+(defun create-alien-type-class-if-necessary (name include)
+  (let ((old (gethash name *alien-type-classes*))
+	(include (and include (alien-type-class-or-lose include))))
+    (if old
+	(setf (alien-type-class-include old) include)
+	(setf (gethash name *alien-type-classes*)
+	      (make-alien-type-class :include include)))))
+
+(defconstant method-slot-alist
+  '((:unparse . alien-type-class-unparse)
+    (:type= . alien-type-class-type=)
+    ;; subtypep?
+    (:lisp-rep . alien-type-class-lisp-rep)
+    (:alien-rep . alien-type-class-alien-rep)
+    (:extract-gen . alien-type-class-extract-gen)
+    (:deposit-gen . alien-type-class-deposit-gen)
+    (:naturalize-gen . alien-type-class-naturalize-gen)
+    (:deport-gen . alien-type-class-deport-gen)
+    ;; Cast?
+    (:arg-tn . alien-type-class-arg-tn)
+    (:result-tn . alien-type-class-result-tn)))
+
+(defun method-slot (method)
+  (cdr (or (assoc method method-slot-alist)
+	   (error "No method ~S" method))))
+
+); eval-when
+
+
+(defmacro def-alien-type-class ((name &key include) &rest slots)
+  (let ((defstruct-name
+	 (intern (concatenate 'string "ALIEN-" (symbol-name name) "-TYPE"))))
+    (multiple-value-bind
+	(include include-defstruct overrides)
+	(etypecase include
+	  (null
+	   (values nil 'alien-type nil))
+	  (symbol
+	   (values
+	    include
+	    (intern (concatenate 'string
+				 "ALIEN-" (symbol-name include) "-TYPE"))
+	    nil))
+	  (list
+	   (values
+	    (car include)
+	    (intern (concatenate 'string
+				 "ALIEN-" (symbol-name (car include)) "-TYPE"))
+	    (cdr include))))
+      `(progn
+	 (eval-when (compile load eval)
+	   (create-alien-type-class-if-necessary ',name ',(or include 'root)))
+	 (defstruct (,defstruct-name
+			(:include ,include-defstruct
+				  (:class ',name)
+				  ,@overrides))
+	   ,@slots)))))
+
+(defmacro def-alien-type-method ((class method) lambda-list &rest body)
+  (let ((defun-name (intern (concatenate 'string
+					 (symbol-name class)
+					 "-"
+					 (symbol-name method)
+					 "-METHOD"))))
+    `(progn
+       (defun ,defun-name ,lambda-list
+	 ,@body)
+       (setf (,(method-slot method) (alien-type-class-or-lose ',class))
+	     #',defun-name))))
+
+(defmacro invoke-alien-type-method (method type &rest args)
+  (let ((slot (method-slot method)))
+    (once-only ((type type))
+      `(funcall (do ((class (alien-type-class-or-lose (alien-type-class ,type))
+			    (alien-type-class-include class)))
+		    ((null class)
+		     (error "Method ~S not defined for ~S"
+			    ',method (alien-type-class ,type)))
+		  (let ((fn (,slot class)))
+		    (when fn
+		      (return fn))))
+		,type ,@args))))
 
-(defun %print-alien-info (s stream d)
-  (declare (ignore s d))
-  (write-string "#<Alien-Info>" stream))
 
 
-;;;; Interpreter stubs for SAP functions:
+;;;; Alien-type defstruct.
 
-#+new-compiler (progn
+(eval-when (compile load eval)
+  (create-alien-type-class-if-necessary 'root nil))
 
-(defun pointer< (x y)
-  "Return T iff the SAP X points to a smaller address then the SAP Y."
-  (declare (type system-area-pointer x y))
-  (pointer< x y))
+(defstruct (alien-type
+	    (:print-function %print-alien-type)
+	    (:make-load-form-fun :just-dump-it-normally))
+  (class 'root :type symbol)
+  (bits nil :type (or null unsigned-byte))
+  (alignment (guess-alignment bits) :type (or null unsigned-byte)))
 
-(defun pointer> (x y)
-  "Return T iff the SAP X points to a larger address then the SAP Y."
-  (declare (type system-area-pointer x y))
-  (pointer> x y))
+(defun %print-alien-type (type stream depth)
+  (declare (ignore depth))
+  (print-unreadable-object (type stream :type t)
+    (prin1 (unparse-alien-type type) stream)))
 
-(defun sap+ (sap offset)
-  "Return a new sap OFFSET bytes from SAP."
-  (declare (type system-area-pointer sap)
-	   (fixnum offset))
-  (sap+ sap offset))
-
-(defun sap- (sap1 sap2)
-  "Return the byte offset between SAP1 and SAP2."
-  (declare (type system-area-pointer sap1 sap2))
-  (sap- sap1 sap2))
-
-(defun sap-int (sap)
-  "Converts a System Area Pointer into an integer."
-  (declare (type system-area-pointer sap))
-  (sap-int sap))
-
-(defun int-sap (int)
-  "Converts an integer into a System Area Pointer."
-  (declare (type (unsigned-byte #.vm:word-bits) int))
-  (int-sap int))
-
-(defun sap-ref-8 (sap offset)
-  "Returns the 8-bit byte at OFFSET bytes from SAP."
-  (declare (type system-area-pointer sap)
-	   (type index offset))
-  (sap-ref-8 sap offset))
+
+;;;; Type parsing and unparsing.
+
+
+(defvar *additional-type-definitions*)
+
+(defmacro with-additional-alien-types ((symbol) &body body)
+  `(let ((*additional-type-definitions*
+	  (if (boundp '*additional-type-definitions*)
+	      *additional-type-definitions*
+	      nil)))
+     (symbol-macrolet ((,symbol *additional-type-definitions*))
+       ,@body)))
+
+(defmacro locally-introduce-additional-types ((additional-types) &body body)
+  `(compiler-let ((*additional-type-definitions* ',additional-types))
+     ,@body))
+
+;;; PARSE-ALIEN-TYPE -- public
+;;;
+(defun parse-alien-type (type)
+  "Parse the list structure TYPE as an alien type specifier and return
+   the resultant alien-type structure."
+  (if (boundp '*additional-type-definitions*)
+      (%parse-alien-type type)
+      (let ((*additional-type-definitions* nil))
+	(%parse-alien-type type))))
+
+(defun %parse-alien-type (type)
+  (if (consp type)
+      (let ((translator (info alien-type translator (car type))))
+	(unless translator
+	  (error "Unknown alien type: ~S" type))
+	(funcall translator type))
+      (case (info alien-type kind type)
+	(:primitive
+	 (let ((translator (info alien-type translator type)))
+	   (unless translator
+	     (error "No translator for primitive alien type ~S?" type))
+	   (funcall translator (list type))))
+	(:defined
+	 (or (info alien-type definition type)
+	     (error "Definition missing for alien type ~S?" type)))
+	(:unknown
+	 (error "Unknown alien type: ~S" type)))))
+
+(defun auxiliary-alien-type (kind name)
+  (let ((in-additionals (find-if #'(lambda (x)
+				     (and (eq (first x) kind)
+					  (eq (second x) name)))
+				 *additional-type-definitions*)))
+    (if in-additionals
+	(values (third in-additionals) t)
+	(ecase kind
+	  (:struct
+	   (info alien-type struct name))
+	  (:union
+	   (info alien-type union name))
+	  (:enum
+	   (info alien-type enum name))))))
+
+(defun %set-auxiliary-alien-type (kind name defn)
+  (push (list kind name defn)
+	*additional-type-definitions*)
+  defn)
+
+(defsetf auxiliary-alien-type %set-auxiliary-alien-type)
+
+
+;;; *record-type-already-unparsed* -- internal
+;;;
+;;; Holds the list of record types that have already been unparsed.  This is
+;;; used to keep from outputing the slots again if the same structure shows
+;;; up twice.
+;;; 
+(defvar *record-types-already-unparsed*)
 
-(defun sap-ref-16 (sap offset)
-  "Returns the 16-bit word at OFFSET half-words from SAP."
-  (declare (type system-area-pointer sap)
-	   (type index offset))
-  (sap-ref-16 sap offset))
+;;; UNPARSE-ALIEN-TYPE -- public.
+;;; 
+(defun unparse-alien-type (type)
+  "Convert the alien-type structure TYPE back into a list specification of
+   the type."
+  (declare (type alien-type type))
+  (let ((*record-types-already-unparsed* nil))
+    (%unparse-alien-type type)))
 
-(defun sap-ref-32 (sap offset)
-  "Returns the 32-bit dualword at OFFSET words from SAP."
-  (declare (type system-area-pointer sap)
-	   (type index offset))
-  (sap-ref-32 sap offset))
+;;; %UNPARSE-ALIEN-TYPE -- internal.
+;;;
+;;; Does all the work of UNPARSE-ALIEN-TYPE.  It's seperate because we need
+;;; to recurse inside the binding of *record-types-already-unparsed*.
+;;; 
+(defun %unparse-alien-type (type)
+  (invoke-alien-type-method :unparse type))
 
-(defun sap-ref-sap (sap offset)
-  "Returns the 32-bit system-area-pointer at OFFSET words from SAP."
-  (declare (type system-area-pointer sap)
-	   (type index offset))
-  (sap-ref-sap sap offset))
 
-(defun sap-ref-single (sap offset)
-  "Returns the 32-bit single-float at OFFSET words from SAP."
-  (declare (type system-area-pointer sap)
-	   (type index offset))
-  (sap-ref-single sap offset))
 
-(defun sap-ref-double (sap offset)
-  "Returns the 64-bit double-float at OFFSET words from SAP."
-  (declare (type system-area-pointer sap)
-	   (type index offset))
-  (sap-ref-double sap offset))
+
+;;;; Alien type defining stuff.
+
+(defmacro def-alien-type-translator (name lambda-list &body body)
+  (let ((whole (gensym))
+	(defun-name (intern (concatenate 'string
+					 "ALIEN-"
+					 (symbol-name name)
+					 "-TYPE-TRANSLATOR"))))
+    (multiple-value-bind
+	(body decls docs)
+	(lisp::parse-defmacro lambda-list whole body name
+			      'def-alien-type-translator)
+      `(progn
+	 (defun ,defun-name (,whole)
+	   ,decls
+	   (block ,name
+	     ,body))
+	 (%def-alien-type-translator ',name #',defun-name ,docs)))))
+
+(defun %def-alien-type-translator (name translator docs)
+  (declare (ignore docs))
+  (setf (info alien-type kind name) :primitive)
+  (setf (info alien-type translator name) translator)
+  (clear-info alien-type definition name)
+  #+nil
+  (setf (documentation name 'alien-type) docs)
+  name)
+
+
+(defmacro def-alien-type (name type)
+  "Define the alien type NAME to be equivalent to TYPE."
+  (with-additional-alien-types (additional-types)
+    (let ((alien-type (parse-alien-type type)))
+      `(eval-when (compile load eval)
+	 ,@(when additional-types
+	     `((%def-additional-alien-types ',additional-types)))
+	 ,@(when name
+	     `((%def-alien-type ',name ',alien-type)))))))
+
+(defun %def-additional-alien-types (types)
+  (dolist (info types)
+    (destructuring-bind (kind name defn) info
+      (ecase kind
+	(:struct
+	 (setf (info alien-type struct name) defn))
+	(:union
+	 (setf (info alien-type union name) defn))
+	(:enum
+	 (setf (info alien-type enum name) defn))))))
+
+(defun %def-alien-type (name new)
+  (ecase (info alien-type kind name)
+    (:primitive
+     (error "~S is a built-in alien type." name))
+    (:defined
+     (let ((old (info alien-type definition name)))
+       (unless (or (null old) (alien-type-= new old))
+	 (warn "Redefining ~S to be:~%  ~S,~%was~%  ~S" name
+	       (unparse-alien-type new) (unparse-alien-type old)))))
+    (:unknown))
+  (setf (info alien-type definition name) new)
+  (setf (info alien-type kind name) :defined)
+  name)
 
-(defun signed-sap-ref-8 (sap offset)
-  "Returns the signed 8-bit byte at Offset bytes from SAP."
-  (declare (type system-area-pointer sap)
-	   (type index offset))
-  (signed-sap-ref-8 sap offset))
 
-(defun signed-sap-ref-16 (sap offset)
-  "Returns the signed 16-bit word at Offset words from SAP."
-  (declare (type system-area-pointer sap)
-	   (type index offset))
-  (signed-sap-ref-16 sap offset))
+
+;;;; Interfaces to the different methods
+
+(defun alien-type-= (type1 type2)
+  "Return T iff TYPE1 and TYPE2 describe equivalent alien types."
+  (or (eq type1 type2)
+      (and (eq (alien-type-class type1)
+	       (alien-type-class type2))
+	   (invoke-alien-type-method :type= type1 type2))))
+
+(defun alien-subtype-p (type1 type2)
+  "Return T iff the alien type TYPE1 is a subtype of TYPE2.  Currently, the
+   only supported subtype relationship is that any pointer type is a subtype
+   of (* t).  Otherwise, the two types have to be ALIEN-TYPE-=."
+  (typecase type1
+    (alien-pointer-type
+     (and (alien-pointer-type-p type2)
+	  (or (null (alien-pointer-type-to type2))
+	      (alien-type-= type1 type2))))
+    (t
+     (alien-type-= type1 type2))))
+
+
+(defun alien-typep (object type)
+  "Return T iff OBJECT is an alien of type TYPE."
+  (let ((lisp-rep-type (compute-lisp-rep-type type)))
+    (if lisp-rep-type
+	(typep object lisp-rep-type)
+	(and (alien-value-p object)
+	     (alien-subtype-p (alien-value-type object) type)))))
+
+
+(defun compute-naturalize-lambda (type)
+  `(lambda (alien ignore)
+     (declare (ignore ignore))
+     ,(invoke-alien-type-method :naturalize-gen type 'alien)))
+
+(defun compute-deport-lambda (type)
+  (declare (type alien-type type))
+  (multiple-value-bind
+      (form value-type)
+      (invoke-alien-type-method :deport-gen type 'value)
+    `(lambda (value ignore)
+       (declare (type ,(or value-type
+			   (compute-lisp-rep-type type)
+			   `(alien ,type))
+		      value)
+		(ignore ignore))
+       ,form)))
+
+(defun compute-extract-lambda (type)
+  `(lambda (sap offset ignore)
+     (declare (type system-area-pointer sap)
+	      (type unsigned-byte offset)
+	      (ignore ignore))
+     (naturalize ,(invoke-alien-type-method :extract-gen type 'sap 'offset)
+		 ',type)))
+
+(defun compute-deposit-lambda (type)
+  (declare (type alien-type type))
+  `(lambda (sap offset ignore value)
+     (declare (type system-area-pointer sap)
+	      (type unsigned-byte offset)
+	      (ignore ignore))
+     (let ((value (deport value ',type)))
+       ,(invoke-alien-type-method :deposit-gen type 'sap 'offset 'value)
+       ;; Note: the reason we don't just return the pre-deported value
+       ;; is because that would inhibit any (deport (naturalize ...))
+       ;; optimizations that might have otherwise happen.  Re-naturalizing
+       ;; the value might cause extra consing, but is flushable, so probably
+       ;; results in better code.
+       (naturalize value ',type))))
+
+(defun compute-lisp-rep-type (type)
+  (invoke-alien-type-method :lisp-rep type))
+
+(defun compute-alien-rep-type (type)
+  (invoke-alien-type-method :alien-rep type))
 
-(defun signed-sap-ref-32 (sap offset)
-  "Returns the signed 32-bit dualword at Offset words from SAP."
-  (declare (type system-area-pointer sap)
-	   (type index offset))
-  (signed-sap-ref-32 sap offset))
 
-(defun %set-sap-ref-8 (sap offset new-value)
-  (declare (type system-area-pointer sap)
-	   (type index offset)
-	   (type (or (signed-byte 8) (unsigned-byte 8)) new-value))
-  (setf (sap-ref-8 sap offset) new-value))
 
-(defun %set-sap-ref-16 (sap offset new-value)
-  (declare (type system-area-pointer sap)
-	   (type index offset)
-	   (type (or (signed-byte 16) (unsigned-byte 16)) new-value))
-  (setf (sap-ref-16 sap offset) new-value))
 
-(defun %set-sap-ref-32 (sap offset new-value)
-  (declare (type system-area-pointer sap)
-	   (type index offset)
-	   (type (or (signed-byte 32) (unsigned-byte 32)) new-value))
-  (if (minusp new-value)
-      (truly-the (signed-byte 32) (setf (sap-ref-32 sap offset) new-value))
-      (truly-the (unsigned-byte 32) (setf (sap-ref-32 sap offset) new-value))))
-
-(defun %set-sap-ref-sap (sap offset new-value)
-  (declare (type system-area-pointer sap new-value)
-	   (type index offset))
-  (setf (sap-ref-sap sap offset) new-value))
-
-(defun %set-sap-ref-single (sap offset new-value)
-  (declare (type system-area-pointer sap)
-	   (type index offset)
-	   (type single-float new-value))
-  (setf (sap-ref-single sap offset) new-value))
+
+;;;; Default methods.
 
-(defun %set-sap-ref-double (sap offset new-value)
-  (declare (type system-area-pointer sap)
-	   (type index offset)
-	   (type double-float new-value))
-  (setf (sap-ref-double sap offset) new-value))
+(def-alien-type-method (root :unparse) (type)
+  `(!!unknown-alien-type!! ,(type-of type)))
+
+(def-alien-type-method (root :type=) (type1 type2)
+  (declare (ignore type1 type2))
+  t)
+
+(def-alien-type-method (root :lisp-rep) (type)
+  (declare (ignore type))
+  nil)
+
+(def-alien-type-method (root :alien-rep) (type)
+  (declare (ignore type))
+  nil)
+
+(def-alien-type-method (root :naturalize-gen) (type alien)
+  (declare (ignore alien))
+  (error "Cannot represent ~S typed aliens." type))
+
+(def-alien-type-method (root :deport-gen) (type object)
+  (declare (ignore object))
+  (error "Cannot represent ~S typed aliens." type))
 
-); #+New-Compiler
+(def-alien-type-method (root :extract-gen) (type sap offset)
+  (declare (ignore sap offset))
+  (error "Cannot represent ~S typed aliens." type))
+
+(def-alien-type-method (root :deposit-gen) (type sap offset value)
+  `(setf ,(invoke-alien-type-method :extract-gen type sap offset) ,value))
+
+(def-alien-type-method (root :arg-tn) (type state)
+  (declare (ignore state))
+  (error "Cannot pass aliens of type ~S as arguments to call-out"
+	 (unparse-alien-type type)))
+
+(def-alien-type-method (root :result-tn) (type state)
+  (declare (ignore state))
+  (error "Cannot return aliens of type ~S from call-out"
+	 (unparse-alien-type type)))
 
 
-;;;; Miscellaneous primitives:
+;;;; The INTEGER type.
 
-;;; Alien-Assign  --  Public
-;;;
-;;;    Just blt the bytes from one to the other...
-;;;
-(defun alien-assign (to-alien from-alien)
-  "Copy the data in From-Alien into To-Alien.  The two alien values
-  must be of the same size and type."
-  (declare (type alien-value to-alien from-alien))
-  (unless (equal (alien-value-type to-alien) (alien-value-type from-alien))
-    (error "Arguments to Alien-Assign are of different types:~%~S~%~S"
-	   to-alien from-alien))
-  (let ((size (alien-value-size to-alien))
-	(src-off (alien-value-offset from-alien))
-	(dst-off (alien-value-offset to-alien)))
-    (unless (= size (alien-value-size from-alien))
-      (error "Arguments to Alien-Assign are of different sizes:~%~S~%~S"
-	     to-alien from-alien))
-    (unless (zerop (logand size (1- alien-address-unit)))
-      (error "Size of assigned Alien is not a byte multiple:~%~S"
-	     from-alien))
-    (unless (zerop (logand src-off (1- alien-address-unit)))
-      (error "Alien is not byte aligned:~%~S" from-alien))
-    (unless (zerop (logand dst-off (1- alien-address-unit)))
-      (error "Alien is not byte aligned:~%~S" to-alien))
-    (let ((dst-start (ash dst-off (- alien-address-shift))))
-      (%primitive byte-blt
-		  (alien-value-sap from-alien)
-		  (ash src-off (- alien-address-shift))
-		  (alien-value-sap to-alien) dst-start
-		  (+ dst-start (ash size (- alien-address-shift)))))
-    to-alien))
-
-
-;;; Alien-Type, Alien-Size, Alien-Address, Alien-SAP  --  Public
-;;;
-;;;    Return the corresponding fields out of the Alien-Value structure.
-;;; Convert the address back into rational form.
-;;;
-(defun alien-type (alien)
-  "Return the type of the Alien Value."
-  (check-type alien alien-value)
-  (alien-value-type alien))
-
-(defun alien-size (alien)
-  "Return the size in bits of the Alien." 
-  (check-type alien alien-value)
-  (alien-value-size alien))
-
-(defun alien-address (alien)
-  "Return the address of the data for Alien."
-  (check-type alien alien-value)
-  (+ (sap-int (alien-value-sap alien))
-     (/ (alien-value-offset alien) alien-address-unit)))
+(def-alien-type-class (integer)
+  (signed t :type (member t nil)))
+
+(def-alien-type-translator signed (&optional (bits vm:word-bits))
+  (make-alien-integer-type :bits bits))
+
+(def-alien-type-translator integer (&optional (bits vm:word-bits))
+  (make-alien-integer-type :bits bits))
+
+(def-alien-type-translator unsigned (&optional (bits vm:word-bits))
+  (make-alien-integer-type :bits bits :signed nil))
+
+(def-alien-type-method (integer :unparse) (type)
+  (list (if (alien-integer-type-signed type) 'signed 'unsigned)
+	(alien-integer-type-bits type)))
+
+(def-alien-type-method (integer :type=) (type1 type2)
+  (and (eq (alien-integer-type-signed type1)
+	   (alien-integer-type-signed type2))
+       (= (alien-integer-type-bits type1)
+	  (alien-integer-type-bits type2))))
+
+(def-alien-type-method (integer :lisp-rep) (type)
+  (list (if (alien-integer-type-signed type) 'signed-byte 'unsigned-byte)
+	(alien-integer-type-bits type)))
+
+(def-alien-type-method (integer :alien-rep) (type)
+  (list (if (alien-integer-type-signed type) 'signed-byte 'unsigned-byte)
+	(alien-integer-type-bits type)))
+
+(def-alien-type-method (integer :naturalize-gen) (type alien)
+  (declare (ignore type))
+  alien)
+
+(def-alien-type-method (integer :deport-gen) (type value)
+  (declare (ignore type))
+  value)
+
+(def-alien-type-method (integer :extract-gen) (type sap offset)
+  (declare (type alien-integer-type type))
+  (or (if (alien-integer-type-signed type)
+	  (case (alien-integer-type-bits type)
+	    (8 `(signed-sap-ref-8 ,sap (/ ,offset 8)))
+	    (16 `(signed-sap-ref-16 ,sap (/ ,offset 16)))
+	    (32 `(signed-sap-ref-32 ,sap (/ ,offset 32))))
+	  (case (alien-integer-type-bits type)
+	    (8 `(sap-ref-8 ,sap (/ ,offset 8)))
+	    (16 `(sap-ref-16 ,sap (/ ,offset 16)))
+	    (32 `(sap-ref-32 ,sap (/ ,offset 32)))))
+      (error "Cannot extract ~D bit integers."
+	     (alien-integer-type-bits type))))
 
-(defun alien-sap (alien)
-  "Return the system-area-pointer which corresponds to Alien.  Signal an
-  error if the alien's address is not word-aligned."
-  (check-type alien alien-value)
-  (unless (zerop (alien-value-offset alien))
-    (error "Argument to Alien-SAP is not word-aligned:~%~S" alien))
-  (alien-value-sap alien))
 
 
-;;;; Interface macros:
+;;;; The BOOLEAN type.
 
-;;; Defalien  --  Public
-;;;
-;;;    Dump the right compiler info and code to create the value at
-;;; load-time.
-;;;
-(defmacro defalien (name type size &optional (address :static))
-  "defalien Name Type Size [address]
-  Define a global Alien variable with the specified Name, Type, Size and
-  Address.  If Address is not supplied allocate storage to hold it."
-  `(progn
-    (eval-when (load eval)
-      (defparameter ,name (make-alien ',type ,size ,address)))
-    (eval-when ,*alien-eval-when*
-      (setf (info variable alien-value ',name)
-	    (make-ct-a-val
-	     :type ',type
-	     :size ,size
-	     :offset ,(if (numberp address)
-			  (rem (* address alien-address-unit) alien-alignment)
-			  0)
-	     :sap `(alien-value-sap ,',name)
-	     :alien ',name)))))
-
-
-;;; Define-Alien-Stack  --  Public
-;;;
-;;;    Define some variables and a function to grow the stack.  Put good
-;;; stuff on the property list.
-;;;
-(defmacro define-alien-stack (name type size)
-  "Define-Stack-Alien Name Type Size
-  Defines a new alien stack for use with the With-Stack-Alien macro.
-  The aliens have the specifed Type and Size, and are allocated on the
-  number stack."
-  `(eval-when ,*alien-eval-when*
-     (setf (info alien-stack info ',name)
-	   (make-stack-info :type ',type :size ,size))))
+(def-alien-type-class (boolean :include integer))
 
+(def-alien-type-translator boolean (&optional (bits vm:word-bits))
+  (make-alien-boolean-type :bits bits :signed nil))
 
-;;; Defoperator  --  Public
-;;;
-;;;    Make the Alien-Info for the compiler and the function for the
-;;; interpreter.
-;;;
-(defmacro defoperator ((name result-type) args body)
-  (do ((arg args (cdr arg))
-       (argnames ())
-       (arg-types ())
-       (n 0 (1+ n)))
-      ((null arg)
-       `(eval-when ,*alien-eval-when*
-	  (setf (info function alien-operator ',name)
-		(make-alien-info #'(lambda ,(nreverse argnames) ,body)
-				 ,(length args) ',arg-types ',result-type))
-	  (setf (info function source-transform ',name)
-		#'c::alien=>lisp-transform)
-	  (setf (fdefinition ',name)
-		(make-operator-definition ',name))))
-    (cond
-     ((symbolp (car arg))
-      (push (car arg) argnames))
-     (t
-      (push (cons n (cadar arg)) arg-types) 
-      (push (caar arg) argnames)))))
-
-#-new-compiler
-(eval-when (compile)
-  (setq lisp::*bootstrap-defmacro* nil))
+(def-alien-type-method (boolean :unparse) (type)
+  `(boolean ,(alien-boolean-type-bits type)))
+
+(def-alien-type-method (boolean :lisp-rep) (type)
+  (declare (ignore type))
+  `(member t nil))
+
+(def-alien-type-method (boolean :naturalize-gen) (type alien)
+  (declare (ignore type))
+  `(not (zerop ,alien)))
+
+(def-alien-type-method (boolean :deport-gen) (value type)
+  (declare (ignore type))
+  `(if ,value 1 0))
 
 
-;;;; Alien allocation:
+;;;; The ENUM type.
+
+(def-alien-type-class (enum :include integer)
+  name		; name of this enum (if any)
+  from		; alist from keywords to integers.
+  to		; alist or vector from integers to keywords.
+  kind		; Kind of from mapping, :vector or :alist.
+  offset)	; Offset to add to value for :vector from mapping.
+
+(def-alien-type-translator enum (&whole type name &rest mappings)
+  (cond (mappings
+	 (let ((result (parse-enum name mappings)))
+	   (when name
+	     (multiple-value-bind
+		 (old old-p)
+		 (auxiliary-alien-type :enum name)
+	       (when old-p
+		 (unless (alien-type-= result old)
+		   (warn "Redefining alien enum ~S" name))))
+	     (setf (auxiliary-alien-type :enum name) result))
+	   result))
+	(name
+	 (multiple-value-bind
+	     (result found)
+	     (auxiliary-alien-type :enum name)
+	   (unless found
+	     (error "Unknown enum type: ~S" name))
+	   result))
+	(t
+	 (error "Empty enum type: ~S" type))))
+
+(defun parse-enum (name elements)
+  (when (null elements)
+    (error "An anumeration must contain at least one element."))
+  (let ((min nil)
+	(max nil)
+	(from-alist ())
+	(prev -1))
+    (declare (list from-alist))
+    (dolist (el elements)
+      (multiple-value-bind
+	  (sym val)
+	  (if (listp el)
+	      (values (first el) (second el))
+	      (values el (1+ prev)))
+	(setf prev val)
+	(unless (keywordp sym)
+	  (error "Enumeration element ~S is not a keyword." sym))
+	(unless (integerp val)
+	  (error "Element value ~S is not an integer." val))
+	(unless (and max (> max val)) (setq max val))
+	(unless (and min (< min val)) (setq min val))
+	(when (rassoc val from-alist)
+	  (error "Element value ~S used more than once." val))
+	(when (assoc sym from-alist :test #'eq)
+	  (error "Enumeration element ~S used more than once." sym))
+	(push (cons sym val) from-alist)))
+    (let* ((signed (minusp min))
+	   (min-bits (if signed
+			 (1+ (max (integer-length min)
+				  (integer-length max)))
+			 (integer-length max)))
+	   (bits (max 8 (ash 1 (integer-length (1- min-bits))))))
+      (when (> bits 32)
+	(error "Can't represent enums needing more than 32 bits."))
+      (cond
+       ;;
+       ;; If range is at least 20% dense, use vector mapping.  Crossover
+       ;; point solely on basis of space would be 25%.  Vector mapping
+       ;; is always faster, so give the benefit of the doubt.
+       ((< 0.2 (/ (float (length from-alist)) (float (- max min))))
+	;;
+	;; If offset is small and ignorable, ignore it to save time.
+	(when (< 0 min 10) (setq min 0))
+	(let ((to (make-array (1+ (- max min)))))
+	  (dolist (el from-alist)
+	    (setf (svref to (- (cdr el) min)) (car el)))
+	  (make-alien-enum-type :name name :bits bits :signed signed
+				:from from-alist :to to :kind
+				:vector :offset (- min))))
+       (t
+	(make-alien-enum-type :name name :bits bits :signed signed
+			      :from from-alist
+			      :to (mapcar #'(lambda (x) (cons (cdr x) (car x)))
+					  from-alist)
+			      :kind :alist))))))
+
+(def-alien-type-method (enum :unparse) (type)
+  `(enum ,(alien-enum-type-name type)
+	 ,@(let ((prev -1))
+	     (mapcar #'(lambda (mapping)
+			 (let ((sym (car mapping))
+			       (value (cdr mapping)))
+			   (prog1
+			       (if (= (1+ prev) value)
+				   sym
+				   `(,sym ,value))
+			     (setf prev value))))
+		     (alien-enum-type-from type)))))
+
+(def-alien-type-method (enum :type=) (type1 type2)
+  (and (eq (alien-enum-type-name type1)
+	   (alien-enum-type-name type2))
+       (equal (alien-enum-type-from type1)
+	      (alien-enum-type-from type2))))
+
+(def-alien-type-method (enum :lisp-rep) (type)
+  `(member ,@(mapcar #'car (alien-enum-type-from type))))
+
+(def-alien-type-method (enum :naturalize-gen) (type alien)
+  (ecase (alien-enum-type-kind type)
+    (:vector
+     `(svref ',(alien-enum-type-to type)
+	     (+ ,alien ,(alien-enum-type-offset type))))
+    (:alist
+     `(ecase ,alien
+	,@(mapcar #'(lambda (mapping)
+		      `(,(car mapping) ,(cdr mapping)))
+		  (alien-enum-type-to type))))))
+
+(def-alien-type-method (enum :deport-gen) (type value)
+  `(ecase ,value
+     ,@(mapcar #'(lambda (mapping)
+		   `(,(car mapping) ,(cdr mapping)))
+	       (alien-enum-type-from type))))
 
-;;;    In order to improve memory locality static alien values are allocated
-;;; contiguously in a pre-validated area at the beginning of system space.  We
-;;; keep a free pointer to the next word we can allocate.
-;;;
-#+new-compiler
-(defparameter system-space-start (int-sap #x80000000)
-  "The address of the first statically allocated alien.")
 
-#+new-compiler
-(defparameter alien-allocation-end (int-sap #x8fffffff)
-  "The end of statically allocated aliens.")
+
+;;;; the FLOAT types.
 
-#+new-compiler
-(defvar *current-alien-free-pointer* system-space-start
-  "The next word in system space for static alien allocation.")
+(def-alien-type-class (float)
+  (type (required-argument) :type symbol))
 
-;;; Allocate-Static-Alien  --  Internal
-;;;
-;;;    Allocate enough storage to hold the specified number of bits
-;;; and return the address.
-;;;
-#+new-compiler
-(defun allocate-static-alien (bits)
-  (declare (fixnum bits))
-  (let* ((alien *current-alien-free-pointer*)
-	 (bytes (logand (ash (the fixnum (+ bits alien-alignment -1))
-			     (- alien-address-shift))
-			(lognot (1- (truncate alien-alignment
-					      alien-address-unit)))))
-	 (new (sap+ *current-alien-free-pointer* bytes)))
-    (when (#-new-compiler %primitive pointer> new alien-allocation-end)
-      (error "Not enough room to allocate a ~D bit alien." bits))
-    (setq *current-alien-free-pointer* new)
-    alien))
+(def-alien-type-method (float :unparse) (type)
+  (alien-float-type-type type))
 
+(def-alien-type-method (float :lisp-rep) (type)
+  (alien-float-type-type type))
 
-;;; ALLOCATE-SYSTEM-MEMORY -- public
-;;;
-;;; Allocate random memory from the system area.
-;;; 
-(defun allocate-system-memory (bytes)
-  (declare (type index bytes))
-  (gr-call* mach:vm_allocate *task-self* (int-sap 0) bytes t))
+(def-alien-type-method (float :alien-rep) (type)
+  (alien-float-type-type type))
 
-;;; REALLOCATE-SYSTEM-MEMORY -- public
-;;;
-;;; Either allocate more memory at the end of this block, or allocate a new
-;;; block and move the old memory into it.
-;;; 
-(defun reallocate-system-memory (old old-size new-size)
-  (declare (type system-area-pointer old)
-	   (type index old-size new-size))
-  ;; ### Got to work the page size into this somehow.  The vm_allocate
-  ;; will fail much more often than it otherwise would 'cause if the old
-  ;; block stops in the middle of a page, we can't extend it.
-  (if (eql (mach:vm_allocate *task-self*
-			     (sap+ old old-size)
-			     (- new-size old-size)
-			     nil)
-	   mach:kern-success)
-      old
-      (let ((new (allocate-system-memory new-size)))
-	(declare (type system-area-pointer new))
-	(system-area-copy old 0 new 0 (* old-size vm:byte-bits))
-	(deallocate-system-memory old old-size)
-	new)))
-
-;;; DEALLOCATE-SYSTEM-MEMORY -- public
-;;;
-;;; Deallocate that memory.
-;;; 
-(defun deallocate-system-memory (addr bytes)
-  (declare (type system-area-pointer addr)
-	   (type index bytes))
-  (gr-call* mach:vm_deallocate *task-self* addr bytes))
+(def-alien-type-method (float :naturalize-gen) (type alien)
+  (declare (ignore type))
+  alien)
 
+(def-alien-type-method (float :deport-gen) (type value)
+  (declare (ignore type))
+  value)
 
-;;; Make-Alien  --  Public
-;;;
-;;;    Create an Alien value structure, validating memory to hold the data
-;;; if necessary.  We convert the rational address into a word address +
-;;; bit offset.
-;;;
-(defun make-alien (type size &optional (address :dynamic))
-  "Return an Alien value of the specified Type, whose size is Size bits.
-  Address is the word address of the value to create, if this is not
-  supplied then memory is allocated to contain the data."
-  (case address
-    (:dynamic
-     (setq address (allocate-system-memory (ash size (- alien-address-shift)))))
-    (:static
-     (setq address (allocate-static-alien size)))
-    (t
-     (check-type address (or #+new-compiler system-area-pointer
-			     (rational 0)))))
-  (check-type size (integer 0))
-  (if (numberp address)
-      (multiple-value-bind (base frac) (truncate address)
-	(let ((offset (* frac alien-address-unit)))
-	  (unless (integerp frac)
-	    (error "Address ~S does not fall on a bit position." address))
-	  (make-alien-value (int-sap base) offset size type)))
-      (make-alien-value address 0 size type)))
-
-
-;;; Copy-Alien  --  Public
-;;;
-;;;   Validate some memory and byte-blt the contents to it.  Since we just move
-;;; words we preserve a nonzero bit-offset when it might be desirable to
-;;; eliminate it, but that is more trouble than it is worth, since non-aligned
-;;; fields are probably rarely copied.
-;;;
-(defun copy-alien (alien)
-  "Copy the storage pointed to by Alien and return a new alien value that
-  describes it."
-  (check-type alien alien-value)
-  (let* ((offset (alien-value-offset alien))
-	 (length (alien-value-size alien))
-	 (bytes (ash (+ length offset alien-alignment -1)
-		     (- alien-address-shift)))
-	 (new (allocate-system-memory bytes)))
-    (%primitive byte-blt
-		(alien-value-sap alien) (ash offset (- alien-address-shift))
-		new 0 bytes)
-    (make-alien-value new offset length (alien-value-type alien))))
-
-
-;;; Dispose-Alien  --  Public
-;;;
-;;;    Invalidate the memory pointed to by unless it is a statically
-;;; allocated alien.
-;;;
-#+new-compiler
-(defun dispose-alien (alien)
-  "Release the storage allocated for Alien."
-  (check-type alien alien-value)
-  (let ((address (alien-value-sap alien)))
-    (unless (not (or (pointer< address system-space-start)
-		     (pointer> address alien-allocation-end)))
-      (gr-call mach:vm_deallocate *task-self* address
-	       (logand #x-200 (ash (+ (alien-value-size alien) #xFFF)
-				   (- alien-address-shift)))))))
 
-
-;;;; Operator definition primitives:
+(def-alien-type-class (single-float :include float))
+
+(def-alien-type-translator single-float ()
+  (make-alien-single-float-type :type 'single-float))
+
+(def-alien-type-method (single-float :extract-gen) (type sap offset)
+  (declare (ignore type))
+  `(sap-ref-single ,sap (/ ,offset vm:word-bits)))
+
+
+(def-alien-type-class (double-float :include float))
+
+(def-alien-type-translator double-float ()
+  (make-alien-double-float-type :type 'double-float))
+
+(def-alien-type-method (double-float :extract-gen) (type sap offset)
+  (declare (ignore type))
+  `(sap-ref-double ,sap (/ ,offset vm:word-bits)))
 
-;;; Alien-Index  --  Public
-;;;
-;;;    Check that the selected field fits within the Alien, and add it
-;;; in if it does.
-;;;
-(defun alien-index (alien offset size)
-  "Return a new Alien value that is Offset bits within Alien, and is
-  Size bits long."
-  (check-type alien alien-value)
-  (check-type offset (integer 0))
-  (check-type size (integer 0))
-  (when (> (+ offset size) (alien-value-size alien))
-    (error "~S is too small to extract a ~A bit field at ~A."
-	   alien size offset))
-  (multiple-value-bind (words bits)
-		       (truncate (+ offset (alien-value-offset alien))
-				 alien-alignment)
-    (make-alien-value
-     (int-sap (+ (* words (/ alien-alignment alien-address-unit))
-		 (sap-int (alien-value-sap alien))))
-     bits
-     size
-     nil)))
-
-;;; Alien-Indirect  --  Public
-;;;
-;;;    Check that Alien is word-aligned and 32 bits long.  If it is, grab
-;;; the value.  Check that the value falls within the system area.  If
-;;; it does then make a new Alien-Value out of it.
-;;;
-(defun alien-indirect (alien size)
-  "Return a new Alien value that points to what the value of Alien points to
-  which is Size bits long."
-  (check-type alien alien-value)
-  (check-type size (integer 0))
-  (unless (= (alien-value-size alien) 32)
-    (error "~S is not thirty-two bits long." alien))
-  (unless (zerop (alien-value-offset alien))
-    (error "~S is not word aligned."))
-  (let* ((sap (alien-value-sap alien))
-	 (value (sap-ref-sap sap 0)))
-#|
-    (unless (<= system-space-start value most-positive-fixnum)
-      (error "The value of ~S, #x~X, does not point into system space."
-	     alien value))
-|#
-    (make-alien-value value 0 size nil)))
-
-
-;;; Bits, Bytes, Words, Long-Words  --  Public
-;;;
-;;;
-(eval-when (compile eval)
-(defmacro def-words-frob (name n)
-  `(progn
-     (proclaim '(inline ,name))
-     (defun ,name (n)
-       (declare (type (integer 0 ,(truncate most-positive-fixnum n))
-		      n))
-       (* n ,n)))))
-(def-words-frob bits 1)
-(def-words-frob bytes 8)
-(def-words-frob words 16)
-(def-words-frob long-words 32)
 
 
-;;;; General case versions of compiler internal functions:
+;;;; The SAP type
 
-;;; %Alien-Indirect  --  Internal
-;;;
-;;;    Alien-Indirect is transformed into this.  Calls can take place at
-;;; run-time when the operation can't be proven safe at compile time.
-;;;
-(defun %alien-indirect (size sap offset exp)
-  (unless (eql size 32)
-    (error "Argument to Alien-Indirect is ~D bits, not 32:~% ~S." size exp))
-  (unless (zerop (logand offset #x1F))
-    (error "Offset ~D to Alien-Indirect is not long-word-aligned:~% ~S."
-	   offset exp))
-  (sap-ref-sap sap (ash offset -5)))
+(def-alien-type-class (sap))
 
+(def-alien-type-translator system-area-pointer ()
+  (make-alien-sap-type :bits vm:word-bits))
 
-;;; %Aligned-SAP  --  Internal
-;;;
-;;;    Various things transform into this when the alien is declared to be
-;;; aligned.  In this case, we absorb the offset into the SAP, and make the
-;;; bound offset 0.
-;;;
-#+new-compiler
-(defun %aligned-sap (sap offset form)
-  (unless (zerop (logand offset #x1F))
-    (error "Offset ~S was declared to be word aligned, but isn't:~% ~S"
-	   offset form))
-  (sap+ sap (ash offset (- alien-address-unit))))
-
-#+new-compiler
-;;; Naturalize-Integer  --  Internal
-;;;
-;;;    Read a possibly signed integer somewhere.
-;;;
-(defun naturalize-integer (signed sap offset size form)
-  (declare (type boolean signed)
-	   (type system-area-pointer sap)
-	   (type index offset size))
-  (let ((bit-offset (logand offset #x1f)))
-    (cond
-     ((and (= size 32) (zerop bit-offset))
-      (if signed
-	  (signed-sap-ref-32 sap (ash offset -5))
-	  (sap-ref-32 sap (ash offset -5))))
-     ((and (= size 16) (zerop (logand offset #xf)))
-      (if signed
-	  (signed-sap-ref-16 sap (ash offset -4))
-	  (sap-ref-16 sap (ash offset -4))))
-     ((and (= size 8) (zerop (logand offset #x7)))
-      (if signed
-	  (signed-sap-ref-8 sap (ash offset -3))
-	  (sap-ref-8 sap (ash offset -3))))
-     ((> size 32)
-      (error "Access of ~D bit integers is not supported:~% ~S" size form))
-     ((zerop bit-offset)
-      (let ((value (ldb (byte size 0) (sap-ref-32 sap (ash offset -5)))))
-	(if (and signed (logbitp value (1- size)))
-	    (logior value (ash -1 size))
-	    value)))
-     ((<= (+ size bit-offset) 32)
-      (let ((value (ldb (byte size bit-offset)
-			(sap-ref-32 sap (ash offset -5)))))
-	(if (and signed (logbitp value (1- size)))
-	    (logior value (ash -1 size))
-	    value)))
-     (t
-      (macrolet ((low-byte ()
-			   (ecase (c:backend-byte-order c:*backend*)
-			     (:little-endian 'offset)
-			     (:big-endian '(1+ offset))))
-		 (high-byte ()
-			    (ecase (c:backend-byte-order c:*backend*)
-			      (:little-endian '(1+ offset))
-			      (:big-endian 'offset))))
-	(let* ((high-bits (- 32 bit-offset))
-	       (low-bits (- size high-bits))
-	       (value (logior (ash (ldb (byte high-bits 0)
-					(sap-ref-32 sap (high-byte)))
-				   low-bits)
-			      (ash (sap-ref-32 sap (low-byte))
-				   (- (- 32 low-bits))))))
-	  (if (and signed (logbitp value (1- size)))
-	      (logior value (ash -1 size))
-	      value)))))))
-
-
-#+new-compiler
-;;; Deport-Integer  --  Internal
-;;;
-;;;    Like Naturalize-Integer, but writes an integer.
-;;;
-(defun deport-integer (signed sap offset size value form)
-  (declare (type boolean signed)
-	   (type system-area-pointer sap)
-	   (type index offset size)
-	   (type integer value))
-  (declare (ignore signed))
-  (multiple-value-bind (q r) (truncate offset 32)
-    (declare (fixnum r))
-    (cond
-     ((and (= size 32) (zerop r))
-      (setf (sap-ref-32 sap q) value))
-     ((and (= size 16) (zerop (logand r #xf)))
-      (setf (sap-ref-16 sap (ash offset -4)) value))
-     ((and (= size 8) (zerop (logand r #x7)))
-      (setf (sap-ref-8 sap (ash offset -3)) value))
-     ((> size 32)
-      (error "Storing of ~D bit integers is not supported:~% ~S"
-	     size form))
-     ((zerop r)
-      (setf (ldb (byte size 0) (sap-ref-32 sap q)) value))
-     ((<= (+ r size) 32)
-      (setf (ldb (byte size r) (sap-ref-32 sap q)) value))
-     (t
-      (macrolet ((low-byte ()
-			   (ecase (c:backend-byte-order c:*backend*)
-			     (:little-endian 'offset)
-			     (:big-endian '(1+ offset))))
-		 (high-byte ()
-			    (ecase (c:backend-byte-order c:*backend*)
-			      (:little-endian '(1+ offset))
-			      (:big-endian 'offset))))
-	(let* ((high-bits (- 32 r))
-	       (low-bits (- size high-bits)))
-	  (setf (ldb (byte high-bits 0)
-		     (sap-ref-32 sap (high-byte)))
-		(ash value (- low-bits)))
-	  (setf (ldb (byte low-bits (- 32 low-bits))
-		     (sap-ref-32 sap (low-byte)))
-		value))))))
-  nil)
+(def-alien-type-method (sap :unparse) (type)
+  (declare (ignore type))
+  'system-area-pointer)
 
+(def-alien-type-method (sap :lisp-rep) (type)
+  (declare (ignore type))
+  'system-area-pointer)
 
-;;; Naturalize and Deport Boolean  --  Internal
-;;;
-;;;    Handle the general case of boolean access.  The transforms
-;;; should pick off the normal cases.
-;;;
-#+new-compiler
-(defun naturalize-boolean (sap offset size form)
-  (declare (type system-area-pointer sap)
-	   (type index offset size))
-  (declare (notinline naturalize-integer))
-  (not (zerop (naturalize-integer nil sap offset size form))))
-;;;
-#+new-compiler
-(defun deport-boolean (sap offset size value form)
-  (declare (type system-area-pointer sap)
-	   (type index offset size)
-	   (type boolean value))
-  (declare (notinline deport-integer))
-  (deport-integer nil sap offset size (if value 1 0) form)
+(def-alien-type-method (sap :alien-rep) (type)
+  (declare (ignore type))
+  'system-area-pointer)
+
+(def-alien-type-method (sap :naturalize-gen) (type alien)
+  (declare (ignore type))
+  alien)
+
+(def-alien-type-method (sap :deport-gen) (type object)
+  (declare (ignore type))
+  object)
+
+(def-alien-type-method (sap :extract-gen) (type sap offset)
+  (declare (ignore type))
+  `(sap-ref-sap ,sap (/ ,offset vm:word-bits)))
+
+
+;;;; the ALIEN-VALUE type.
+
+(def-alien-type-class (alien-value :include sap))
+
+(def-alien-type-method (alien-value :lisp-rep) (type)
+  (declare (ignore type))
   nil)
 
-;;; Check<=, Check=  --  Internal
-;;;
-;;;    Interpreter stubs for functions normally open-coded.  Note that the
-;;; compiler will constant-fold these, possibly producing an error at compile
-;;; time.
-;;;
-(defun check<=  (x y) (check<= x y))
-(defun check= (x y)
-  #|
-  (check= x y)
-  |#
-  ;### Bootstrap hack:
-  (unless (and (fixnump x) (>= x 0)
-	       (fixnump y) (>= y 0)
-	       (= x y))
-    (error "Not ~S not = to ~S at compile time." x y)))
+(def-alien-type-method (alien-value :naturalize-gen) (type alien)
+  `(%sap-alien ,alien ',type))
+
+(def-alien-type-method (alien-value :deport-gen) (type value)
+  (declare (ignore type))
+  `(alien-sap ,value))
+
 
 
-;;;; Utility functions used by macros and special forms:
+;;;; The POINTER type.
+
+(def-alien-type-class (pointer :include (alien-value (:bits vm:word-bits)))
+  (to nil :type (or alien-type null)))
+
+(def-alien-type-translator * (to)
+  (make-alien-pointer-type :to (if (eq to t) nil (parse-alien-type to))))
+
+(def-alien-type-method (pointer :unparse) (type)
+  (let ((to (alien-pointer-type-to type)))
+    `(* ,(if to
+	     (%unparse-alien-type to)
+	     t))))
+
+(def-alien-type-method (pointer :type=) (type1 type2)
+  (let ((to1 (alien-pointer-type-to type1))
+	(to2 (alien-pointer-type-to type2)))
+    (if to1
+	(if to2
+	    (alien-type-= to1 to2)
+	    nil)
+	(null to2))))
+
+(def-alien-type-method (pointer :deport-gen) (type value)
+  (values
+   `(etypecase ,value
+      (null
+       (int-sap 0))
+      (system-area-pointer
+       ,value)
+      ((alien ,type)
+       (alien-sap ,value)))
+   `(or null system-area-pointer (alien ,type))))
 
-;;; Check-Alien-Type  --  Internal
-;;;
-;;;    Check that Alien is of the specified Alien type, and give an
-;;; error if it is not. 
-;;;
-(defun check-alien-type (alien type)
-  (unless (alien-value-p alien)
-    (error "~S is not an Alien value." alien))
-  (unless (equal (alien-value-type alien) type)
-    (error "Wrong Alien type ~S, should have been of type ~S."
-	   (alien-value-type alien) type))
-  alien)
+
+;;;; The MEM-BLOCK type.
 
+(def-alien-type-class (mem-block :include alien-value))
 
-;;; Assert-Alien-Type  --  Internal
-;;;
-;;;    Make a new Alien value having the specified type.
-;;;
-(defun assert-alien-type (alien type)
-  (unless (alien-value-p alien)
-    (error "~S is not an Alien value." alien))
-  (make-alien-value (alien-value-sap alien)
-		    (alien-value-offset alien)
-		    (alien-value-size alien)
-		    type))
+(def-alien-type-method (mem-block :extract-gen) (type sap offset)
+  (declare (ignore type))
+  `(sap+ ,sap (/ ,offset vm:byte-bits)))
 
+(def-alien-type-method (mem-block :deposit-gen) (type sap offset value)
+  (let ((bits (alien-mem-block-type-bits type)))
+    (unless bits
+      (error "Cannot deposit aliens of type ~S (unknown size)." type))
+    `(kernel:system-area-copy ,value 0 ,sap ,offset ',bits)))
+
+
+;;;; The ARRAY type.
+
+(def-alien-type-class (array :include mem-block)
+  (element-type (required-argument) :type alien-type)
+  (dimensions (required-argument) :type list))
+
+(def-alien-type-translator array (ele-type &rest dims) 
+  (let ((type (parse-alien-type ele-type)))
+    (make-alien-array-type
+     :element-type type
+     :dimensions dims
+     :alignment (alien-type-alignment type)
+     :bits (if (and (alien-type-bits type)
+		    (every #'integerp dims))
+	       (* (align-offset (alien-type-bits type)
+				(alien-type-alignment type))
+		  (reduce #'* dims))))))
+
+(def-alien-type-method (array :unparse) (type)
+  `(array ,(%unparse-alien-type (alien-array-type-element-type type))
+	  ,@(alien-array-type-dimensions type)))
+
+(def-alien-type-method (array :type=) (type1 type2)
+  (and (equal (alien-array-type-dimensions type1)
+	      (alien-array-type-dimensions type2))
+       (alien-type-= (alien-array-type-element-type type1)
+		     (alien-array-type-element-type type2))))
 
-;;; MAKE-OPERATOR-DEFINITION  --  Internal
-;;;
-;;;    To save space and load & compile time for defoperators, we don't
-;;; actually generate the function for the operator until it is called.  This
-;;; function returns a closure that, when called, computes the definition and
-;;; installs as the definition of Name.  This results in a significant space
-;;; savings at the cost of always running the operator definition interpreted
-;;; when called that way.
-;;;
-(defun make-operator-definition (name)
-  #'(lambda (&rest actual-args)
-      (let ((info (info function alien-operator name)))
-	(unless info
-	  (error "Operator ~S has no Alien-Operator-Info property."))
-	(let ((num-args (alien-info-num-args info))
-	      (arg-types (alien-info-arg-types info)))
-	  (collect ((args)
-		    (binds))
-	    (dotimes (i num-args)
-	      (let ((type (assoc i arg-types))
-		    (sym (gensym)))
-		(args sym)
-		(when type
-		  (binds `(,sym ,sym ,(cdr type))))))
-
-	    (let ((res (coerce `(lambda ,(args)
-				  (alien-bind ,(binds)
-				    (assert-alien-type
-				     ,(apply (alien-info-function info) (args))
-				     ',(alien-info-result-type info))))
-			       'function)))
-	      (setf (fdefinition name) res)
-	      (apply res actual-args)))))))
 
 
-;;;; Alien access method definition:
-;;;
-;;;    We describe how to access and store at an Alien's address in
-;;; a way that permits the same code to be use both for the compiler
-;;; and the interpreter.  What we do is have experts that ask things
-;;; about the alien value and return a piece of code to do the access.
-;;;
-;;;
-(defvar *alien-access-table* (make-hash-table :test #'eq)
-  "Hashtable from lisp types to Alien access functions.")
-(defvar *alien-only-access-table* (make-hash-table :test #'eq)
-  "Hashtable from alien types to Alien access functions.")
-(defvar *alien-to-lisp-types* (make-hash-table :test #'eq)
-  "Hashtable we use to tell whether there is a unique lisp-type
-   for a given alien-type.")
+;;;; The RECORD type.
+
+(defstruct (alien-record-field
+	    (:print-function %print-alien-field)
+	    (:make-load-form-fun :just-dump-it-normally))
+  (name (required-argument) :type symbol)
+  (type (required-argument) :type alien-type)
+  (bits nil :type (or unsigned-byte null))
+  (offset 0 :type unsigned-byte))
+
+(defun %print-alien-field (field stream depth)
+  (declare (ignore depth))
+  (print-unreadable-object (field stream :type t)
+    (funcall (formatter "~S ~S~@[:~D~]")
+	     stream
+	     (alien-record-field-type field)
+	     (alien-record-field-name field)
+	     (alien-record-field-bits field))))
+
+(def-alien-type-class (record :include mem-block)
+  (kind :struct :type (member :struct :union))
+  (name nil :type (or symbol null))
+  (fields nil :type list))
+
+(def-alien-type-translator struct (name &rest fields)
+  (parse-alien-record-type :struct name fields))
+
+(def-alien-type-translator union (name &rest fields)
+  (parse-alien-record-type :union name fields))
+
+(defun parse-alien-record-type (kind name fields)
+  (let ((result
+	 (if name
+	     (or (auxiliary-alien-type kind name)
+		 (setf (auxiliary-alien-type kind name)
+		       (make-alien-record-type :name name :kind kind)))
+	     (make-alien-record-type :kind kind))))
+    (when fields
+      (parse-alien-record-fields result fields))
+    result))
+
+;;; PARSE-ALIEN-RECORD-FIELDS -- internal
+;;;
+;;; Used by parse-alien-type to parse the fields of struct and union
+;;; types.  RESULT holds the record type we are paring the fields of,
+;;; and FIELDS is the list of field specifications.
+;;; 
+(defun parse-alien-record-fields (result fields)
+  (declare (type alien-record-type result)
+	   (type list fields))
+  (let ((total-bits 0)
+	(overall-alignment 1)
+	(parsed-fields nil))
+    (dolist (field fields)
+      (destructuring-bind (var type &optional bits) field
+	(declare (ignore bits))
+	(let* ((field-type (parse-alien-type type))
+	       (bits (alien-type-bits field-type))
+	       (alignment (alien-type-alignment field-type))
+	       (parsed-field
+		(make-alien-record-field :type field-type
+					 :name var)))
+	  (push parsed-field parsed-fields)
+	  (when (null bits)
+	    (error "Unknown size: ~S"
+		   (unparse-alien-type field-type)))
+	  (when (null alignment)
+	    (error "Unknown alignment: ~S"
+		   (unparse-alien-type field-type)))
+	  (setf overall-alignment (max overall-alignment alignment))
+	  (ecase (alien-record-type-kind result)
+	    (:struct
+	     (let ((offset (align-offset total-bits alignment)))
+	       (setf (alien-record-field-offset parsed-field) offset)
+	       (setf total-bits (+ offset bits))))
+	    (:union
+	     (setf total-bits (max total-bits bits)))))))
+    (let ((new (nreverse parsed-fields)))
+      (unless (record-fields-match (alien-record-type-fields result) new)
+	(setf (alien-record-type-fields result) new)))
+    (setf (alien-record-type-alignment result) overall-alignment)
+    (setf (alien-record-type-bits result)
+	  (align-offset total-bits overall-alignment))))
+
+(def-alien-type-method (record :unparse) (type)
+  `(,(case (alien-record-type-kind type)
+       (:struct 'struct)
+       (:union 'union)
+       (t '???))
+    ,(alien-record-type-name type)
+    ,@(unless (member type *record-types-already-unparsed* :test #'eq)
+	(push type *record-types-already-unparsed*)
+	(mapcar #'(lambda (field)
+		    `(,(alien-record-field-name field)
+		      ,(%unparse-alien-type (alien-record-field-type field))
+		      ,@(if (alien-record-field-bits field)
+			    (list (alien-record-field-bits field)))))
+		(alien-record-type-fields type)))))
+
+(defun record-fields-match (fields1 fields2)
+  (declare (type list fields1 fields2))
+  (or (eq fields1 fields2)
+      (and fields1
+	   fields2
+	   (let ((field1 (car fields1))
+		 (field2 (car fields2)))
+	     (declare (type alien-record-field field1 field2))
+	     (and (eq (alien-record-field-name field1)
+		      (alien-record-field-name field2))
+		  (eql (alien-record-field-bits field1)
+		       (alien-record-field-bits field2))
+		  (eql (alien-record-field-offset field1)
+		       (alien-record-field-offset field2))
+		  (alien-type-= (alien-record-field-type field1)
+				(alien-record-field-type field2))))
+	   (record-fields-match (cdr fields1) (cdr fields2)))))
+
+(def-alien-type-method (record :type=) (type1 type2)
+  (and (eq (alien-record-type-name type1)
+	   (alien-record-type-name type2))
+       (eq (alien-record-type-kind type1)
+	   (alien-record-type-kind type2))
+       (= (length (alien-record-type-fields type1))
+	  (length (alien-record-type-fields type2)))
+       (record-fields-match (alien-record-type-fields type1)
+			    (alien-record-type-fields type2))))
 
-(defmacro mostcar (x)
-  `(if (listp ,x) (car ,x) ,x))
+
+;;;; The FUNCTION and VALUES types.
 
+(defvar *values-type-okay* nil)
 
-;;; %Define-Alien-Access  --  Internal
-;;;
-(defun %define-alien-access (lisp-type atypes fun)
-  (dolist (type atypes)
-    (let ((res (gethash type *alien-to-lisp-types*)))
-      (cond ((not res)
-	     (setf (gethash type *alien-to-lisp-types*) lisp-type))
-	    ((eq res lisp-type))
-	    (t
-	     (setf (gethash type *alien-to-lisp-types*) '%conflict%))))
+(def-alien-type-class (function :include mem-block)
+  (result-type (required-argument) :type alien-type)
+  (arg-types (required-argument) :type list)
+  (stub nil :type (or null function)))
 
-    (setf (gethash type *alien-only-access-table*) fun)
-    (setf (gethash lisp-type *alien-access-table*) fun)))
+(def-alien-type-translator function (result-type &rest arg-types)
+  (make-alien-function-type
+   :result-type (let ((*values-type-okay* t))
+		  (parse-alien-type result-type))
+   :arg-types (mapcar #'parse-alien-type arg-types)))
 
+(def-alien-type-method (function :unparse) (type)
+  `(function ,(%unparse-alien-type (alien-function-type-result-type type))
+	     ,@(mapcar #'%unparse-alien-type
+		       (alien-function-type-arg-types type))))
 
-;;; Get-Alien-Access-Method  --  Internal
-;;;
-;;;    Returns the alien-access method corresponding to Alien-Type and
-;;; Lisp-Type or dies trying.
-;;;
-(defun get-alien-access-method (alien-type lisp-type)
-  (let* ((alien-type (mostcar alien-type))
-	 (lisp-type (mostcar lisp-type))
-	 (unique? (gethash alien-type *alien-to-lisp-types*)))
-    (cond
-     ((not unique?)
-      (error "Alien type ~S does not correspond to any Lisp type." alien-type))
-     ((and (null lisp-type)
-	   (not (eq unique? '%conflict%))
-	   (gethash alien-type *alien-only-access-table*)))
-     ((not (eq unique? '%conflict%))
-      (gethash unique? *alien-access-table*))
-     ((not lisp-type)
-      (error "Lisp-Type must be specified with Alien type ~S." alien-type))
-     ((gethash lisp-type *alien-access-table*))
-     (t
-      (error "~S is not a Lisp-Type known to Alien-Access."
-	     lisp-type)))))
-
-
-;;; Define-Alien-Access  --  Internal
-;;;
-(defmacro define-alien-access ((lisp-type &optional (atype lisp-type)
-					  &rest more-types)
-			       (alien-var kind-var value-var
-					  &optional
-					  (source-var (gensym) source-p))
-			       &body body)
-  "Define-Alien-Access (Lisp-Type {Alien-Type}*) (Alien-Var Kind-Var Value-Var)
-		       {form}*
-
-  Define a new type for Alien-Access.  When Alien-Access is given the specified
-  Lisp-Type and the alien is one of the specified Alien-Types, then body will
-  be evaluated to get an expression that does the the appropriate access/store.
-  If no Alien-Type is supplied, then the accepted Alien type is Lisp-Type.  If
-  the type of the Alien is a list, then we use the car as the type.
-
-  Alien-Var
-      Bound to the Alien type of the Alien value to access.
-
-  Kind-Var
-      Bound to :read or :write, indicating whether to read or store a value.
-
-  Value-Var
-      When Kind-Var is :write, this is bound to an expression to evaluate to
-      obtain the value to be stored.
-
-  Source-Var
-      If specified, this is bound to the original Alien-Access form
-      (for use in error messages.)
-
-  In order to obtain the Alien value at which the access is to be done, the
-  local With-Alien macro should be used:
-
-  With-Alien (Sap-Var) (Offset-Var {Key Value}*) (Size-Var {Key Value}*)
-              {Form}*
-  This macro is for use within the body of a Define-Alien-Access.  It
-  analyzes and verifies assertions on the alien value to be accessed.
-  Sap-Var, Offset-Var and Size-Var are bound to expressions for the
-  system-area-pointer to the value, the offset from it in bits and
-  the size of the Alien in bits.
-
-  The keyword arguments for the offset and size may be used to place
-  constraints on the values they may assume.  If the value
-  is Nil, that is taken to be a null constraint.  The following
-  keys are defined:
-   :unit      -- A integer (default 32).
-		 Asserts that the value is a multiple of this number, and
-		 that the value is to be divided by this number before any
-		 other options are processed.
-   :constant  -- An integer (default Nil).
-		 Asserts that the value must be exactly the supplied value.
-   :minimum   -- An integer (default Nil).
-		 Asserts that the value may not be less than the supplied
-		 value.
-
-  The value of With-Alien is the value of the last form."
-
-  (let ((n-sap (gensym))
-	(n-offset (gensym))
-	(n-size (gensym)))
-    `(progn
-       (%define-alien-access
-	',lisp-type '(,atype ,@more-types)
-	#'(lambda (,n-sap ,n-offset ,n-size ,alien-var ,kind-var ,value-var
-			  ,source-var)
-	    ,@(unless source-p
-		`((declare (ignore ,source-var))))
-	    
-	    (unless (member (mostcar ,alien-var) '(,atype ,@more-types)
-			    :test #'eq)
-	      (error "Wrong Alien type ~S, should have been ~S~
-	      ~{~#[~; or~:;,~] ~S~}."
-		     ,alien-var ',atype ',more-types))
-	    
-	    (macrolet ((with-alien ((sap)
-				    (offset &key
-					    ((:unit ounit) 32))
-				    (size &key
-					  ((:constant sconst) nil)
-					  ((:minimum smin) nil)
-					  ((:unit sunit) 32))
-				    &body (body decls))
-			 (%with-alien sap offset ounit
-				      size sconst smin sunit
-				      ',n-sap ',n-offset ',n-size
-				      body decls)))
-	      ,@body)))
-       #-new-compiler
-       (eval-when (compile)
-	 (clc::clc-mumble "alien-access ~S compiled.~%" ',lisp-type)))))
+(def-alien-type-method (function :type=) (type1 type2)
+  (and (alien-type-= (alien-function-type-result-type type1)
+		     (alien-function-type-result-type type2))
+       (= (length (alien-function-type-arg-types type1))
+	  (length (alien-function-type-arg-types type2)))
+       (every #'alien-type-p
+	      (alien-function-type-arg-types type1)
+	      (alien-function-type-arg-types type2))))
 
 
-(eval-when (compile load eval)
 
-(defun %with-alien (sap offset ounit size sconst smin sunit
-			n-sap n-offset n-size body decls)
-  (let ((sunit (or sunit 1))
-	(ounit (or ounit 1))
-	(n-scaled-offset (gensym))
-	(n-scaled-size (gensym)))
-    `(let ((,sap ,n-sap)
-	   (,offset ',n-scaled-offset)
-	   (,size ',n-scaled-size))
-       ,@decls
-       `(let ((,',n-scaled-offset (/ ,,n-offset ,,ounit))
-	      (,',n-scaled-size (/ ,,n-size ,,sunit)))
-	  ,',n-scaled-size ; Ignorable...
-	  ,,@(when sconst
-	       `(`(check= ,',n-scaled-size ,,sconst)))
-	  ,,@(when smin
-	       `(`(check<= ,,smin ,',n-scaled-size)))
-	  ,,@body))))
-
-); Eval-When (Compile Load Eval)
+(def-alien-type-class (values)
+  (values (required-argument) :type list))
+
+(def-alien-type-translator values (&rest values)
+  (unless *values-type-okay*
+    (error "Cannot use values types here."))
+  (let ((*values-type-okay* nil))
+    (make-alien-values-type
+     :values (mapcar #'parse-alien-type values))))
+
+(def-alien-type-method (values :unparse) (type)
+  `(values ,@(mapcar #'%unparse-alien-type
+		     (alien-values-type-values type))))
+
+(def-alien-type-method (values :type=) (type1 type2)
+  (and (= (length (alien-values-type-values type1))
+	  (length (alien-values-type-values type2)))
+       (every #'alien-type-=
+	      (alien-values-type-values type1)
+	      (alien-values-type-values type2))))
+
 
 
-;;; Alien-Access  --  Public
+;;;; Alien variables.
+
+;;; HEAP-ALIEN-INFO -- defstruct.
 ;;;
-;;;    This is only called when we can't open-code because the types aren't
-;;; constant (or are erroneous.)  In this case, we must look up the access
-;;; method at run-time, compute the access form, then eval it.
+;;; Information describing a heap-allocated alien.
+;;; 
+(defstruct (heap-alien-info
+	    (:print-function %print-heap-alien-info)
+	    (:make-load-form-fun :just-dump-it-normally))
+  ;; The type of this alien.
+  (type (required-argument) :type alien-type)
+  ;; The form to evaluate to produce the SAP pointing to where in the heap
+  ;; it is.
+  (sap-form (required-argument)))
+;;;
+(defun %print-heap-alien-info (info stream depth)
+  (declare (ignore depth))
+  (print-unreadable-object (info stream :type t)
+    (funcall (formatter "~S ~S")
+	     stream
+	     (heap-alien-info-sap-form info)
+	     (unparse-alien-type (heap-alien-info-type info)))))
+
+;;; LOCAL-ALIEN-INFO -- public defstruct.
+;;;
+;;; Information about local aliens.  The WITH-ALIEN macro builds one of these
+;;; structures and local-alien and friends comunicate information about how
+;;; that local alien is represented.
+;;; 
+(defstruct (local-alien-info
+	    (:print-function %print-local-alien-info)
+	    (:make-load-form-fun :just-dump-it-normally))
+  ;; The type of the local alien.
+  (type (required-argument) :type alien-type)
+  ;; T if this local alien must be forced into memory.  Using the ADDR macro
+  ;; on a local alien will set this.
+  (force-to-memory-p (or (alien-array-type-p type) (alien-record-type-p type))
+		     :type (member t nil)))
+;;;
+(defun %print-local-alien-info (info stream depth)
+  (declare (ignore depth))
+  (print-unreadable-object (info stream :type t)
+    (funcall (formatter "~:[~;(forced to stack) ~]~S")
+	     stream
+	     (local-alien-info-force-to-memory-p info)
+	     (unparse-alien-type (local-alien-info-type info)))))
+
+;;; GUESS-ALIEN-NAME-FROM-LISP-NAME -- internal.
+;;;
+;;; Make a string out of the symbol, converting all uppercase letters to
+;;; lower case and hyphens into underscores.
+;;; 
+(defun guess-alien-name-from-lisp-name (lisp-name)
+  (declare (type symbol lisp-name))
+  (nsubstitute #\_ #\- (string-downcase (symbol-name lisp-name))))
+
+;;; GUESS-LISP-NAME-FROM-ALIEN-NAME -- internal.
 ;;;
-(defun alien-access (alien &optional lisp-type)
-  "Converts the bits described by Alien into an object of type Lisp-Type,
-  or dies trying."
-  (declare (type alien-value alien))
-  (let* ((alien-type (alien-value-type alien))
-	 (access (get-alien-access-method alien-type lisp-type))
-	 (n-sap (gensym))
-	 (n-offset (gensym))
-	 (n-size (gensym)))
-    (eval
-     `(let ((,n-sap ',(alien-value-sap alien))
-	    (,n-offset ',(alien-value-offset alien))
-	    (,n-size ',(alien-value-size alien)))
-	,(funcall access n-sap n-offset n-size alien-type :read nil
-		  'alien-access)))))
-
-(defsetf alien-access %set-alien-access
-  "Stores the representation of the value into the alien.")
-
-;;; %Set-Alien-Access  --  Public
+;;; The opposite of GUESS-ALIEN-NAME-FROM-LISP-NAME.  Make a symbol out of the
+;;; string, converting all lowercase letters to uppercase and underscores into
+;;; hyphens.
 ;;;
-;;;    Like Alien-Access, only we call the expert with :write and return
-;;; the new value.
+(defun guess-lisp-name-from-alien-name (alien-name)
+  (declare (type simple-string alien-name))
+  (intern (nsubstitute #\- #\_ (string-upcase alien-name))))
+
+;;; PICK-LISP-AND-ALIEN-NAMES -- internal.
 ;;;
-(defun %set-alien-access (alien lisp-type &optional (new-value nil nvp))
+;;; Extract the lisp and alien names from NAME.  If only one is given, guess
+;;; the other.
+;;; 
+(defun pick-lisp-and-alien-names (name)
+  (etypecase name
+    (string
+     (values (guess-lisp-name-from-alien-name name) name))
+    (symbol
+     (values name (guess-alien-name-from-lisp-name name)))
+    (list
+     (unless (= (length name) 2)
+       (error "Badly formed alien name."))
+     (values (cadr name) (car name)))))
+
+;;; DEF-ALIEN-VARIABLE -- public
+;;;
+(defmacro def-alien-variable (name type)
+  "Define NAME as an external alien variable of type TYPE.  NAME should be
+   a list of a symbol to use as the Lisp name, and a string holding the alien
+   name.  If NAME is just a symbol or string, then the other name is guessed
+   from the one supplied."
+  (multiple-value-bind
+      (lisp-name alien-name)
+      (pick-lisp-and-alien-names name)
+    (with-additional-alien-types (additional-types)
+      (let ((alien-type (parse-alien-type type)))
+	`(eval-when (compile load eval)
+	   ,@(when additional-types
+	       `((%def-additional-alien-types ',additional-types)))
+	   (%def-alien-variable ',lisp-name
+				',alien-name
+				',alien-type))))))
+
+;;; %DEF-ALIEN-VARIABLE -- internal
+;;;
+;;; Do the actual work of DEF-ALIEN-VARIABLE.
+;;; 
+(defun %def-alien-variable (lisp-name alien-name type)
+  (setf (info variable kind lisp-name) :alien)
+  (setf (info variable where-from lisp-name) :defined)
+  (clear-info variable constant-value lisp-name)
+  (setf (info variable alien-info lisp-name)
+	(make-heap-alien-info :type type
+			      :sap-form `(foreign-symbol-address
+					  ',alien-name))))
+
+;;; EXTERN-ALIEN -- public.
+;;; 
+(defmacro extern-alien (name type)
+  "Access the alien variable named NAME, assuming it is of type TYPE.  This
+   is setfable."
+  (let ((alien-name (etypecase name
+		      (symbol (guess-alien-name-from-lisp-name name))
+		      (string name))))
+    `(%heap-alien ',(make-heap-alien-info
+		     :type (parse-alien-type type)
+		     :sap-form `(foreign-symbol-address ',alien-name)))))
+
+;;; WITH-ALIEN -- public.
+;;;
+(defmacro with-alien (bindings &body body)
+  "Establish some local alien variables.  Each BINDING is of the form:
+     VAR TYPE [ ALLOCATION ] [ INITIAL-VALUE | EXTERNAL-NAME ]
+   ALLOCATION should be one of:
+     :LOCAL (the default)
+       The alien is allocated on the stack, and has dynamic extent.
+     :STATIC
+       The alien is allocated on the heap, and has infinate extent.  The alien
+       is allocated at load time, so the same piece of memory is used each time
+       this form executes.
+     :EXTERN
+       No alien is allocated, but VAR is established as a local name for
+       the external alien given by EXTERNAL-NAME."
+  (with-additional-alien-types (additional-types)
+    (dolist (binding (reverse bindings))
+      (destructuring-bind
+	  (symbol type &optional (opt1 nil opt1p) (opt2 nil opt2p))
+	  binding
+	(let ((alien-type (parse-alien-type type)))
+	  (multiple-value-bind
+	      (allocation initial-value)
+	      (if opt2p
+		  (values opt1 opt2)
+		  (case opt1
+		    (:extern
+		     (values opt1 (guess-alien-name-from-lisp-name symbol)))
+		    (:static
+		     (values opt1 nil))
+		    (t
+		     (values :local opt1))))
+	    (setf body
+		  (ecase allocation
+		    #+nil
+		    (:static
+		     (let ((sap
+			    (make-symbol (concatenate 'string "SAP-FOR-"
+						      (symbol-name symbol)))))
+		       `((let ((,sap (load-time-value (%make-alien ...))))
+			   (declare (type system-area-pointer ,sap))
+			   (symbol-macrolet
+			    ((,symbol (sap-alien ,sap ,type)))
+			    ,@(when initial-value
+				`((setq ,symbol ,initial-value)))
+			    ,@body)))))
+		    (:extern
+		     (let ((info (make-heap-alien-info
+				  :type alien-type
+				  :sap-form `(foreign-symbol-address
+					      ',initial-value))))
+		       `((symbol-macrolet
+			     ((,symbol (%heap-alien ',info)))
+			   ,@body))))
+		    (:local
+		     (let ((var (gensym))
+			   (initval (if initial-value (gensym)))
+			   (info (make-local-alien-info
+				  :type (parse-alien-type type))))
+		       `((let ((,var (make-local-alien ',info))
+			       ,@(when initial-value
+				   `((,initval ,initial-value))))
+			   (note-local-alien-type ',info ,var)
+			   (multiple-value-prog1
+			       (symbol-macrolet
+				   ((,symbol (local-alien ',info ,var)))
+				 ,@(when initial-value
+				     `((setq ,symbol ,initval)))
+				 ,@body)
+			     (dispose-local-alien ',info ,var))))))))))))
+    `(locally-introduce-additional-types (,additional-types)
+       ,@body)))
+
+
+;;;; Runtime C values that don't correspond directly to Lisp types.
+
+;;; ALIEN-VALUE
+;;; 
+(defstruct (alien-value
+	    (:print-function %print-alien-value))
+  (sap (required-argument) :type system-area-pointer)
+  (type (required-argument) :type alien-type))
+;;;
+(defun %print-alien-value (value stream depth)
+  (declare (ignore depth))
+  (print-unreadable-object (value stream)
+    (funcall (formatter "Alien-Value of type ~S: #x~8,'0X")
+	     stream 
+	     (unparse-alien-type (alien-value-type value))
+	     (sap-int (alien-value-sap value)))))
+
+
+(defmacro sap-alien (sap type)
+  (let ((alien-type (parse-alien-type type)))
+    (if (eq (compute-alien-rep-type alien-type) 'system-area-pointer)
+	`(%sap-alien ,sap ',alien-type)
+	(error "Cannot make aliens of type ~S out of SAPs" type))))
+
+(defun %sap-alien (sap type)
+  (declare (type system-area-pointer sap)
+	   (type alien-type type))
+  (make-alien-value :sap sap :type type))
+
+(defun alien-sap (alien)
   (declare (type alien-value alien))
-  (multiple-value-bind (lisp-type new-value)
-		       (if nvp
-			   (values lisp-type new-value)
-			   (values nil lisp-type))
-    (let* ((alien-type (alien-value-type alien))
-	   (access (get-alien-access-method alien-type lisp-type))
-	   (n-sap (gensym))
-	   (n-offset (gensym))
-	   (n-size (gensym))
-	   (n-nval (gensym)))
-      (eval
-       `(let ((,n-sap ',(alien-value-sap alien))
-	      (,n-offset ',(alien-value-offset alien))
-	      (,n-size ',(alien-value-size alien))
-	      (,n-nval ,new-value))
-	  ,(funcall access n-sap n-offset n-size alien-type :write n-nval
-		    '(setf alien-access))))
-      new-value)))
+  (alien-value-sap alien))
+
 
 
-;;;; Miscellaneous alien access methods:
+;;;; Allocation/Deallocation of heap aliens.
 
-;;; Alien-Access expert for Port  --  Internal
-;;;
-;;;    Just find the place and grab or store a 32-bit port, depending
-;;; on the access kind, treating ports as 32-bit signed integers. --JRG
-;;;
-(define-alien-access (port) (type kind value form)
-  ;;
-  ;; We want to know if the offset is constant, and the size must be two
-  ;; words.
-  (with-alien (sap)
-	      (offset :unit nil)
-	      (size :constant 32
-		    :unit nil)
-    (declare (ignore size))
-    (if (eq kind :read)
-	`(naturalize-integer t ,sap ,offset 32 ',form)
-	`(deport-integer t ,sap ,offset 32 ,value ',form))))
-
-;;; Alien-Access expert for String-Char  --  Internal
-;;;
-;;;    Kind of easy, but we need to deal with random bit positions.  What we do
-;;; is call Naturalize-Integer or Deport-Integer to do the access, and just do
-;;; the type conversion.
-;;;
-(define-alien-access (string-char) (type kind value form)
-  (with-alien (sap)
-	      (offset :unit nil)
-	      (size :unit nil :minimum 8)
-    (if (eq kind :read)
-	`(code-char (naturalize-integer nil ,sap ,offset ,size ',form))
-	`(deport-integer nil ,sap ,offset ,size (char-code ,value) ',form))))
-
-;;; Alien-Access experts for Unsigned-Byte, Signed-Byte  --  Internal
-;;;
-;;;    Like, just call Naturalize or Deport Integer.
-;;;
-(define-alien-access (unsigned-byte) (type kind value form)
-  (with-alien (sap)
-	      (offset :unit nil)
-	      (size :minimum (cadr type)
-		    :unit nil)
-    (if (eq kind :read)
-	`(naturalize-integer nil ,sap ,offset ,size ',form)
-	`(deport-integer nil ,sap ,offset ,size ,value ',form))))
-;;;
-(define-alien-access (signed-byte) (type kind value form)
-  (with-alien (sap)
-	      (offset :unit nil)
-	      (size :minimum (cadr type)
-		    :unit nil)
-    (if (eq kind :read)
-	`(naturalize-integer t ,sap ,offset ,size ',form)
-	`(deport-integer t ,sap ,offset ,size ,value ',form))))
-
-#| 
-I didn't write this, and it is wrong, since it assumes the size is constant.
-In fact, it will never be constant at this point in the new compiler.  I also
-don't know that it is supposed to be used for.  I suspect it is a PERQ crock.
-
-(define-alien-access (unstructured) (type kind value)
-  (with-alien (sap)
-	      (offset :unit nil)
-	      (size :unit nil
-		    :minimum (cadr type))
-    (if (eq kind :read)
-	(if (<= size 32)
-	    `(naturalize-integer nil ,sap ,offset ,size)
-	    (if (and (= (mod offset 32) 0) (= (mod size 32) 0))
-		(do ((i 32 (+ i 32))
-		     (form `(naturalize-integer nil ,sap ,offset 32)))
-		    ((>= i size) form)
-		  (setq form
-			`(logior (ash ,form 32)
-				 (naturalize-integer nil ,sap
-						     ,(+ offset i) 32))))
-		(error
-		 "Unstructured aliens of size ~D and offset ~D not supported."
-		 size offset)))
-	(if (<= size 32)
-	    `(deport-integer nil ,sap ,offset ,size ,value)
-	    (if (and (= (mod offset 32) 0) (= (mod size 32) 0))
-		(do ((i (- size 32) (- i 32))
-		     (shift 0 (- shift 32))
-		     (form ()))
-		    ((< i 0) (nreverse form))
-		  (push `(deport-integer nil ,sap ,(+ offset i) 32
-					 (logand (ash ,value ,shift)
-						 #xFFFFFFFF))
-			form))
-		(error
-		 "Unstructured aliens of size ~D and offset ~D not supported."
-		 size offset)))))))
-
-|#
-
-;;; Alien-Access expert for Boolean  --  Internal 
-;;;
-;;;    A boolean is a single bit, represented in Lisp as T or NIL.
-;;;
-(define-alien-access (boolean) (type kind value form)
-  (with-alien (sap)
-	      (offset :unit 1)
-	      (size :unit 1  :minimum 1)
-    (if (eq kind :read)
-	`(naturalize-boolean ,sap ,offset ,size ',form)
-	`(deport-boolean ,sap ,offset ,size ,value ',form))))
-
-;;; Alien-Access expert for single-floats
-;;;
-(define-alien-access (single-float) (type kind value)
-  (with-alien (sap)
-	      (offset)
-	      (size :constant 1)
-    (declare (ignore size))
-    (if (eq kind :read)
-	`(sap-ref-single ,sap ,offset)
-	`(setf (sap-ref-single ,sap ,offset) ,value))))
-
-;;; Alien-Access expert for double-floats
-;;;
-(define-alien-access (double-float) (type kind value)
-  (with-alien (sap)
-	      (offset)
-	      (size :unit 64 :constant 1)
-    (declare (ignore size))
-    (if (eq kind :read)
-	`(sap-ref-double ,sap ,offset)
-	`(setf (sap-ref-double ,sap ,offset) ,value))))
-
-;;; Alien-access expert for procedure objects.  These should be used
-;;; with caution.
+;;; MAKE-ALIEN -- public.
+;;; 
+(defmacro make-alien (type &optional size)
+  "Allocate an alien of type TYPE and return an alien pointer to it.  If SIZE
+   is supplied, how it is interpreted depends on TYPE.  If TYPE is an array
+   type, SIZE is used as the first dimension for the allocated array.  If
+   TYPE is not an array, then SIZE is the number of elements to allocate."
+  (let ((alien-type (parse-alien-type type)))
+    (multiple-value-bind
+	(size-expr element-type)
+	(if (alien-array-type-p alien-type)
+	    (let ((dims (alien-array-type-dimensions alien-type)))
+	      (cond
+	       (size
+		(unless dims
+		  (error
+		   "Cannot override the size of zero-dimensional arrays."))
+		(when (constantp size)
+		  (setf alien-type (copy-alien-array-type alien-type))
+		  (setf (alien-array-type-dimensions alien-type)
+			(cons (eval size) (cdr dims)))))
+	       (dims
+		(setf size (car dims)))
+	       (t
+		(setf size 1)))
+	      (values `(* ,size ,@(cdr dims))
+		      (alien-array-type-element-type alien-type)))
+	    (values (or size 1) alien-type))
+      (let ((bits (alien-type-bits element-type))
+	    (alignment (alien-type-alignment element-type)))
+	(unless bits
+	  (error "Size of ~S unknown." (unparse-alien-type element-type)))
+	(unless alignment
+	  (error "Alignment of ~S unknown." (unparse-alien-type element-type)))
+	`(%sap-alien (%make-alien (* ,(align-offset bits alignment)
+				     ,size-expr))
+		     ',(make-alien-pointer-type :to alien-type))))))
+
+;;; %MAKE-ALIEN -- internal
+;;;
+;;; Allocate a block of memory at least BITS bits long and return a system
+;;; area pointer to it.
+;;;
+(defun %make-alien (bits)
+  (declare (ignore bits))
+  nil)
+
+;;; FREE-ALIEN -- public
 ;;;
-#+nil ; ### This will need work.
-(define-alien-access (c-procedure) (type kind value)
-  (with-alien (sap)
-	      (offset)
-	      (size :constant 2)
-    (declare (ignore size))
-    (if (eq kind :read)
-	`(error "It is illegal to reference a c-procedure object.")
-	`(%primitive set-c-procedure-pointer ,sap ,offset ,value))))
+(defun free-alien (alien)
+  "Dispose of the storage pointed to by ALIEN.  ALIEN must have been allocated
+   by MAKE-ALIEN."
+  (let ((sap (alien-sap alien)))
+    (declare (ignore sap))
+    nil))
 
 
-;;;; Strings accesses:
+;;;; The SLOT operator
 
-;;; Can't use length, because it may be less than the limit.
+;;; SLOT-OR-LOSE -- internal.
 ;;;
-(deftype perq-string (&optional length)
-  (declare (ignore length))
-  'simple-base-string)
+;;; Find the field named SLOT, or die trying.
+;;; 
+(defun slot-or-lose (type slot)
+  (declare (type alien-record-type type)
+	   (type symbol slot))
+  (or (find slot (alien-record-type-fields type)
+	    :key #'alien-record-field-name)
+      (error "No slot named ~S in ~S" slot type)))
 
-;;; Alien-Access expert for String  --  Internal
-;;;
-;;;    Read a Perq-String into a string or write a string out into
-;;; a Perq-String.
-;;;
-(define-alien-access (simple-string perq-string) (type kind n-value)
-  (with-alien (n-sap)
-	      (n-offset :unit 8)
-	      (size :unit 8
-		    :minimum (1+ (cadr type)))
-    (declare (ignore size))
-    (if (eq kind :read)
-	(let ((size (gensym))
-	      (str (gensym)))
-	  `(let* ((,size (sap-ref-8 ,n-sap ,n-offset))
-		  (,str (make-string ,size)))
-	     (%primitive byte-blt ,n-sap (1+ ,n-offset) ,str 0 ,size)
-	     ,str))
-	(let ((len (gensym))
-	      (1+off (gensym)))
-	  `(let ((,len (length (the simple-string
-				    ,n-value)))
-		 (,1+off (1+ ,n-offset)))
-	     (check<= ,len ,(cadr type))
-	     (setf (sap-ref-8 ,n-sap ,n-offset) ,len)
-	     (%primitive byte-blt ,n-value 0 ,n-sap ,1+off
-			 (+ ,1+off ,len)))))))
-
-
-;;; Can't use length, because it may be less than the limit.
+;;; SLOT -- public
 ;;;
-(deftype null-terminated-string (&optional length)
-  (declare (ignore length))
-  'simple-base-string)
+;;; Extract the value from the named slot from the record alien.  If the
+;;; alien is actually a pointer, then deref it first.
+;;; 
+(defun slot (alien slot)
+  (declare (type alien-value alien)
+	   (type symbol slot))
+  (let ((type (alien-value-type alien)))
+    (etypecase type
+      (alien-pointer-type
+       (slot (deref alien) slot))
+      (alien-record-type
+       (let ((field (slot-or-lose type slot)))
+	 (extract-alien-value (alien-value-sap alien)
+			      (alien-record-field-offset field)
+			      (alien-record-field-type field)))))))
+
+;;; %SET-SLOT -- public setf method
+;;;
+;;; Deposite the value in the specified slot of the record alien.  If the
+;;; alien is really a pointer, deref it first.  The compiler uses this
+;;; when it can't figure out anything better.
+;;; 
+(defun %set-slot (alien slot value)
+  (declare (type alien-value alien)
+	   (type symbol slot))
+  (let ((type (alien-value-type alien)))
+    (etypecase type
+      (alien-pointer-type
+       (%set-slot (deref alien) slot value))
+      (alien-record-type
+       (let ((field (slot-or-lose type slot)))
+	 (deposit-alien-value (alien-value-sap alien)
+			      (alien-record-field-offset field)
+			      (alien-record-field-type field)
+			      value))))))
+;;;
+(defsetf slot %set-slot)
+
+;;; %SLOT-ADDR -- internal
+;;; 
+;;; Compute the address of the specified slot and return a pointer to it.
+;;; 
+(defun %slot-addr (alien slot)
+  (declare (type alien-value alien)
+	   (type symbol slot))
+  (let ((type (alien-value-type alien)))
+    (etypecase type
+      (alien-pointer-type
+       (%slot-addr (deref alien) slot))
+      (alien-record-type
+       (let* ((field (slot-or-lose type slot))
+	      (offset (alien-record-field-offset field))
+	      (field-type (alien-record-field-type field)))
+	 (%sap-alien (sap+ (alien-sap alien) (/ offset vm:byte-bits))
+		     (make-alien-pointer-type :to field-type)))))))
 
-;;; Alien-Access expert for null terminated string  --  Internal
-;;;
-;;;    Read a null terminated string into a string or write a string out into
-;;; a null terminated string.
+
+;;;; The DEREF operator.
+
+;;; DEREF-GUTS -- internal.
 ;;;
-(define-alien-access (simple-string null-terminated-string) (type kind n-value)
-  (with-alien (n-sap)
-	      (n-offset :unit 8)
-	      (size :unit 8
-		    :minimum (cadr type))
-    (declare (ignore size))
-    (if (eq kind :read)
-	(let ((size (gensym))
-	      (str (gensym))
-	      (ptr (gensym))
-	      (start (gensym)))
-	  `(do* ((,start (sap+ ,n-sap ,n-offset))
-		 (,ptr ,start (sap+ ,ptr 1)))
-	       ((zerop (sap-ref-8 ,ptr 0))
-		(let* ((,size (sap- ,ptr ,start))
-		       (,str (make-string ,size)))
-		  (declare (fixnum ,size)
-			   (type simple-base-string ,str))
-		  (copy-from-system-area ,start 0
-					 ,str (* vm:vector-data-offset
-						 vm:word-bits)
-					 (* ,size vm:byte-bits))
-		  ,str))
-	     (declare (type system-area-pointer ,start ,ptr))))
-	(let ((len (gensym)))
-	  `(let ((,len (the fixnum (1+ (length (the simple-string
-						    ,n-value))))))
-	     (declare (fixnum ,len))
-	     (check<= ,len ,(cadr type))
-	     (copy-to-system-area ,n-value (* vm:vector-data-offset
-					      vm:word-bits)
-				  ,n-sap ,n-offset ,len))))))
+;;; Does most of the work of the different DEREF methods.  Returns two values:
+;;; the type and the offset (in bits) of the refered to alien.
+;;; 
+(defun deref-guts (alien indices)
+  (declare (type alien-value alien)
+	   (type list indices)
+	   (values alien-type integer))
+  (let ((type (alien-value-type alien)))
+    (etypecase type
+      (alien-pointer-type
+       (when (cdr indices)
+	 (error "Too many indices when derefing ~S: ~D"
+		type
+		(length indices)))
+       (let ((element-type (alien-pointer-type-to type)))
+	 (values element-type
+		 (if indices
+		     (* (align-offset (alien-type-bits element-type)
+				      (alien-type-alignment element-type))
+			(car indices))
+		     0))))
+      (alien-array-type
+       (unless (= (length indices) (length (alien-array-type-dimensions type)))
+	 (error "Incorrect number of indices when derefing ~S: ~D"
+		type (length indices)))
+       (labels ((frob (dims indices offset)
+		  (if (null dims)
+		      offset
+		      (frob (cdr dims) (cdr indices)
+			(+ (if (zerop offset)
+			       0
+			       (* offset (car dims)))
+			   (car indices))))))
+	 (let ((element-type (alien-array-type-element-type type)))
+	   (values element-type
+		   (* (align-offset (alien-type-bits element-type)
+				    (alien-type-alignment element-type))
+		      (frob (alien-array-type-dimensions type)
+			indices 0)))))))))
+
+;;; DEREF -- public
+;;;
+;;; Dereference the alien and return the results.
+;;; 
+(defun deref (alien &rest indices)
+  (declare (type alien-value alien)
+	   (type list indices))
+  (multiple-value-bind
+      (target-type offset)
+      (deref-guts alien indices)
+    (extract-alien-value (alien-value-sap alien)
+			 offset
+			 target-type)))
+
+;;; %SET-DEREF -- public setf method
+;;; 
+(defun %set-deref (alien value &rest indices)
+  (declare (type alien-value alien)
+	   (type list indices))
+  (multiple-value-bind
+      (target-type offset)
+      (deref-guts alien indices)
+    (deposit-alien-value (alien-value-sap alien)
+			 offset
+			 target-type
+			 value)))
+;;;
+(defsetf deref (alien &rest indices) (value)
+  `(%set-deref ,alien ,value ,@indices))
+
+;;; %DEREF-ADDR -- public
+;;;
+(defun %deref-addr (alien &rest indices)
+  (declare (type alien-value alien)
+	   (type list indices))
+  (multiple-value-bind
+      (target-type offset)
+      (deref-guts alien indices)
+    (%sap-alien (sap+ (alien-value-sap alien) (/ offset vm:byte-bits))
+		(make-alien-pointer-type :to target-type))))
 
 
-;;;; Pointer alien access:
+;;;; Accessing heap alien variables.
 
-;;; Alien-Access expert for System-Area-Pointer  --  Internal
-;;;
-;;;    Get or store a pointer.  In the store case this is the same
-;;; as Pointer.
-;;;
-(define-alien-access (system-area-pointer system-area-pointer alien)
-  (type kind value)
-  (with-alien (sap)
-	      (offset)
-	      (size :constant 1)
-    (declare (ignore size))
-    (if (eq kind :read)
-	`(sap-ref-sap ,sap ,offset)
-	`(setf (sap-ref-sap ,sap ,offset) ,value))))
-
-;;; Alien-Access expert for (Alien <type> [<bits>])  --  Internal
-;;;
-;;;    Get or store an alien value.  On read, we cons up a value, getting
-;;; the size of out the type.  On write, we just store the SAP.
+(defun %heap-alien (info)
+  (declare (type heap-alien-info info))
+  (extract-alien-value (eval (heap-alien-info-sap-form info))
+		       0
+		       (heap-alien-info-type info)))
+
+(defun %set-heap-alien (info value)
+  (declare (type heap-alien-info info))
+  (deposit-alien-value (eval (heap-alien-info-sap-form info))
+		       0
+		       (heap-alien-info-type info)
+		       value))
 ;;;
-(define-alien-access (alien) (type kind value)
-  (with-alien (sap)
-	      (offset)
-	      (size :constant 1)
-    (declare (ignore size))
-    (unless (and (consp type) (consp (cdr type)))
-      (error "Bad type for accessing as an Alien: ~S" type))
-    (let ((atype (second type))
-	  (size (third type)))
-      (cond
-       ((eq kind :read)
-	(unless size
-	  (error "Size not specified when reading alien type: ~S" type))
-	(unless (and (integerp size) (>= size 0))
-	  (error "Size is not a positive integer: ~S" type))
-	`(make-alien-value
-	  (sap-ref-sap ,sap ,offset)
-	  0
-	  ,size
-	  ',atype))
-       (t
-	`(setf (sap-ref-sap ,sap ,offset)
-	       (alien-value-sap ,value)))))))
+(defsetf %heap-alien %set-heap-alien)
 
+(defun %heap-alien-addr (info)
+  (declare (type heap-alien-info info))
+  (%sap-alien (eval (heap-alien-info-sap-form info))
+	      (make-alien-pointer-type :to (heap-alien-info-type info))))
 
-;;; Alien-Access expert for (Pointer xxx)  --  Internal
-;;;
-;;;    We can't read pointers, and can only store pointers to unboxed
-;;; things.
-;;;
-(define-alien-access (pointer pointer alien) (type kind value)
-  (with-alien (sap)
-	      (offset)
-	      (size :constant 1)
-    (declare (ignore size))
-    (if (eq kind :read)
-	`(error "Cannot reference pointer aliens")
-	(let ((n-value (gensym)))
-	  `(setf (sap-ref-sap ,sap ,offset)
-		 (let ((,n-value ,value))
-		   ,@(when (and (consp type) (consp (cdr type)))
-		       `((declare (type ,(cadr type) ,n-value))))
-		   (etypecase ,n-value
-		     (null (int-sap 0))
-		     (system-area-pointer ,n-value)
-		     ((or simple-string
-			  simple-bit-vector
-			  (simple-array unsigned-byte (*)))
-		      (vector-sap ,n-value)))))))))
 
 
-;;;; Enumeration Alien access:
+;;;; Accessing local aliens.
 
-(compiler-let ((lisp::*bootstrap-defmacro* t))
+(defun make-local-alien (info)
+  (let ((alien (eval `(make-alien ,(local-alien-info-type info)))))
+    #+nil
+    (finalize info #'(lambda () (free-alien alien)))
+    alien))
 
-;;; Defenumeration  --  Public
-;;;
-;;;    Cons up the from alist, keeping track of the minimum and maximum
-;;; values, then decide whether to use a vector or alist to mapping.
-;;;
-(defmacro defenumeration (name &rest elements)
-  "Defenumeration Name {{Element}+ | {(Element Value)}+}
-  Define an enumeration for use with Alien-Access and the Enumeration
-  Alien type."
-  (let ((min nil)
-	(max nil)
-	(from-alist ()))
-    (declare (list from-alist))
-    (when (null elements)
-      (error "An anumeration must contain at least one element."))
-    (if (listp (car elements))
-	(dolist (el elements)
-	  (unless (listp el)
-	    (error "Element value is not specified: ~S." el))
-	  (push (cons (first el) (second el)) from-alist))
-	(let ((num -1))
-	  (dolist (el elements)
-	    (push (cons el (incf num)) from-alist))))
-    (do ((el from-alist (cdr el)))
-	((null el))
-      (let ((sym (caar el))
-	    (val (cdar el)))
-	(unless (keywordp sym)
-	  (error "Enumeration element ~S is not a keyword." sym))
-	(unless (integerp val)
-	  (error "Element value ~S is not an integer." val))
-	(unless (and max (> max val)) (setq max val))
-	(unless (and min (< min val)) (setq min val))
-	(when (rassoc val (cdr el))
-	  (error "Element value ~S used more than once." val))
-	(when (assoc sym (cdr el) :test #'eq)
-	  (error "Enumeration element ~S used more than once." sym))))
-    (let* ((signed (minusp min))
-	   (to (intern (concatenate 'simple-string (string name)
-				    "-TO-ENUMERATION-" (string (gensym)))))
-	   (from (intern (concatenate 'simple-string (string name)
-				      "-FROM-ENUMERATION-" (string (gensym)))))
-	   (info (make-enumeration-info :signed signed
-					:size (if signed
-						  (1+ (max (integer-length min)
-							   (integer-length max)))
-						  (integer-length max))
-					:from from  :to to))
-	   to-thing)
-      (cond
-       ;;
-       ;; If range is at least 20% dense, use vector mapping.  Crossover
-       ;; point solely on basis of space would be 25%.  Vector mapping
-       ;; is always faster, so give the benefit of the doubt.
-       ((< 0.2 (/ (float (length from-alist)) (float (- max min))))
-	;;
-	;; If offset is small and ignorable, ignore it to save time.
-	(when (< 0 min 10) (setq min 0))
-	(setq to-thing (make-array (1+ (- max min))))
-	(dolist (el from-alist)
-	  (setf (svref to-thing (- (cdr el) min)) (car el)))
-	(setf (enumeration-info-kind info) :vector)
-	(setf (enumeration-info-offset info) (- min)))
-       (t
-	(setf (enumeration-info-kind info) :alist)
-	(setq to-thing (mapcar #'(lambda (x) (cons (cdr x) (car x))) from-alist))))
-      `(progn
-	(eval-when (compile load eval)
-	  (proclaim '(special ,to ,from))
-	  (set ',to ',to-thing)
-	  (set ',from ',from-alist))
-	(eval-when ,*alien-eval-when*
-	  (setf (info enumeration info ',name) ',info))
-	',name))))
+(defun note-local-alien-type (info alien)
+  (declare (ignore info alien))
+  nil)
 
-); compiler-let
+(defun local-alien (info alien)
+  (declare (ignore info))
+  (deref alien))
+
+(defun %set-local-alien (info alien value)
+  (declare (ignore info))
+  (setf (deref alien) value))
+
+(define-setf-method local-alien (&whole whole info alien)
+  (let ((value (gensym))
+	(info (if (and (consp info)
+		       (eq (car info) 'quote))
+		  (second info)
+		  (error "Something is wrong; local-alien-info not found: ~S"
+			 whole))))
+    (values nil
+	    nil
+	    (list value)
+	    (if c:*converting-for-interpreter*
+		`(%set-local-alien ',info ,alien ,value)
+		`(if (%local-alien-forced-to-memory-p ',info)
+		     (%set-local-alien ',info ,alien ,value)
+		     (setf ,alien
+			   (deport ,value ',(local-alien-info-type info)))))
+	    whole)))
+
+(defun %local-alien-forced-to-memory-p (info)
+  (local-alien-info-force-to-memory-p info))
+
+(defun %local-alien-addr (info alien)
+  (declare (type local-alien-info info))
+  (unless (local-alien-info-force-to-memory-p info)
+    (error "~S isn't forced to memory.  Something went wrong." alien))
+  alien)
 
-;;; Enumeration-Error  --  Internal
-;;;
-;;;    Tell the luser what permissable values the enumeration has when she
-;;; gives us something bogus.  We even give them a chance to specify
-;;; something else.
-;;;
-(defun enumeration-error (alist)
-  (loop
-   (cerror "Prompt for a new value."
-	   "Enumeration value is not one of the following: ~{~<~%  ~:;~S ~>~}"
-	  (mapcar #'car alist))
-   (write-string "New value: " *query-io*)
-   (let* ((response (read *query-io*))
-	  (res (cdr (assoc response alist :test #'eq))))
-     (when res (return res)))))
-
-
-(define-alien-access (enumeration) (type kind value form)
-  (let* ((enum (cadr type))
-	 (info (or (info enumeration info enum)
-		   (error "~S is not a defined enumeration." enum)))
-	 (signed (enumeration-info-signed info))
-	 (to (enumeration-info-to info))
-	 (from (enumeration-info-from info)))
-    (with-alien (sap)
-		(offset :unit nil)
-		(size :unit nil
-		      :minimum (enumeration-info-size info))
-      (if (eq kind :read)
-	  (ecase (enumeration-info-kind info)
-	    (:vector
-	     `(svref ,to
-		     (+ ,(enumeration-info-offset info)
-			(naturalize-integer ,signed ,sap ,offset ,size
-					    ',form))))
-	    (:alist
-	     `(cdr (assoc (naturalize-integer ,signed ,sap ,offset ,size
-					      ',form)
-			  ,to))))
-	  `(deport-integer
-	    ,signed ,sap ,offset ,size
-	    (or (cdr (assoc ,value ,from :test #'eq))
-		(enumeration-error ,from))
-	    ',form)))))
+(defun dispose-local-alien (info alien)
+  (declare (ignore info))
+  #+nil
+  (cancel-finalization info)
+  (free-alien alien))
+
+
+;;;; The ADDR macro.
+
+(defmacro addr (expr &environment env)
+  (let ((form (macroexpand expr env)))
+    (or (typecase form
+	  (cons
+	   (case (car form)
+	     (slot
+	      (cons '%slot-addr (cdr form)))
+	     (deref
+	      (cons '%deref-addr (cdr form)))
+	     (%heap-alien
+	      (cons '%heap-alien-addr (cdr form)))
+	     (local-alien
+	      (let ((info
+		     (let ((info-arg (second form)))
+		       (and (consp info-arg)
+			    (eq (car info-arg) 'quote)
+			    (second info-arg)))))
+		(unless (local-alien-info-p info)
+		  (error "Something is wrong, local-alien-info not found: ~S"
+			 form))
+		(setf (local-alien-info-force-to-memory-p info) t))
+	      (cons '%local-alien-addr (cdr form)))))
+	  (symbol
+	   (let ((kind (info variable kind form)))
+	     (when (eq kind :alien)
+	       `(%heap-alien-addr ',(info variable alien-info form))))))
+	(error "~S is not a valid L-value" form))))
+
+
+;;;; The CAST macro.
+
+(defmacro cast (alien type)
+  `(%cast ,alien ',(parse-alien-type type)))
 
+(defun %cast (alien target-type)
+  (declare (type alien-value alien) (type alien-type target-type))
+  (if (or (alien-pointer-type-p target-type)
+	  (alien-array-type-p target-type)
+	  (alien-function-type-p target-type))
+      (let ((alien-type (alien-value-type alien)))
+	(if (or (alien-pointer-type-p alien-type)
+		(alien-array-type-p alien-type)
+		(alien-function-type-p alien-type))
+	    (naturalize (alien-value-sap alien) target-type)
+	    (error "~S cannot be casted." alien)))
+      (error "Cannot cast to alien type ~S" (unparse-alien-type target-type))))
+
+
+
+;;;; The ALIEN-SIZE macro.
+
+(defmacro alien-size (type &optional (units :bits))
+  "Return the size of the alien type TYPE.  UNITS specifies the units to
+   use and can be either :BITS, :BYTES, or :WORDS."
+  (let* ((alien-type (parse-alien-type type))
+	 (bits (alien-type-bits alien-type)))
+    (if bits
+	(values (ceiling bits
+			 (ecase units
+			   (:bits 1)
+			   (:bytes vm:byte-bits)
+			   (:words vm:word-bits))))
+	(error "Unknown size for alien type ~S."
+	       (unparse-alien-type alien-type)))))
+
+
+
+;;;; Naturalize, deport, extract-alien-value, deposit-alien-value
+
+(defun naturalize (alien type)
+  (declare (type alien-type type))
+  (funcall (coerce (compute-naturalize-lambda type) 'function)
+	   alien type))
+
+(defun deport (value type)
+  (declare (type alien-type type))
+  (funcall (coerce (compute-deport-lambda type) 'function)
+	   value type))
+
+(defun extract-alien-value (sap offset type)
+  (declare (type system-area-pointer sap)
+	   (type unsigned-byte offset)
+	   (type alien-type type))
+  (funcall (coerce (compute-extract-lambda type) 'function)
+	   sap offset type))
+
+(defun deposit-alien-value (sap offset type value)
+  (declare (type system-area-pointer sap)
+	   (type unsigned-byte offset)
+	   (type alien-type type))
+  (funcall (coerce (compute-deposit-lambda type) 'function)
+	   sap offset type value))
+
+
+
+;;;; alien-funcall, def-alien-function
+
+(defun alien-funcall (alien &rest args)
+  (declare (type alien-value alien))
+  (let ((type (alien-value-type alien)))
+    (typecase type
+      (alien-pointer-type
+       (apply #'alien-funcall (deref alien) args))
+      (alien-function-type
+       (unless (= (length (alien-function-type-arg-types type))
+		  (length args))
+	 (error "Wrong number of arguments for ~S~%Expected ~D, got ~D."
+		type
+		(length (alien-function-type-arg-types type))
+		(length args)))
+       (let ((stub (alien-function-type-stub type)))
+	 (unless stub
+	   (setf stub
+		 (let ((fun (gensym))
+		       (parms (loop repeat (length args) collect (gensym))))
+		   (compile nil
+			    `(lambda (,fun ,@parms)
+			       (declare (type (alien ,type) ,fun))
+			       (alien-funcall ,fun ,@parms)))))
+	   (setf (alien-function-type-stub type) stub))
+	 (apply stub alien args)))
+      (t
+       (error "~S is not an alien function." alien)))))
+
+(defmacro def-alien-routine (name result-type &rest args)
+  (multiple-value-bind
+      (lisp-name alien-name)
+      (pick-lisp-and-alien-names name)
+    (collect ((docs) (lisp-args) (arg-types) (alien-vars)
+	      (alien-args) (results))
+      (dolist (arg args)
+	(if (stringp arg)
+	    (docs arg)
+	    (destructuring-bind (name type &optional (style :in)) arg
+	      (unless (member style '(:in :copy :out :in-out))
+		(error "Bogus argument style ~S in ~S." style arg))
+	      (unless (eq style :out)
+		(lisp-args name))
+	      (if (eq style :in)
+		  (arg-types type)
+		  (arg-types `(* ,type)))
+	      (if (eq style :out)
+		  (alien-vars `(,name ,type))
+		  (alien-vars `(,name ,type ,name)))
+	      (if (eq style :in)
+		  (alien-args name)
+		  (alien-args `(addr ,name)))
+	      (when (or (eq style :out) (eq style :in-out))
+		(results name)))))
+      `(defun ,lisp-name ,(lisp-args)
+	 ,@(docs)
+	 (with-alien
+	     ((,lisp-name (function ,result-type ,@(arg-types))
+			  :extern ,alien-name)
+	      ,@(alien-vars))
+	     ,(if (alien-values-type-p result-type)
+		  (let ((temps (loop
+				 repeat (length (alien-values-type-values
+						 result-type))
+				 collect (gensym))))
+		    `(multiple-value-bind
+			 ,temps
+			 (alien-funcall ,lisp-name ,@(alien-args))
+		       (values ,@temps ,@(results))))
+		  `(values (alien-funcall ,lisp-name ,@(alien-args))
+			   ,@(results))))))))
diff --git a/code/c-call.lisp b/code/c-call.lisp
index f3f152e17f2eac3c6e552d6b376704de06bac0c8..cd98a2b198f8f333cea28ed6956288e5c1edf83c 100644
--- a/code/c-call.lisp
+++ b/code/c-call.lisp
@@ -1,4 +1,4 @@
-;;; -*- Mode: Lisp; Package: EXTENSIONS; Log: code.log -*-
+;;; -*- Package: C-CALL -*-
 ;;;
 ;;; **********************************************************************
 ;;; This code was written as part of the CMU Common Lisp project at
@@ -7,815 +7,77 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/c-call.lisp,v 1.7 1991/12/16 19:45:34 wlott Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/c-call.lisp,v 1.8 1992/02/14 23:44:18 wlott Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
-;;;    This file contains stuff used for calling out to C routines that are
-;;; linked into the Lisp process.
+;;; This file contains some extensions to the Alien facility to simplify
+;;; importing C interfaces.
 ;;;
-;;; Written by Rob MacLachlan.
-;;;
-(in-package "EXTENSIONS" :use '("LISP" "SYSTEM"))
-(import '(lisp::enumeration-info lisp::enumeration-info-size
-				 lisp::enumeration-info-kind
-				 lisp::enumeration-info-offset
-				 lisp::enumeration-info-to
-				 lisp::call-lisp-from-c))
-(export '(c-sizeof def-c-type def-c-record def-c-array def-c-pointer
-		   port boolean system-area-pointer
-		   char unsigned-char short unsigned-short
-		   int unsigned-int long unsigned-long
-		   void *char def-c-routine def-c-variable
-		   def-c-procedure))
-
-#-new-compiler
-(eval-when (compile)
-  (setq lisp::*bootstrap-defmacro* t))
-
-(eval-when (compile load eval)
-
-;;; The C-Type structure is used to represent aspects of C data representations
-;;; that aren't directly implemented by Aliens.
-;;;
-(defstruct (c-type
-	    (:make-load-form-fun :just-dump-it-normally))
-  ;;
-  ;; A form which is a printable representation of this type.
-  description
-  ;;
-  ;; The size in bits of objects of this type.  NIL if the size is variable.
-  (size nil :type (or unsigned-byte null))
-  ;;
-  ;; The bit alignment used for allocating objects of this type.
-  (alignment (required-argument) :type (integer 1 32)))
-
-(defun %print-c-type (s stream d)
-  (declare (ignore d))
-  (format stream "#<C-Type ~S>" (c-type-description s)))
-
-
-;;; A c-type which corresponds directly to an alien type.  The Description is
-;;; the alien type.
-;;;
-(defstruct (primitive-type
-	    (:include c-type)
-	    (:print-function %print-c-type)))
-
-
-;;; The Record-Type represnts a c structure type.
-;;;
-(defstruct (record-type
-	    (:include c-type)
-	    (:print-function %print-c-type))
-  ;;
-  ;; A list of the field descriptions for the fields in the record, in order of
-  ;; increasing bit offset.
-  (fields nil :type list))
-
-
-;;; The Field-Info structure describes a single field in a record.  The Size
-;;; recorded here may be larger than the Size in the Type, since more bits may
-;;; be allocated to the field than are actually necessary to hold a value of
-;;; that type.
-;;;
-(defstruct (field-info
-	    (:make-load-form-fun :just-dump-it-normally))
-  ;;
-  ;; The symbol name of this field.
-  (name nil :type symbol)
-  ;;
-  ;; The c-type of this field.
-  (type (required-argument) :type c-type)
-  ;;
-  ;; The bit offset from the start of the record that this field is located at.
-  (offset (required-argument) :type unsigned-byte)
-  ;;
-  ;; The number of bits in this field.
-  (size (required-argument) :type unsigned-byte))
-
-
-;;; The Array-Type represents a C array type.
-;;;
-(defstruct (array-type
-	    (:include c-type)
-	    (:print-function %print-c-type))
-  ;;
-  ;; The c-type of the elements in the array.
-  (element-type (required-argument) :type c-type)
-  ;;
-  ;; The number of bits used to store each element.  May be larger than the
-  ;; Size in the Element-Type due to padding.
-  (element-size (required-argument) :type unsigned-byte))
-
-
-;;; The Pointer-Type represents a C pointer type.
-;;;
-(defstruct (pointer-type
-	    (:include c-type)
-	    (:print-function %print-c-type))
-  ;;
-  ;; The type of object pointed to.
-  (to (required-argument) :type c-type))
-
-
-;;; An EQ hashtable from the names of c-types to the structures describing them.
-;;;
-(defvar *c-type-names* (make-hash-table :test #'eq))
-
-;;; Find-Alignment  --  Internal
-;;;
-;;;    Return the bit alignment for an object of the specified Size.
-;;;
-(proclaim '(function find-alignment (unsigned-byte) (integer 1 32)))
-(defun find-alignment (size)
-  (cond ((> size 16) 32)
-	((> size 8) 16)
-	((> size 1) 8)
-	(t 1)))
-
-
-;;; Align-Offset  --  Internal
-;;;
-;;;    Return Offset with enough added to bring it out to the specified
-;;; Alignment.
-;;;
-(proclaim '(function align-offset (unsigned-byte (integer 1 32))
-		     unsigned-byte))
-(defun align-offset (offset alignment)
-  (let ((extra (rem offset alignment)))
-    (if (zerop extra) offset (+ offset (- alignment extra)))))
-
-
-;;; Get-C-Type  --  Internal
-;;;
-;;;    Get the C-Type structure corresponding to the supplied Spec.  If the
-;;; spec is a named type, then just return the info.  Otherwise, the Spec must
-;;; be a primitive Alien type with an obvious size.  If we can't decide the
-;;; Spec, we signal an error.
-;;;
-(proclaim '(function get-c-type (t) c-type))
-(defun get-c-type (spec)
-  (cond ((gethash spec *c-type-names*))
-	((member spec '(c-procedure single-float double-float
-				    null-terminated-string))
-	 (let ((size (if (eq spec 'double-float) 64 32)))
-	   (make-primitive-type
-	    :description spec
-	    :size size
-	    :alignment (find-alignment size))))
-	((and (listp spec) (> (length spec) 1)
-	      (symbolp (first spec)))
-	 (case (first spec)
-	   ((signed-byte unsigned-byte)
-	    (let ((size (second spec)))
-	      (make-primitive-type
-	       :description spec
-	       :size size
-	       :alignment (find-alignment size))))
-	   (perq-string
-	    (make-primitive-type
-	     :description spec
-	     :size (* (1+ (second spec)) 8)
-	     :alignment 8))
-	   (null-terminated-string
-	    (make-primitive-type
-	     :description spec
-	     :size (* (second spec) 8)
-	     :alignment 8))
-	   (enumeration
-	    (let* ((name (second spec))
-		   (info (get name 'enumeration-info)))
-	      (unless info
-		(error "~S is not a defined enumeration." name))
-	      (let ((size (enumeration-info-size info)))
-		(make-primitive-type
-		 :description spec
-		 :size size
-		 :alignment (find-alignment size)))))
-	   (pointer
-	    (make-primitive-type
-	     :description spec
-	     :size vm:word-bits
-	     :alignment vm:word-bits))
-	   (alien
-	    (let ((size (third spec)))
-	      (unless size
-		(error "Must specify size in Alien C-Type: ~S." spec))
-	      (make-primitive-type
-	       :description spec
-	       :size size
-	       :alignment (find-alignment size))))
-	   (t
-	    (error "~S is not a known C-Type." spec))))
-	(t (error "Losing C-Type: ~S." spec))))
-
-
-); Eval-When (Compile Load Eval)
-
-
-;;;; Exported type operations:
-
-(eval-when (compile load eval)
-
-;;; Symbolicate  --  Internal
-;;;
-;;;    Concatenate together the names of some strings and symbols, producing
-;;; a symbol in the current package.
-;;;
-(proclaim '(function symbolicate (&rest (or string symbol)) symbol))
-(defun symbolicate (&rest things)
-  (values (intern (reduce #'(lambda (x y)
-			      (concatenate 'string (string x) (string y)))
-			  things))))
-
-); Eval-When (Compile Load Eval)
-
-
-;;; C-Sizeof  --  Public
-;;;
-(proclaim '(function c-sizeof (t) unsigned-byte))
-(defun c-sizeof (spec)
-  "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))
-
-
-;;; Def-C-Type  --  Public
-;;;
-(defmacro def-c-type (name spec)
-  "Def-C-Type Name Spec
-  Define Name to be an abbreviation for the C-Type indicated by Spec."
-  `(eval-when (compile load eval)
-     (setf (gethash ',name *c-type-names*) ',(get-c-type spec))
-     ',name))
-
-
-;;; Def-C-Record  --  Public
-;;;
-(defmacro def-c-record (name &rest fields)
-  "Name {(Name Type)}*
-  Define a record C-Type.  Name is the name of the type.  The Fields and Types
-  specify the name and type of each field.  An Alien operator Name-Field is
-  defined to select each field.  The Function Make-Name creates a dynamic alien
-  of the appropriate size and type.  Also a pointer to name type is created, so
-  that you can have pointers to a thing of type name in the definition of name.
-  The name of the pointer type is *name."
-  (let* ((info ())
-	 (pname (symbolicate "*" name))
-	 (pos 0)
-	 (align 0)
-	 (res (make-record-type
-	       :description name
-	       :size NIL
-	       :alignment 1
-	       :fields NIL))
-	 (pres (make-pointer-type
-		:description NIL
-		:size 32
-		:alignment 32
-		:to res)))
-    (setf (gethash name *c-type-names*) res)
-    (setf (gethash pname *c-type-names*) pres)
-    (dolist (field fields)
-      (unless (= (length field) 2)
-	(error "Malformed field specification: ~S." field))
-      (let* ((type (get-c-type (second field)))
-	     (size (c-type-size type))
-	     (start (align-offset pos (c-type-alignment type))))
-	(unless size
-	  (error "Variable size field ~A in record ~A not allowed."
-		 (first field) name))
-	(push (make-field-info :name (first field)
-			       :type type
-			       :offset start
-			       :size size)
-	      info)
-	(setq pos (+ start size))
-	(setq align (max (find-alignment size) align))))
-
-    (setf (record-type-size res) pos)
-    (setf (record-type-alignment res) align)
-    (setf (record-type-fields res) (nreverse info))
-    (setf (pointer-type-description pres) `(alien ,name ,pos))
-    `(progn
-      (eval-when (compile load eval)
-	(setf (gethash ',name *c-type-names*) ',res)
-	(setf (gethash ',pname *c-type-names*) ',pres))
-      (defun ,(symbolicate "MAKE-" name) ()
-	(make-alien ',name ,(c-type-size res)))
-      (defoperator (,(symbolicate "INDIRECT-" pname)
-		    ,(record-type-description res))
-		   ((pointer ,(c-type-description pres)))
-	`(alien-indirect (alien-value ,pointer) ,,pos))
-      ,@(define-record-operators res))))
-
-(eval-when (compile load eval)
-
-;;; Define-Record-Operators  --  Internal
-;;;
-;;;    Compute the operator definitions for accessing the fields in Record.
-;;;
-(proclaim '(function define-record-operators (record-type) list))
-(defun define-record-operators (record)
-  (let ((name (c-type-description record)))
-    (mapcar #'(lambda (x)
-		`(defoperator (,(symbolicate name "-" (field-info-name x))
-			       ,(c-type-description (field-info-type x)))
-			      ((rec ,name))
-		  `(alien-index (alien-value ,rec)
-				,,(field-info-offset x)
-				,,(field-info-size x))))
-	    (record-type-fields record))))
-
-); Eval-When (Compile Load Eval)
-
-
-;;; Def-C-Array  --  Public
-;;;
-(defmacro def-c-array (name element-type &optional size)
-  "Def-C-Array Name Element-Type [Size]
-  Define Name to be an array C-Type with the specified Element-Type.  If size
-  is not specified, then it is a variable size array."
-  (let* ((eltype (get-c-type element-type))
-	 (elalign (c-type-alignment eltype))
-	 (elsize (align-offset (c-type-size eltype) elalign))
-	 (elts (eval size))
-	 (res (make-array-type :description name
-			       :size (if elts (* elsize elts) nil)
-			       :alignment elalign
-			       :element-type eltype
-			       :element-size elsize)))
-    `(progn
-      (eval-when (compile load eval)
-	(setf (gethash ',name *c-type-names*) ',res))
-
-      (defun ,(symbolicate "MAKE-" name)
-	     ,(if elts () '(size))
-	(make-alien ',name ,(if elts (* elsize elts) `(* ,elsize size))))
-
-      (defoperator (,(symbolicate name "-REF")
-		    ,(c-type-description eltype))
-		   ((array ,name) i)
-	`(alien-index (alien-value ,array) (* ,,elsize ,i) ,,elsize)))))
-
-
-;;; Def-C-Pointer  --  Public
-;;;
-(defmacro def-c-pointer (name to)
-  "Def-C-Pointer Name To
-  Define a pointer C-Type which points to an object of type To."
-  (let* ((type (get-c-type to))
-	 (res (make-pointer-type
-	       :description `(alien ,(c-type-description type)
-				    ,@(when (c-type-size type)
-					`(,(c-type-size type))))
-	       :size 32
-	       :alignment 32
-	       :to type)))
-    `(progn
-      (eval-when (compile load eval)
-	(setf (gethash ',name *c-type-names*) ',res))
-      (defoperator (,(symbolicate "INDIRECT-" name)
-		    ,(c-type-description type))
-		   ((pointer ,(c-type-description res))
-		    ,@(unless (c-type-size type)
-			'(size)))
-	`(alien-indirect (alien-value ,pointer)
-			 ,,(or (c-type-size type) 'size))))))
-
-;;; Some trivial builtin types...
-;;;  
-(setf (gethash 'port *c-type-names*)
-      (make-primitive-type :description 'port
-			   :size 32
-			   :alignment 32))
-
-(setf (gethash 'boolean *c-type-names*)
-      (make-primitive-type :description 'boolean
-			   :size 1
-			   :alignment 1))
-
-(setf (gethash 'system-area-pointer *c-type-names*)
-      (make-primitive-type :description 'system-area-pointer
-			   :size 32
-			   :alignment 32))
-
-
-;;; Some more standard types:
-
-(def-c-type char (signed-byte 8))
-(def-c-type unsigned-char (unsigned-byte 8))
-(def-c-type short (signed-byte 16))
-(def-c-type unsigned-short (unsigned-byte 16))
-(def-c-type int (signed-byte 32))
-(def-c-type unsigned-int (unsigned-byte 32))
-(def-c-type long (signed-byte 32))
-(def-c-type unsigned-long (unsigned-byte 32))
-
-(def-c-pointer *char char)
+(in-package "C-CALL")
+(use-package "ALIEN")
+(use-package "ALIEN-INTERNALS")
+(use-package "SYSTEM")
 
+(export '(char short int long unsigned-char unsigned-short unsigned-int
+	  unsigned-long float double c-string void))
+	       
 
-;;; DEF-C-ROUTINE and support stuff.
+;;;; Extra types.
 
-(defstruct (routine-info
-	    (:print-function
-	     (lambda (s stream d)
-	       (declare (ignore d))
-	       (format stream "#<Routine-Info ~S>" (routine-info-name s)))))
-  ;;
-  ;; String name of the routine and symbol name of the interface function.
-  (name "" :type string)
-  (function-name nil :type symbol)
-  ;;
-  ;; List of all the doc strings.
-  docs
-  ;;
-  ;; List of Arg-Info structures describing the args.
-  (args () :type list))
+(def-alien-type char (integer 8))
+(def-alien-type short (integer 16))
+(def-alien-type int (integer 32))
+(def-alien-type long (integer 32))
 
-(defstruct arg-info
-  ;;
-  ;; Symbol name of the arg.
-  (name (required-argument) :type symbol)
-  ;;
-  ;; C-Type describing the actual argument to the routine.
-  (type (required-argument) :type c-type)
-  ;;
-  ;; Specified mode and options.
-  mode
-  options
-  ;;
-  ;; Either the name for :in, or some form for others.
-  passing-form
-  )
+(def-alien-type unsigned-char (unsigned 8))
+(def-alien-type unsigned-short (unsigned 16))
+(def-alien-type unsigned-int (unsigned 32))
+(def-alien-type unsigned-long (unsigned 32))
 
+(def-alien-type float single-float)
+(def-alien-type double double-float)
 
-(defun alien-arg-type (arg)
-  (if (not (eq (arg-info-mode arg) :in))
-      'system-area-pointer
-      (etypecase (arg-info-type arg)
-	(primitive-type
-	 (let* ((descr (c-type-description (arg-info-type arg)))
-		(name (if (atom descr) descr (car descr)))
-		(type-arg (if (consp descr) (cadr descr))))
-	   (ecase name
-	     ((signed-byte unsigned-byte system-area-pointer port
-			   single-float double-float)
-	      descr)
-	     (boolean
-	      (setf (arg-info-passing-form arg)
-		    `(if ,(arg-info-passing-form arg) 1 0))
-	      (if type-arg
-		  `(unsigned-byte ,type-arg)
-		  '(unsigned-byte 32)))
-	     (null-terminated-string
-	      (setf (arg-info-passing-form arg)
-		    `(vector-sap (the simple-base-string
-				      ,(arg-info-passing-form arg))))
-	      'system-area-pointer))))
-	(record-type
-	 (error "Can't pass records by value yet."))
-	(pointer-type
-	 (setf (arg-info-passing-form arg)
-	       `(alien-sap (alien-access ,(arg-info-passing-form arg))))
-	 'system-area-pointer)
-	(array-type
-	 (setf (arg-info-passing-form arg)
-	       `(alien-sap ,(arg-info-passing-form arg)))
-	 'system-area-pointer))))
+(def-alien-type-translator void ()
+  (parse-alien-type '(values)))
 
-(defun compute-call-form (name return-type arg-types args)
-  (flet ((sub-compute-call-form (return-alien-type)
-	   `(call-foreign-function ,name
-				   ',return-alien-type
-				   ',arg-types
-				   ,@args)))
-    (etypecase return-type
-      (null
-       (sub-compute-call-form nil))
-      (primitive-type
-       (let* ((descr (c-type-description return-type))
-	      (name (if (atom descr) descr (car descr)))
-	      (arg (if (consp descr) (cadr descr))))
-	 (ecase name
-	   ((signed-byte unsigned-byte system-area-pointer port
-			 single-float double-float)
-	    (sub-compute-call-form descr))
-	   (null-terminated-string
-	    `(alien-access (make-alien ',descr
-				       ,(c-type-size return-type)
-				       ,(sub-compute-call-form
-					 'system-area-pointer))
-			   'simple-base-string))
-	   (boolean
-	    `(not (zerop ,(sub-compute-call-form '(unsigned-byte 32)))))
-	   (alien
-	    (unless (> (length descr) 2)
-	      (error "Alien return types must include the size: ~S"
-		     descr))
-	    `(make-alien ',arg
-			 ',(caddr descr)
-			 ,(sub-compute-call-form 'system-area-pointer)))
-	   
-	   (enumeration
-	    (error "Can't return ~S yet." descr)))))
-      (record-type
-       (error "Can't return ~S yet." (c-type-description return-type)))
-      (pointer-type
-       (let ((type (pointer-type-to return-type)))
-	 (unless (c-type-size type)
-	   (error "Can't return pointers to objects of unknown size: ~S"
-		  (c-type-description return-type)))
-	 (let ((sap (gensym "SAP-")))
-	   `(let ((,sap ,(sub-compute-call-form 'system-area-pointer)))
-	      (unless (zerop (sap-int ,sap))
-		(make-alien ',(c-type-description type)
-			    ,(c-type-size type)
-			    ,sap))))))
-      (array-type
-       (unless (c-type-size return-type)
-	 (error "Can't return arrays of unknown size: ~S"
-		(c-type-description return-type)))
-       `(make-alien ',(c-type-description return-type)
-		    ,(c-type-size return-type)
-		    ,(sub-compute-call-form 'system-area-pointer))))))
-
-
-(defmacro def-c-routine (name (return-type) &rest specs)
-  "Def-C-Routine Name (Return-Type Option*)
-                    {(Arg-Name Arg-Type [Mode] Arg-Option*)}*
-
-  Define a foreign interface function for the routine with the specified string
-  Name.  Normally the interface function is named by interning the uppercased
-  name in the current package.  A different interface function name may be
-  specified by using a list (Name Function-Name) in the place of Name.
-  
-  Return-Type is the C-Type for the C function return value.  Void may be used
-  to specify a function with no result.
-
-  The remaining forms specifiy individual arguments that are passed to the
-  routine.  Arg-Name is a symbol that names the argument, primarily for
-  documentation.  Arg-Type is the C-Type of the argument.  Mode specifies the
-  say that the argument is passed.
-
-  :In
-        An :In argument is simply passed by value.  The value to be passed is
-        obtained from argument(s) to the interface function.  No values are
-        returned for :In arguments.  This is the default mode.
-
-  :Out
-        The specified argument type must be a pointer to a fixed sized object.
-        A pointer to a preallocated object is passed to the routine, and the
-        the object is accessed on return, with the value(s) being returned from
-        the interface function.
-
-  :Copy
-        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
-        A combination of :Out and :Copy.  A pointer to the argument is passed,
-        with the object being initialized from supplied argument(s) and
-        return value(s) being determined by accessing the object on return."
-
-  (let ((info (make-routine-info)))
-    (cond ((stringp name)
-	   (setf (routine-info-name info) name)
-	   (setf (routine-info-function-name info)
-		 (intern (string-upcase name))))
-	  ((and (listp name) (= (length name) 2)
-		(stringp (first name)) (symbolp (second name)))
-	   (setf (routine-info-name info) (first name))
-	   (setf (routine-info-function-name info) (second name)))
-	  (t
-	   (error "Malformed routine name specification: ~S." name)))
-
-    (let ((docs ())
-	  (arg-info ()))
-      (dolist (spec specs)
-	(cond ((stringp spec)
-	       (push spec docs))
-	      ((and (listp spec) (>= (length spec) 2))
-	       (let ((arg-name (first spec))
-		     (arg-type (get-c-type (second spec)))
-		     (mode (or (third spec) :in))
-		     (options (cdddr spec)))
-		 (when (oddp (length options))
-		   (error "Odd number of options in ~S." spec))
-		 (unless (symbolp arg-name)
-		   (error "Arg name is not a symbol: ~S." arg-name))
-		 (push (make-arg-info :name arg-name :type arg-type
-				      :mode mode :options options)
-		       arg-info)))
-	      (t
-	       (error "Bad argument spec: ~S." spec))))
-
-      (setf (routine-info-docs info) (nreverse docs))
-      (setf (routine-info-args info) (nreverse arg-info)))
-
-    (let ((lisp-args nil)
-	  (buffer-name (symbolicate (routine-info-function-name info)
-				    "-BUFFER"))
-	  (buffer-offset 0)
-	  (top-level-forms nil)
-	  (arg-set-forms nil)
-	  (result-get-forms nil))
-      (dolist (arg (routine-info-args info))
-	(let ((operator nil))
-	  (cond ((not (eq (arg-info-mode arg) :in))
-		 (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)))
-		 (setf operator 
-		       (symbolicate (routine-info-function-name info)
-				    "-"
-				    (arg-info-name arg)
-				    "-SLOT"))
-		 (let* ((type (pointer-type-to (arg-info-type arg)))
-			(size (c-type-size type))
-			(offset (align-offset buffer-offset
-					      (find-alignment size))))
-		   (setf buffer-offset (+ offset size))
-		   (push `(defoperator (,operator
-					,(c-type-description type))
-				       ((foo ,buffer-name))
-			    `(alien-index (alien-value ,foo) ,,offset ,,size))
-			 top-level-forms)
-		   (setf (arg-info-passing-form arg)
-			 `(alien-sap (,operator (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 operator
-	      (push `(setf (alien-access (,operator (alien-value stack)))
-			   ,(arg-info-name arg))
-		    arg-set-forms)))
-	  
-	  (when (member (arg-info-mode arg) '(:out :in-out))
-	    (assert operator)
-	    (push `(alien-access (,operator (alien-value stack)))
-		  result-get-forms))))
-      
-      (let* ((call-form
-	      (compute-call-form (routine-info-name info)
-				 (unless (eq return-type 'void)
-				   (get-c-type return-type))
-				 (mapcar #'alien-arg-type
-					 (routine-info-args info))
-				 (mapcar #'arg-info-passing-form
-					 (routine-info-args info))))
-	     (call-forms
-	      (if (eq return-type 'void)
-		  (if (null result-get-forms)
-		      `(,call-form
-			(undefined-value))
-		      `(,call-form
-			(values ,@(nreverse result-get-forms))))
-		  (if (null result-get-forms)
-		      `(,call-form)
-		      `((values ,call-form
-				,@(nreverse result-get-forms)))))))
-	(unless (zerop buffer-offset)
-	  (setf call-forms
-		`((with-stack-alien (stack ,buffer-name ,buffer-offset)
-		    ,@(nreverse arg-set-forms)
-		    ,@call-forms))))
-	
-	`(progn
-	   ,@(when top-level-forms
-	       `((compiler-let ((*alien-eval-when* '(compile eval)))
-		   ,@(nreverse top-level-forms))))
-	   (defun ,(routine-info-function-name info) ,(nreverse lisp-args)
-	     ,@(or (routine-info-docs info)
-		   (list (make-doc-string info return-type)))
-	     ,@call-forms))))))
-
-
-;;; Make-Doc-String  --  Internal
-;;;
-;;;    Make a doc string for the interface routine described by Info.  Values
-;;; is a list of the names of the by-reference return values.
-;;;
-(proclaim '(function make-doc-string (routine-info t) string))
-(defun make-doc-string (info return-type)
-  (let ((*print-pretty* t)
-	(*print-case* :downcase)
-	(values (mapcar #'arg-info-name
-			(remove-if-not #'(lambda (mode)
-					   (member mode '(:out :in-out)))
-				       (routine-info-args info)
-				       :key #'arg-info-mode))))
-    (format nil "Interface to foreign routine ~S~:[; returns no values.~;~
-	    ~:*, return values:~%  ~A~]"
-	    (routine-info-name info)
-	    (if (eq return-type 'void)
-		values
-		(cons 'return-value values)))))
 
 
-;;; 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.
-
-(defmacro def-c-variable (name type)
-  "Defines a foreign variable so that it is available from Lisp.
-  Name should either be a string with the name of the foreign variable or
-  a list of the string and the symbol to use as the alien variable. 
-  Type is the foreign type of the variable."
-  (multiple-value-bind
-      (symbol name)
-      (cond ((stringp name)
-	     (values (intern (string-upcase name))
-		     name))
-	    ((and (consp name) (= (length name) 2)
-		  (stringp (car name)) (symbolp (cadr name)))
-	     (values (cadr name) (car name)))
-	    (t
-	     (error "Bogus name for def-c-variable: ~S.~%~
-	     Should be either a string or a list of a string and symbol."
-		    name)))
-    (let* ((c-info (get-c-type type))
-	   (c-type (if (primitive-type-p c-info)
-		       (c-type-description c-info)
-		       type))
-	   (c-size (c-type-size c-info)))
-      `(progn
-	 (defparameter ,symbol
-	   (make-alien ',c-type ,c-size
-		       (truly-the system-area-pointer
-				  (%primitive c::foreign-symbol-address
-					      ,name))))
-	 (eval-when ,*alien-eval-when*
-	   (setf (info variable alien-value ',symbol)
-		 (lisp::make-ct-a-val
-		  :type ',c-type
-		  :size ,c-size
-		  :offset 0
-		  :sap '(truly-the system-area-pointer
-				   (%primitive c::foreign-symbol-address
-					       ,name))
-		  :alien ',symbol)))))))
-
-#|
-;;; Def-C-Procedure defines data structures etc. so that C can be passed
-;;; a pointer to a C procedure object which when called will invoke a Lisp
-;;; function.  Def-C-Procedure accepts three arguments: a symbol whose
-;;; value is set to an object which can be written to alien-structures
-;;; that will look like a c procedure object; a number which is a constant
-;;; number of arguments that the C routine will be called with; and a Lisp
-;;; function (an object callable as a function) which should accept the
-;;; same number of arguments and will be called when the C procedure object
-;;; is invoked.
-
-(defmacro def-c-procedure (name nargs lfunc)
-  "Assigns to the value of the symbol name  an object which can be
-  passed to a foreign function as a procedure object.  Nargs is the
-  number of arguments the procedure should accept.  Lfunc is the Lisp
-  function will be called when the procedure is called.  Lfunc should
-  be callable by apply."
-  (let ((var (gensym)))
-  `(defparameter ,name
-     (let ((,var (%primitive alloc-static-g-vector 3)))
-       (setf (svref ,var 0)
-	     (int-sap (logior (ash clc::type-assembler-code
-				   (+ clc::type-shift-16 16))
-			      (get 'clc::call-lisp
-				   'lisp::%loaded-address))))
-       (setf (svref ,var 1) ,nargs)
-       (setf (svref ,var 2) ,lfunc)
-       ,var))))
-
-;;; Call-Lisp-from-C is a Lisp function that gains control when a C
-;;; function calls a procedure object that is defined as above.  It
-;;; wraps an unwind-protect around the call to the function, so that
-;;; if we throw passed it, the c-stack-information will be reset.
-
-(defun call-lisp-from-c (old-c-stack procedure &rest args)
-  (unwind-protect
-    (let ((rv (apply (svref procedure 2) args)))
-	(%primitive return-to-c old-c-stack rv))
-    (%primitive reset-c-stack old-c-stack)))
-
-;;; Reset-foreign-pointers goes through the list of all defined foreign
-;;; functions and variables and sets the pointers to their new location.
-
-(defun reset-foreign-pointers ()
-  "Reset all the code and variable pointers that may have moved."
-  (dolist (x foreign-routines-defined)
-    (setf (symbol-value (car x)) (get-code-pointer (cdr x))))
-  (dolist (x foreign-variables-defined)
-    (setf (lisp::alien-value-sap (symbol-value (car x)))
-	  (get-data-pointer (cdr x)))))
-|#
-
-#-new-compiler
-(eval-when (compile)
-  (setq lisp::*bootstrap-defmacro* nil))
-
+;;;; C string support.
+
+(def-alien-type-class (c-string :include pointer))
+
+(def-alien-type-translator c-string ()
+  (make-alien-c-string-type :to (parse-alien-type 'char)))
+
+(def-alien-type-method (c-string :unparse) (type)
+  (declare (ignore type))
+  'c-string)
+
+(def-alien-type-method (c-string :lisp-rep) (type)
+  (declare (ignore type))
+  'simple-base-string)
+
+(def-alien-type-method (c-string :naturalize-gen) (type alien)
+  (declare (ignore type))
+  `(%naturalize-c-string ,alien))
+
+(def-alien-type-method (c-string :deport-gen) (type value)
+  (declare (ignore type))
+  `(vector-sap ,value))
+
+(defun %naturalize-c-string (sap)
+  (declare (type system-area-pointer sap))
+  (with-alien ((ptr (* char) sap))
+    (locally
+     (declare (optimize (speed 3) (safety 0)))
+     (let ((length (loop
+		     for offset of-type fixnum upfrom 0
+		     until (zerop (deref ptr offset))
+		     finally return offset)))
+       (let ((result (make-string length)))
+	 (kernel:copy-from-system-area (alien-sap ptr) 0
+				       result (* vm:vector-data-offset
+						 vm:word-bits)
+				       (* length vm:byte-bits))
+	 result)))))
diff --git a/code/debug-int.lisp b/code/debug-int.lisp
index e6e5ae538f568ed849f0fad69b0fd8d7b505342d..7febc0794ec1b90ace3e8d07d590cf8f1b765237 100644
--- a/code/debug-int.lisp
+++ b/code/debug-int.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/debug-int.lisp,v 1.35 1992/01/14 15:07:31 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/debug-int.lisp,v 1.36 1992/02/14 23:44:21 wlott Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -853,20 +853,13 @@
 ;;;
 (defsetf kernel:stack-ref kernel:%set-stack-ref)
 
-(ext:def-c-variable "control_stack" system:system-area-pointer)
-
 (proclaim '(inline cstack-pointer-valid-p))
 (defun cstack-pointer-valid-p (x)
   (declare (type system:system-area-pointer x))
-  (and (system:pointer< x (kernel:current-sp))
-       (not (system:pointer< x (system:alien-access
-				(system:alien-value control_stack))))))
-
-
-(ext:def-c-array interrupt-array mach:*sigcontext 4096)
-
-(ext:def-c-variable "lisp_interrupt_contexts" interrupt-array)
-
+  (and (system:sap< x (kernel:current-sp))
+       (system:sap<= (alien:alien-sap (alien:extern-alien "control_stack"
+							  (* t)))
+		     x)))
 
 ;;; TOP-FRAME -- Public.
 ;;;
@@ -1055,55 +1048,45 @@
 (defun find-escaped-frame (frame-pointer)
   (declare (type system:system-area-pointer frame-pointer))
   (dotimes (index lisp::*free-interrupt-context-index* (values nil 0 nil))
-    (system:alien-bind ((scp (interrupt-array-ref
-			      (system:alien-value lisp_interrupt_contexts)
-			      index)
-			     (system:alien mach:sigcontext
-					   #.(ext:c-sizeof 'mach:sigcontext))
-			     t)
-			(sc (mach:indirect-*sigcontext scp) mach:sigcontext t)
-			(regs (mach:sigcontext-regs (system:alien-value sc))
-			      mach:int-array t))
-      (when (= (system:sap-int frame-pointer)
-	       (system:alien-access (mach:int-array-ref regs vm::cfp-offset)))
-	(system:without-gcing
-	 (let ((code (code-object-from-bits
-		      (system:alien-access (mach:int-array-ref
-					    regs vm::code-offset)))))
-	   (when (symbolp code)
-	     (return (values code 0 (system:alien-value sc))))
-	   (let* ((code-header-len (* (kernel:get-header-data code)
-				      vm:word-bytes))
-		  (pc-offset
-		   (- (system:sap-int
-		       (system:alien-access
-			(mach:sigcontext-pc (system:alien-value sc))))
-		      (- (kernel:get-lisp-obj-address code)
-			 vm:other-pointer-type)
-		      code-header-len)))
-	     ;; Check to see if we were executing in a branch delay slot.
-	     #+pmax  ; pmax only
-	     (when (logbitp 31 (system:alien-access
-				(mach:sigcontext-cause (system:alien-value sc))))
-	       (incf pc-offset vm:word-bytes))
-	     (unless (<= 0 pc-offset
-			 (* (ext:truly-the lisp::index
-					   (system:%primitive c::code-code-size
-							      code))
-			    vm:word-bytes))
-	       ;; We were in an assembly routine.  Therefore, use the LRA as
-	       ;; the pc.
-	       (setf pc-offset
-		     (- (escape-register (system:alien-value sc) vm::lra-offset)
-			(kernel:get-lisp-obj-address code)
+    (alien:with-alien
+	((lisp-interrupt-contexts (array (* unix:sigcontext) nil) :extern))
+      (let ((scp (alien:deref lisp-interrupt-contexts index)))
+	(when (= (system:sap-int frame-pointer)
+		 (vm:sigcontext-register scp vm::cfp-offset))
+	  (system:without-gcing
+	   (let ((code (code-object-from-bits
+			(vm:sigcontext-register scp vm::code-offset))))
+	     (when (symbolp code)
+	       (return (values code 0 scp)))
+	     (let* ((code-header-len (* (kernel:get-header-data code)
+					vm:word-bytes))
+		    (pc-offset
+		     (- (system:sap-int (alien:slot scp 'unix:sc-pc))
+			(- (kernel:get-lisp-obj-address code)
+			   vm:other-pointer-type)
 			code-header-len)))
-	     (return
-	      (if (eq (kernel:code-debug-info code) :bogus-lra)
-		  (let ((real-lra (kernel:code-header-ref code real-lra-slot)))
-		    (values (kernel:lra-code-header real-lra)
-			    (kernel:get-header-data real-lra)
-			    nil))
-		  (values code pc-offset (system:alien-value sc)))))))))))
+	       ;; Check to see if we were executing in a branch delay slot.
+	       #+pmax  ; pmax only
+	       (when (logbitp 31 (alien:slot scp 'mips::sc-cause))
+		 (incf pc-offset vm:word-bytes))
+	       (unless (<= 0 pc-offset
+			   (* (kernel:code-header-ref code
+						      vm:code-code-size-slot)
+			      vm:word-bytes))
+		 ;; We were in an assembly routine.  Therefore, use the LRA as
+		 ;; the pc.
+		 (setf pc-offset
+		       (- (vm:sigcontext-register scp vm::lra-offset)
+			  (kernel:get-lisp-obj-address code)
+			  code-header-len)))
+	       (return
+		(if (eq (kernel:code-debug-info code) :bogus-lra)
+		    (let ((real-lra (kernel:code-header-ref code
+							    real-lra-slot)))
+		      (values (kernel:lra-code-header real-lra)
+			      (kernel:get-header-data real-lra)
+			      nil))
+		    (values code pc-offset scp)))))))))))
 
 ;;; CODE-OBJECT-FROM-BITS  --  internal.
 ;;;
@@ -1131,55 +1114,6 @@
 ;;; Frame utilities.
 ;;;
 
-;;; ESCAPE-REGISTER -- Internal.
-;;;
-;;; An escape register saves the value of a register for a frame that someone
-;;; interrupts.  
-;;;
-(defun escape-register (scp index)
-  (system:alien-bind ((sc scp mach:sigcontext t)
-		      (regs (mach:sigcontext-regs (system:alien-value sc))
-			    mach:int-array t))
-    (system:alien-access (mach:int-array-ref (system:alien-value regs) index))))
-
-(defun %set-escape-register (scp index new)
-  (system:alien-bind ((sc scp mach:sigcontext t)
-		      (regs (mach:sigcontext-regs (system:alien-value sc))
-			    mach:int-array t))
-    (setf (system:alien-access (mach:int-array-ref (system:alien-value regs)
-						   index))
-	  new)))
-
-(defsetf escape-register %set-escape-register)
-
-
-;;; ESCAPE-FLOAT-REGISTER  --  Internal
-;;;
-;;;    Like ESCAPE-REGISTER, but returns the value of a float register.  Format
-;;; is the type of float to return.
-;;;
-(defun escape-float-register (scp index format)
-  (system:alien-bind ((sc scp mach:sigcontext t)
-		      (fpregs (mach:sigcontext-fpregs (system:alien-value sc))
-			      mach:int-array t))
-    (let ((sap (system:alien-sap fpregs)))
-      (ecase format
-	(single-float (system:sap-ref-single sap index))
-	(double-float (system:sap-ref-double sap index))))))
-;;;
-(defun %set-escape-float-register (scp index format new-value)
-  (system:alien-bind ((sc scp mach:sigcontext t)
-		      (fpregs (mach:sigcontext-fpregs (system:alien-value sc))
-			      mach:int-array t))
-    (let ((sap (system:alien-sap fpregs)))
-      (ecase format
-	(single-float
-	 (setf (system:sap-ref-single sap index) new-value))
-	(double-float
-	 (setf (system:sap-ref-double sap index) new-value))))))
-;;;
-(defsetf escape-float-register %set-escape-float-register)
-
 ;;; DEBUG-FUNCTION-FROM-PC -- Internal.
 ;;;
 ;;; This returns a compiled-debug-function for code and pc.  We fetch the
@@ -2451,21 +2385,23 @@
 (defun sub-access-debug-var-slot (fp sc-offset &optional escaped)
   (macrolet ((with-escaped-value ((var) &body forms)
 	       `(if escaped
-		    (let ((,var (escape-register
+		    (let ((,var (vm:sigcontext-register
 				 escaped
 				 (c::sc-offset-offset sc-offset))))
 		      ,@forms)
 		    :invalid-value-for-unescaped-register-storage))
 	     (escaped-float-value (format)
 	       `(if escaped
-		    (escape-float-register escaped
-					   (c::sc-offset-offset sc-offset)
-					   ',format)
+		    (vm:sigcontext-float-register
+		     escaped
+		     (c::sc-offset-offset sc-offset)
+		     ',format)
 		    :invalid-value-for-unescaped-register-storage))
 	     (with-nfp ((var) &body body)
 	       `(let ((,var (if escaped
 				(system:int-sap
-				 (escape-register escaped vm::nfp-offset))
+				 (vm:sigcontext-register escaped
+							 vm::nfp-offset))
 				(system:sap-ref-sap fp vm::nfp-save-offset))))
 		  ,@body)))
     (ecase (c::sc-offset-scn sc-offset)
@@ -2571,13 +2507,14 @@
 (defun sub-set-debug-var-slot (fp sc-offset value &optional escaped)
   (macrolet ((set-escaped-value (val)
 	       `(if escaped
-		    (setf (escape-register escaped
-					   (c::sc-offset-offset sc-offset))
+		    (setf (vm:sigcontext-register
+			   escaped
+			   (c::sc-offset-offset sc-offset))
 			  ,val)
 		    value))
 	     (set-escaped-float-value (format val)
 	       `(if escaped
-		    (setf (escape-float-register
+		    (setf (vm:sigcontext-float-register
 			   escaped
 			   (c::sc-offset-offset sc-offset)
 			   ',format)
@@ -2586,7 +2523,8 @@
 	     (with-nfp ((var) &body body)
 	       `(let ((,var (if escaped
 				(system:int-sap
-				 (escape-register escaped vm::nfp-offset))
+				 (vm:sigcontext-register escaped
+							 vm::nfp-offset))
 				(system:sap-ref-sap fp vm::nfp-save-offset))))
 		  ,@body)))
     (ecase (c::sc-offset-scn sc-offset)
@@ -3271,9 +3209,9 @@
 ;;; the overwritten bits.  You must call this in a context in which GC is
 ;;; disabled, so Lisp doesn't move objects around that C is pointing to.
 ;;;
-(ext:def-c-routine "breakpoint_install" (ext:unsigned-long)
-  (code-obj ext:unsigned-long)
-  (pc-offset ext:int))
+(alien:def-alien-routine "breakpoint_install" c-call:unsigned-long
+  (code-obj c-call:unsigned-long)
+  (pc-offset c-call:int))
 
 ;;; BREAKPOINT_REMOVE -- Internal.
 ;;;
@@ -3281,17 +3219,17 @@
 ;;; You must call this in a context in which GC is disabled, so Lisp doesn't
 ;;; move objects around that C is pointing to.
 ;;;
-(ext:def-c-routine "breakpoint_remove" (ext:void)
-  (code-obj ext:unsigned-long)
-  (pc-offset ext:int)
-  (old-inst ext:unsigned-long))
+(alien:def-alien-routine "breakpoint_remove" c-call:void
+  (code-obj c-call:unsigned-long)
+  (pc-offset c-call:int)
+  (old-inst c-call:unsigned-long))
 
 ;;; BREAKPOINT_AFTER_OFFSET -- Internal.
 ;;;
 ;;; This returns the offset of the next instruction following the break that
 ;;; generated the signal context we supply as an argument to this routine.
 ;;;
-(ext:def-c-routine "breakpoint_after_offset" (ext:int)
+(alien:def-alien-routine "breakpoint_after_offset" c-call:int
   (scp system:system-area-pointer))
 
 ;;;
@@ -3386,7 +3324,7 @@
       ;; Set the sigmask, to keep the system running until we can
       ;; remove the after breakpoints and re-install the user breakpoints.
       (setf (breakpoint-data-sigmask data)
-	    (mach:unix-sigblock (mach:sigmask :sigint :sigquit :sigtstp))))))
+	    (unix:unix-sigblock (unix:sigmask :sigint :sigquit :sigtstp))))))
 
 (defun handle-after-breakpoint (after breakpoints data offset component)
   (let ((previous-data (after-breakpoint-previous-data after)))
@@ -3418,7 +3356,7 @@
 			  (breakpoint-data-component previous-data))
 			 (breakpoint-data-offset previous-data)))
     ;; Restore sigmask that we saved before executing previous's inst.
-    (mach:unix-sigsetmask (breakpoint-data-sigmask previous-data))))
+    (unix:unix-sigsetmask (breakpoint-data-sigmask previous-data))))
 
 (defun invoke-breakpoint-hooks (breakpoints component offset after)
   (let* ((debug-fun (debug-function-from-pc component offset))
@@ -3469,41 +3407,36 @@
 ;;;
 (defun handle-function-end-breakpoint (breakpoints data signal-context)
   (delete-breakpoint-data data)
-  (system:alien-bind ((sc (system:make-alien 'mach:sigcontext
-					     #.(ext:c-sizeof 'mach:sigcontext)
-					     signal-context)
-			  mach:sigcontext
-			  t))
-    (let* ((frame (do ((cfp (escape-register sc vm::cfp-offset))
-		       (f (top-frame) (frame-down f)))
-		      ((= cfp (system:sap-int (frame-pointer f))) f)
-		    (declare (type (unsigned-byte #.vm:word-bits) cfp))))
-	   (component (breakpoint-data-component data))
-	   (cookie (gethash component *function-end-cookies*)))
-      (remhash component *function-end-cookies*)
-      (dolist (bpt breakpoints)
-	(funcall (breakpoint-hook-function bpt)
-		 frame bpt
-		 (get-function-end-breakpoint-values (system:alien-value sc))
-		 cookie)))))
-
-(defun get-function-end-breakpoint-values (sc)
-  (system:alien-bind ((sc sc mach:sigcontext t))
-    (let ((ocfp (system:int-sap (escape-register sc vm::ocfp-offset)))
-	  (nargs (kernel:make-lisp-obj (escape-register sc vm::nargs-offset)))
-	  (reg-arg-offsets vm::register-arg-offsets)
-	  (results nil))
-      (system:without-gcing
-       (dotimes (arg-num nargs)
-	 (push (if reg-arg-offsets
-		   (kernel:make-lisp-obj
-		    (escape-register sc (pop reg-arg-offsets)))
-		   (kernel:stack-ref ocfp arg-num))
-	       results)))
-      (nreverse results))))
+  (let* ((scp (alien:sap-alien signal-context (* unix:sigcontext)))
+	 (frame (do ((cfp (vm:sigcontext-register scp vm::cfp-offset))
+		     (f (top-frame) (frame-down f)))
+		    ((= cfp (system:sap-int (frame-pointer f))) f)
+		  (declare (type (unsigned-byte #.vm:word-bits) cfp))))
+	 (component (breakpoint-data-component data))
+	 (cookie (gethash component *function-end-cookies*)))
+    (remhash component *function-end-cookies*)
+    (dolist (bpt breakpoints)
+      (funcall (breakpoint-hook-function bpt)
+	       frame bpt
+	       (get-function-end-breakpoint-values scp)
+	       cookie))))
+
+(defun get-function-end-breakpoint-values (scp)
+  (let ((ocfp (system:int-sap (escape-register scp vm::ocfp-offset)))
+	(nargs (kernel:make-lisp-obj (escape-register scp vm::nargs-offset)))
+	(reg-arg-offsets vm::register-arg-offsets)
+	(results nil))
+    (system:without-gcing
+     (dotimes (arg-num nargs)
+       (push (if reg-arg-offsets
+		 (kernel:make-lisp-obj
+		  (vm:sigcontext-register scp (pop reg-arg-offsets)))
+		 (kernel:stack-ref ocfp arg-num))
+	     results)))
+    (nreverse results)))
 
 
-;;; CALL-BREAKPOINT_AFTER_OFFSET -- Internal.
+;;; CAL<L-BREAKPOINT_AFTER_OFFSET -- Internal.
 ;;;
 ;;; This calls the C routine and massages its return values.  Originally the
 ;;; breakpoint code was designed for the C code to return multiple offsets when
@@ -3534,18 +3467,12 @@
    are returned: the bogus LRA object, the code component it is part of, and the
    PC offset for the trap instruction."
   (system:without-gcing
-   (let* ((src-start (ext:truly-the system:system-area-pointer
-				    (system:%primitive
-				     c:foreign-symbol-address
-				     "function_end_breakpoint_guts")))
-	  (src-end (ext:truly-the system:system-area-pointer
-				  (system:%primitive
-				   c:foreign-symbol-address
-				   "function_end_breakpoint_end")))
-	  (trap-loc (ext:truly-the system:system-area-pointer
-				   (system:%primitive
-				    c:foreign-symbol-address
-				    "function_end_breakpoint_trap")))
+   (let* ((src-start (system:foreign-symbol-address
+		      "function_end_breakpoint_guts"))
+	  (src-end (system:foreign-symbol-address
+		    "function_end_breakpoint_end"))
+	  (trap-loc (system:foreign-symbol-address
+		     "function_end_breakpoint_trap"))
 	  (length (system:sap- src-end src-start))
 	  (code-object (system:%primitive c:allocate-code-object
 					  (1+ bogus-lra-constants)
diff --git a/code/debug.lisp b/code/debug.lisp
index 0fe9b29fe0a07d89ad8b77be5cd607fdf5982fc9..a2499598c03c8c2c6608aa08ef5acd06227c6576 100644
--- a/code/debug.lisp
+++ b/code/debug.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/debug.lisp,v 1.25 1991/12/16 09:27:25 wlott Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/debug.lisp,v 1.26 1992/02/14 23:44:34 wlott Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -258,7 +258,7 @@
      (t
       (when number
 	(format t "~&~S: " (di:frame-number frame)))
-  (mach:unix-sigsetmask 0)
+      (print-frame-call-1 frame)))
     (when (>= verbosity 2)
       (let ((loc (di:frame-code-location frame)))
 	 (*debug-abort* (find-restart 'abort))
diff --git a/code/exports.lisp b/code/exports.lisp
index 929bc9ed2f52634f212fe4a903f78be1523b4f2d..69b5f1a9c550c6148eb295ae3898ccfa4a0c4554 100644
--- a/code/exports.lisp
+++ b/code/exports.lisp
@@ -7,790 +7,1711 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/exports.lisp,v 1.70 1991/12/06 17:53:04 wlott Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/exports.lisp,v 1.71 1992/02/14 23:44:37 wlott Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
-;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/exports.lisp,v 1.70 1991/12/06 17:53:04 wlott Exp $
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/exports.lisp,v 1.71 1992/02/14 23:44:37 wlott Exp $
 ;;;
 ;;; All the stuff necessary to export various symbols from various packages.
 ;;;
-;;; Written by William Lott.
-;;; 
-
-
-;;; Create the packages
-
-(in-package "LISP")
-(in-package "KERNEL")
-(in-package "SYSTEM" :nicknames '("SYS"))
-(in-package "EXTENSIONS" :nicknames '("EXT"))
-(in-package "USER")
-(in-package "VM")
-(in-package "C")
-(in-package "ASSEMBLER" :nicknames '("ASSEM"))
-(in-package "BIGNUM")
-(in-package "DEBUG")
-(in-package "DEBUG-INTERNALS" :nicknames '("DI"))
-(in-package "MACH")
-(in-package "USER")
-
-
-(in-package "LISP")
-
-(use-package "KERNEL")
-(use-package "EXT")
-(use-package "SYSTEM")
-(use-package "BIGNUM")
-
-(export '(&allow-other-keys &aux &body &environment &key &optional &rest
-	  &whole * ** *** *applyhook* *break-on-signals*
-	  *break-on-warnings* *debug-io* *debugger-hook*
-	  *default-pathname-defaults* *error-output* *evalhook* *features*
-	  *gensym-counter* *load-verbose* *macroexpand-hook* *modules*
-	  *package* *print-array* *print-base* *print-case* *print-circle*
-	  *print-escape* *print-gensym* *print-length* *print-level*
-	  *print-pretty* *print-radix* *query-io* *random-state*
-	  *read-base* *read-default-float-format* *read-suppress*
-
-	  *readtable* *standard-input* *standard-output* *terminal-io*
-	  *trace-output* + ++ +++ - / // /// /= 1+ 1- < <= = > >= abort abs
-	  acons acos acosh adjoin adjust-array adjustable-array-p
-	  alpha-char-p alphanumericp and append apply applyhook apropos
-	  apropos-list aref arithmetic-error arithmetic-error-operands
-	  arithmetic-error-operation array array-dimension
-	  array-dimension-limit array-dimensions array-element-type
-	  array-has-fill-pointer-p array-in-bounds-p array-rank
-	  array-rank-limit array-row-major-index array-total-size
-	  array-total-size-limit arrayp ash asin asinh assert assoc
-	  assoc-if assoc-if-not atan atanh atom base-char base-string
-	  bignum bit bit-and bit-andc1 bit-andc2 bit-eqv bit-ior bit-nand
-	  bit-nor bit-not bit-orc1 bit-orc2 bit-vector bit-vector-p bit-xor
-	  block boole boole-1 boole-2 boole-and boole-andc1 boole-andc2
-	  boole-c1 boole-c2 boole-clr boole-eqv boole-ior boole-nand
-	  boole-nor boole-orc1 boole-orc2 boole-set boole-xor both-case-p
-	  boundp break butlast byte byte-position byte-size caaaar caaadr
-	  caaar caadar caaddr caadr caar cadaar cadadr cadar caddar cadddr
-	  caddr cadr call-arguments-limit car case catch ccase cdaaar
-	  cdaadr cdaar cdadar cdaddr cdadr cdar cddaar cddadr cddar cdddar
-	  cddddr cdddr cddr cdr ceiling cell-error cerror char char-bit
-	  char-bits char-bits-limit char-code char-code-limit
-	  char-control-bit char-downcase char-equal char-font
-	  char-font-limit char-greaterp char-hyper-bit char-int char-lessp
-	  char-meta-bit char-name char-not-equal char-not-greaterp
-	  char-not-lessp char-super-bit char-upcase char/= char< char<=
-	  char= char> char>= character characterp check-type cis
-	  clear-input clear-output close clrhash code-char coerce common
-	  commonp compilation-speed compile compile-file compiled-function
-	  compiled-function-p compiler-let complex complexp
-	  compute-restarts concatenate cond condition conjugate cons consp
-	  constantp continue control-error copy-alist copy-list
-	  copy-readtable copy-seq copy-symbol copy-tree cos cosh count
-	  count-if count-if-not ctypecase debug-info decf declaration
-	  declare decode-float decode-universal-time defconstant
-	  define-condition define-modify-macro define-setf-method defmacro
-	  defparameter defsetf defstruct deftype defun defvar delete
-	  delete-duplicates delete-file delete-if delete-if-not denominator
-	  deposit-field describe digit-char digit-char-p directory
-	  directory-namestring disassemble division-by-zero do do*
-	  do-all-symbols do-external-symbols do-symbols documentation
-	  dolist dotimes double-float double-float-epsilon
-	  double-float-negative-epsilon dpb dribble ecase ed eighth elt
-	  encode-universal-time end-of-file endp enough-namestring eq eql
-	  equal equalp error etypecase eval eval-when evalhook evenp every
-	  exp export expt extended-char fboundp fceiling fdefinition
-	  ffloor fifth file-author file-error file-error-pathname
-	  file-length file-namestring file-position file-write-date fill
-	  fill-pointer find find-all-symbols find-if find-if-not
-	  find-package find-restart find-symbol finish-output first fixnum
-	  flet float float-digits float-precision float-radix float-sign
-	  floating-point-overflow floating-point-underflow floatp floor
-	  fmakunbound force-output format fourth fresh-line fround
-	  ftruncate ftype funcall function function-lambda-expression
-	  functionp gcd gensym gentemp get get-decoded-time
-	  get-dispatch-macro-character get-internal-real-time
-	  get-internal-run-time get-macro-character
-	  get-output-stream-string get-properties get-setf-method
-	  get-setf-method-multiple-value get-universal-time getf gethash go
-	  graphic-char-p handler-bind handler-case hash-table
-	  hash-table-count hash-table-p host-namestring identity if ignore
-	  ignore-errors imagpart import in-package incf inline
-	  input-stream-p inspect int-char integer integer-decode-float
-	  integer-length integerp intern internal-time-units-per-second
-	  intersection invoke-debugger invoke-restart
-	  invoke-restart-interactively isqrt keyword keywordp labels lambda
-	  lambda-list-keywords lambda-parameters-limit last lcm ldb
-	  ldb-test ldiff least-negative-double-float
-	  least-negative-long-float least-negative-short-float
-	  least-negative-single-float least-positive-double-float
-	  least-positive-long-float least-positive-short-float
-	  least-positive-single-float length let let*
-	  lisp-implementation-type lisp-implementation-version list list*
-	  list-all-packages list-length listen listp load locally log
-	  logand logandc1 logandc2 logbitp logcount logeqv logior lognand
-	  lognor lognot logorc1 logorc2 logtest logxor long-float
-	  long-float-epsilon long-float-negative-epsilon long-site-name
-	  loop lower-case-p machine-instance machine-type machine-version
-	  macro-function macroexpand macroexpand-1 macrolet make-array
-	  make-broadcast-stream make-char make-concatenated-stream
-	  make-condition make-dispatch-macro-character make-echo-stream
-	  make-hash-table make-list make-package make-pathname
-	  make-random-state make-sequence make-string
-	  make-string-input-stream make-string-output-stream make-symbol
-	  make-synonym-stream make-two-way-stream makunbound map mapc
-	  mapcan mapcar mapcon maphash mapl maplist mask-field max member
-	  member-if member-if-not merge merge-pathnames min minusp mismatch
-	  mod most-negative-double-float most-negative-fixnum
-	  most-negative-long-float most-negative-short-float
-	  most-negative-single-float most-positive-double-float
-	  most-positive-fixnum most-positive-long-float
-	  most-positive-short-float most-positive-single-float
-	  muffle-warning multiple-value-bind multiple-value-call
-	  multiple-value-list multiple-value-prog1 multiple-value-setq
-	  multiple-values-limit name-char namestring nbutlast nconc nil
-	  nintersection ninth not notany notevery notinline nreconc
-	  nreverse nset-difference nset-exclusive-or nstring-capitalize
-	  nstring-downcase nstring-upcase nsublis nsubst nsubst-if
-	  nsubst-if-not nsubstitute nsubstitute-if nsubstitute-if-not nth
-	  nthcdr null number numberp numerator nunion oddp open optimize or
-	  otherwise output-stream-p package package-error
-	  package-error-package package-name package-nicknames
-	  package-shadowing-symbols package-use-list package-used-by-list
-	  packagep pairlis parse-integer parse-namestring pathname
-	  pathname-device pathname-directory pathname-host pathname-name
-	  pathname-type pathname-version pathnamep peek-char phase pi plusp
-	  pop position position-if position-if-not pprint prin1
-	  prin1-to-string princ princ-to-string print probe-file proclaim
-	  prog prog* prog1 prog2 progn program-error progv provide psetf
-	  psetq push pushnew quote random random-state random-state-p
-	  rassoc rassoc-if rassoc-if-not ratio rational rationalize
-	  rationalp read read-byte read-char read-char-no-hang
-	  read-delimited-list read-from-string read-line
-	  read-preserving-whitespace readtable readtablep real realpart
-	  reduce rem remf remhash remove remove-duplicates remove-if
-	  remove-if-not remprop rename-file rename-package replace require
-	  rest restart restart-bind restart-case restart-name return
-	  return-from revappend reverse room rotatef round row-major-aref
-	  rplaca rplacd safety satisfies sbit scale-float schar search
-	  second sequence serious-condition set set-char-bit set-difference
-	  set-dispatch-macro-character set-exclusive-or set-macro-character
-	  set-syntax-from-char setf setq seventh shadow shadowing-import
-	  shiftf short-float short-float-epsilon
-	  short-float-negative-epsilon short-site-name signal signed-byte
-	  signum simple-array simple-base-string simple-bit-vector
-	  simple-bit-vector-p simple-condition
-	  simple-condition-format-arguments simple-condition-format-string
-	  simple-error simple-string simple-string-p simple-type-error
-	  simple-vector simple-vector-p simple-warning sin single-float
-	  single-float-epsilon single-float-negative-epsilon sinh sixth
-	  sleep software-type software-version some sort space special
-	  special-form-p speed sqrt stable-sort stack-overflow
-	  standard-char standard-char-p step storage-condition
-	  storage-exhausted store-value stream stream-element-type
-	  stream-error stream-error-stream streamp string string-capitalize
-	  string-char string-char-p string-downcase string-equal
-	  string-greaterp string-left-trim string-lessp string-not-equal
-	  string-not-greaterp string-not-lessp string-right-trim
-	  string-trim string-upcase string/= string< string<= string=
-	  string> string>= stringp structure sublis subseq subsetp subst
-	  subst-if subst-if-not substitute substitute-if substitute-if-not
-	  subtypep svref sxhash symbol symbol-function symbol-name
-	  symbol-package symbol-plist symbol-value symbolp t tagbody tailp
-	  tan tanh tenth terpri the third throw time trace tree-equal
-	  truename truncate type type-error type-error-datum
-	  type-error-expected-type type-of typecase typep unbound-variable
-	  undefined-function unexport unintern union unless unread-char
-	  unsigned-byte untrace unuse-package unwind-protect upper-case-p
-	  use-package use-value user-homedir-pathname values values-list
-	  variable vector vector-pop vector-push vector-push-extend vectorp
-	  warn warning when with-compilation-unit with-input-from-string
-	  with-open-file with-open-stream with-output-to-string
-	  with-simple-restart write write-byte write-char write-line
-	  write-string write-to-string y-or-n-p yes-or-no-p zerop))
-
-
-(in-package "KERNEL")
-
-(use-package "EXT")
-(use-package "SYSTEM")
-(use-package "BIGNUM")
-
-(export '(%array-fill-pointer %array-fill-pointer-p
-	  %array-available-elements %array-data-vector %array-displacement
-	  %array-displaced-p %array-dimension %check-bound
-	  %closure-function %closure-index-ref %dpb
-	  %function-header-arglist %function-header-name
-	  %function-header-type %ldb %negate %sxhash-simple-string
-	  %sxhash-simple-substring *empty-type* *eval-stack-top*
-	  *null-type* *universal-type* *unparse-function-type-simplify*
-	  *wild-type* 32bit-logical-not 32bit-logical-nor 32bit-logical-and
-	  32bit-logical-or 32bit-logical-xor 32bit-logical-eqv
-	  32bit-logical-nand 32bit-logical-andc1 32bit-logical-andc2
-	  32bit-logical-orc1 32bit-logical-orc2 always-subtypep args-type
-	  args-type-allowp args-type-keyp args-type-keywords
-	  args-type-optional args-type-p args-type-required args-type-rest
-	  array-rank array-total-size array-type array-type-complexp
-	  array-type-dimensions array-type-element-type array-type-p
-	  array-type-specialized-element-type ash-index bit-bash-clear
-	  bit-bash-set bit-bash-not bit-bash-copy bit-bash-and bit-bash-ior
-	  bit-bash-xor bit-bash-eqv bit-bash-lognand bit-bash-lognor
-	  bit-bash-andc1 bit-bash-andc2 bit-bash-orc1 bit-bash-orc2
-	  bit-index boole-code boolean byte-specifier callable char-int
-	  consed-sequence constant-type constant-type-p constant-type-type
-	  containing-integer-type copy-from-system-area copy-numeric-type
-	  copy-to-system-area csubtypep ctype ctype-of ctype-p ctypep
-	  data-vector-ref data-vector-set error-number-or-lose filename
-	  float-digits float-exponent float-format-max float-radix form
-	  function-type function-type-allowp function-type-keyp
-	  function-type-keywords function-type-optional function-type-p
-	  function-type-required function-type-rest function-type-returns
-	  function-type-wild-args get-header-data get-lowtag get-type
-	  hairy-type hairy-type-check-template hairy-type-specifier index
-	  internal-time irrational key-info key-info-name key-info-p
-	  key-info-type lexical-environment make-args-type
-	  make-function-type make-key-info make-member-type make-named-type
-	  make-numeric-type make-structure-type make-union-type
-	  make-values-type member-type member-type-members member-type-p
-	  merge-bits named-type named-type-name named-type-p
-	  native-byte-order negate never-subtypep numeric-contagion
-	  numeric-type numeric-type-class numeric-type-complexp
-	  numeric-type-format numeric-type-high numeric-type-low
-	  numeric-type-p parse-lambda-list parse-unknown-type
-	  parse-unknown-type-specifier pathname-device pathname-directory
-	  pathname-host pathname-name pathname-type pathname-version
-	  pathnamelike sequence-end simple-unboxed-array single-value-type
-	  specifier-type streamlike stringable stringlike structure-type
-	  structure-type-name structure-type-p system-area-clear
-	  system-area-copy truth type-expand type-init two-arg-* two-arg-+
-	  two-arg-- two-arg-/ two-arg-/= two-arg-< two-arg-<= two-arg-=
-	  two-arg-> two-arg->= two-arg-and two-arg-gcd two-arg-ior
-	  two-arg-lcm two-arg-xor type-difference type-intersect
-	  type-intersection type-specifier type-specifier-symbols
-	  type-union type/= type= types-intersect unboxed-array union-type
-	  union-type-p union-type-types unknown-type unknown-type-p
-	  unknown-type-specifier values-specifier-type
-	  values-specifier-type-cache-clear values-subtypep values-type
-	  values-type-allowp values-type-intersect values-type-intersection
-	  values-type-keyp values-type-keywords values-type-optional
-	  values-type-p values-type-required values-type-rest
-	  values-type-union values-types values-types-intersect void
-	  %unary-truncate %make-ratio %make-complex %single-float
-	  %double-float decode-single-float decode-double-float
-	  integer-decode-single-float integer-decode-double-float
-	  scale-single-float scale-double-float single-float-exponent
-	  double-float-exponent float-format-digits get-closure-length
-	  set-header-data signal-init %mask-field %deposit-field
-	  make-structure structure-length structure-ref structure-set
-	  structure-index-ref structure-index-set structure-index
-	  dynamic-space-free-pointer binding-stack-pointer-sap
-	  control-stack-pointer-sap simple-array-unsigned-byte-2-p
-	  simple-array-unsigned-byte-4-p simple-array-unsigned-byte-8-p
-	  simple-array-unsigned-byte-16-p simple-array-unsigned-byte-32-p
-	  simple-array-single-float-p simple-array-double-float-p
-	  array-header-p signed-byte-32-p unsigned-byte-32-p
-
-	  %set-sap-ref-sap %set-sap-ref-32 %set-sap-ref-16 %set-sap-ref-8
-	  %set-sap-ref-single %set-sap-ref-double
-	  make-single-float make-double-float single-float-bits
-	  double-float-high-bits double-float-low-bits
-	  single-float-p double-float-p base-char-p simple-array-p
-	  %raw-bits %set-raw-bits %sp-set-definition
-	  make-array-header allocate-vector %unary-round
-
-	  ))
-
-
-(in-package "EXTENSIONS")
-
-(export '(*after-gc-hooks* *after-save-initializations* *backup-extension*
-	  *before-gc-hooks* *before-save-initializations*
- 	  *bytes-consed-between-gcs* *clx-fds-to-displays*
- 	  *command-line-strings* *command-line-switches*
- 	  *command-line-utility-name* *command-line-words*
- 	  *command-switch-demons* *compatibility-warnings*
- 	  *describe-implementation-details* *describe-indentation*
- 	  *describe-level* *describe-print-length* *describe-print-level*
- 	  *describe-verbose* *display-event-handlers* *editor-lisp-p*
- 	  *environment-list* *gc-inhibit-hook* *gc-notify-after*
- 	  *gc-notify-before* *gc-verbose* *hemlock-version*
- 	  *ignore-floating-point-underflow* *info-environment*
- 	  *intexp-maximum-exponenent* *keyword-package* *lisp-package*
- 	  *load-if-source-newer* *max-step-indentation*
- 	  *max-trace-indentation* *module-file-translations* *prompt*
- 	  *require-verbose* *safe-defstruct-accessors* *step-print-length*
- 	  *step-print-level* *terminal-line-mode* *trace-print-length*
- 	  *trace-print-level* *traced-function-list* abort
- 	  accept-tcp-connection add-oob-handler ambiguous-files
- 	  argument-list assq basic-definition bignump bitp c-sizeof
- 	  call-user-miscop careful-symbol-function carefully-add-font-paths
- 	  char clean-up-compiler clear-info close-socket cmd-switch-arg
- 	  cmd-switch-name cmd-switch-value cmd-switch-words collect
- 	  command-line-switch command-line-switch-p
- 	  compact-info-environment compile-from-stream compiledp
- 	  complete-file concat-pnames connect-to-inet-socket constant
- 	  constant-argument create-inet-listener create-inet-socket debug
- 	  def-c-array def-c-pointer def-c-procedure def-c-record
- 	  def-c-routine def-c-type def-c-variable default-clx-event-handler
- 	  default-directory define-info-class define-info-type
- 	  define-keyboard-modifier define-keysym define-mouse-code
- 	  defmodule defswitch deletef delq disable-clx-event-handling
- 	  do-anonymous do-info double-floatp dovector e
- 	  enable-clx-event-handling encapsulate encapsulated-p
- 	  file-writable fixnump flush-display-events format-decoded-time
- 	  format-universal-time gc gc-off gc-on get-bytes-consed
- 	  get-code-pointer get-command-line-switch get-data-pointer grindef
- 	  host-entry host-entry-addr host-entry-addr-list
- 	  host-entry-aliases host-entry-name htonl htons ignorable
- 	  ignore-errors inaddr-any indenting-further info int
- 	  interactive-eval ipproto-tcp ipproto-udp iterate letf letf*
- 	  listen-skip-whitespace load-foreign long long-floatp
- 	  lookup-host-entry make-info-environment maybe-inline memq ntohl
- 	  ntohs object-set-event-handler once-only open-clx-display
- 	  parse-time print-directory print-herald process-alive-p
- 	  process-close process-core-dumped process-error process-exit-code
- 	  process-input process-kill process-output process-p process-pid
- 	  process-plist process-pty process-status process-status-hook
- 	  process-wait putf quit ratiop read-char-no-edit realp
- 	  remove-all-oob-handlers remove-oob-handler reset-foreign-pointers
- 	  run-program save save-all-buffers save-lisp search-list
- 	  send-character-out-of-band serve-button-press
- 	  serve-button-release serve-circulate-notify
- 	  serve-circulate-request serve-client-message
- 	  serve-colormap-notify serve-configure-notify
- 	  serve-configure-request serve-create-notify serve-destroy-notify
- 	  serve-enter-notify serve-exposure serve-focus-in serve-focus-out
- 	  serve-graphics-exposure serve-gravity-notify serve-key-press
- 	  serve-key-release serve-leave-notify serve-map-notify
- 	  serve-map-request serve-motion-notify serve-no-exposure
- 	  serve-property-notify serve-reparent-notify serve-resize-request
- 	  serve-selection-clear serve-selection-notify
- 	  serve-selection-request serve-unmap-notify
- 	  serve-visibility-notify set-symbol-function-carefully short
-	  short-floatp signal single-floatp structurep symbolicate
-	  translate-character translate-mouse-character truly-the
-	  uncompile undefined-value unencapsulate unsigned-char
-	  unsigned-int unsigned-long unsigned-short void
-	  with-clx-event-handling weak-pointer weak-pointer-p
- 	  make-weak-pointer weak-pointer-value))
-
-
-(in-package "SYSTEM")
-
-(export '(%alien-indirect %assembler-code-type %bind-aligned-sap
-	  %set-alien-access %standard-char-p %static-alien-area
-	  %string-char-p *alien-eval-when* *beep-function* *gr-messages*
-	  *in-the-compiler* *maximum-interpreter-error-checking*
-	  *nameserverport* *pornography-of-death*
-	  *port-ownership-rights-handlers* *port-receive-rights-handlers*
-	  *stderr* *stdin* *stdout* *task-data* *task-notify* *task-self*
-	  *tty* *typescriptport* *usertypescript* *userwindow*
-	  *xwindow-table* add-fd-handler add-port-death-handler
-	  add-port-object add-xwindow-object alien alien-access
-	  alien-address alien-assign alien-bind alien-index alien-indirect
-	  alien-sap alien-size alien-type alien-value
-	  allocate-system-memory beep bits boolean bytes c-procedure
-	  check<= check= compiler-version copy-alien ct-a-val
-	  ct-a-val-alien ct-a-val-offset ct-a-val-p ct-a-val-sap
-	  ct-a-val-size ct-a-val-type deallocate-system-memory defalien
-	  default-interrupt defenumeration define-alien-stack defoperator
-	  defrecord deport-boolean deport-integer dispose-alien
-	  double-float-radix enable-interrupt enumeration fd-stream
-	  fd-stream-fd fd-stream-p fexpr find-if-in-closure gr-bind gr-call
-	  gr-call* gr-error ignore-interrupt int-sap invalidate-descriptor
-	  long-float-radix long-words macro make-alien make-ct-a-val
-	  make-fd-stream make-indenting-stream make-object-set map-port
-	  map-xwindow naturalize-boolean naturalize-integer
-	  null-terminated-string object-set-operation output-raw-bytes
-	  parse-body perq-string pointer pointer< pointer> port primep
-	  read-n-bytes record-size remove-fd-handler
-	  remove-port-death-handler remove-port-object
-	  remove-xwindow-object resolve-loaded-assembler-references sap+
-	  sap- sap-int sap-ref-16 sap-ref-32 sap-ref-8 sap-ref-sap
-	  sap-ref-single sap-ref-double sap-ref-descriptor serve-all-events
-	  serve-event server server-message short-float-radix
-	  signed-sap-ref-16 signed-sap-ref-32 signed-sap-ref-8
-	  single-float-radix symbol-macro-let system-area-pointer
-	  system-area-pointer-p unproclaim unstructured vector-sap
-	  wait-until-fd-usable with-enabled-interrupts with-fd-handler
-	  with-interrupts with-reply-port with-stack-alien without-gcing
-	  without-hemlock without-interrupts words
-	  reallocate-system-memory))
-
-
-(in-package "USER")
-
-(use-package "EXT")
-
-
-
-(in-package "VM")
-
-(use-package "KERNEL")
-(use-package "EXT")
-(use-package "C")
-(use-package "BIGNUM")
-
-(export '(*assembly-unit-length* *primitive-objects* array-data-slot
-	  array-dimensions-offset array-displaced-p-slot
-	  array-displacement-slot array-elements-slot
-	  array-fill-pointer-slot atomic-flag base-char-type
-	  binding-size binding-symbol-slot
-	  binding-value-slot byte-bits catch-block-current-code-slot
-	  catch-block-current-cont-slot catch-block-current-uwp-slot
-	  catch-block-entry-pc-slot catch-block-previous-catch-slot
-	  catch-block-size catch-block-size-slot catch-block-tag-slot
-	  cerror-trap closure-function-header-type closure-function-slot
-	  closure-header-type closure-info-offset code-code-size-slot
-	  code-constants-offset code-debug-info-slot code-entry-points-slot
-	  code-header-type complex-array-type complex-bit-vector-type
-	  complex-imag-slot complex-real-slot complex-size
-	  complex-string-type complex-type complex-vector-type
-	  cons-car-slot cons-cdr-slot cons-size
-	  define-for-each-primitive-object double-float-bias
-	  double-flaot-exponent-byte double-float-hidden-bit
-	  double-float-normal-exponent-min double-float-normal-exponent-max
-	  double-float-size double-float-significand-byte double-float-type
-	  double-float-value-slot error-trap even-fixnum-type
-	  exported-static-symbols fixnum float-sign-shift
-	  function-header-arglist-slot function-header-code-offset
-	  function-header-name-slot function-header-next-slot
-	  function-header-self-slot function-header-type
-	  function-header-type-slot function-pointer-type genesis halt-trap
-	  interrupted-flag list-pointer-type lowtag-bits lowtag-limit
-	  lowtag-mask most-positive-cost odd-fixnum-type
-	  offset-static-symbol other-immediate-0-type
-	  other-immediate-1-type other-pointer-type pad-data-block
-	  pending-interrupt-trap primitive-object-header
-	  primitive-object-lowtag primitive-object-name
-	  primitive-object-options primitive-object-size
-	  primitive-object-slots primitive-object-variable-length
-	  ratio-denominator-slot ratio-numerator-slot ratio-size ratio-type
-	  return-pc-header-type return-pc-return-point-offset
-	  sap-pointer-slot sap-size sap-type
-	  simple-array-double-float-type simple-array-single-float-type
-	  simple-array-type simple-array-unsigned-byte-16-type
-	  simple-array-unsigned-byte-2-type
-	  simple-array-unsigned-byte-32-type
-	  simple-array-unsigned-byte-4-type
-	  simple-array-unsigned-byte-8-type simple-bit-vector-type
-	  simple-string-type simple-vector-type single-float-bias
-	  single-float-exponent-byte single-float-hidden-bit
-	  single-float-normal-exponent-min single-float-normal-exponent-max
-	  single-float-size single-float-significand-byte single-float-type
-	  single-float-value-slot slot-docs slot-length slot-name
-	  slot-offset slot-options slot-rest-p static-symbol-offset
-	  static-symbol-p static-symbols structure-pointer-type
-	  symbol-function-slot symbol-header-type symbol-name-slot
-	  symbol-package-slot symbol-plist-slot symbol-size
-	  symbol-value-slot target-binding-stack-start target-byte-order
-	  target-control-stack-start target-dynamic-space-start
-	  target-fasl-code-format target-fasl-file-type
-	  target-heap-address-space target-most-negative-fixnum
-	  target-most-positive-fixnum target-read-only-space-start
-	  target-static-space-start type-bits type-mask unbound-marker-type
-	  unwind-block-current-code-slot unwind-block-current-cont-slot
-	  unwind-block-current-uwp-slot unwind-block-entry-pc-slot
-	  unwind-block-size value-cell-header-type value-cell-size
-	  value-cell-value-slot vector-data-offset vector-length-slot
-	  vector-normal-subtype vector-structure-subtype
-	  vector-valid-hashing-subtype vector-must-rehash-subtype
-	  word-bits word-bytes word-shift weak-pointer-type
-	  weak-pointer-size weak-pointer-value-slot weak-pointer-next-slot
-	  
-	  single-float-bias
-	  double-float-bias single-float-significand-byte
-	  double-float-significand-byte
-	  single-float-exponent-byte double-float-exponent-byte
-	  single-float-normal-exponent-max single-float-normal-exponent-min
-	  double-float-normal-exponent-max double-float-normal-exponent-min
-	  single-float-hidden-bit double-float-hidden-bit
-	  float-sign-shift single-float-digits double-float-digits
-	  register-save-penalty symbol-raw-function-addr-slot
-	  symbol-setf-function-slot structure-header-type bignum-type
-	  ))
-
-(in-package "LISP")
-(import '(
-	  %aset
-	  %bitset
-	  %charset
-	  %primitive
-	  %put
-	  %rplaca
-	  %rplacd
-	  %sbitset
-	  %scharset
-	  %set-documentation
-	  %set-fdefinition
-	  %set-fill-pointer
-	  %set-row-major-aref
-	  %setelt
-	  %setnth
-	  %sp-set-plist
-	  %sp-set-definition
-	  %standard-char-p
-	  %string-char-p
-	  %svset
-	  %typep
-	  %array-typep
-	  array-header-p
-	  base-char-p
-	  double-float-p
-	  long-float-p
-	  short-float-p
-	  simple-array-p
-	  single-float-p
-	  string<*
-	  string>*
-	  string<=*
-	  string>=*
-	  string=*
-	  string/=*
-	  %sp-string-compare
-	  )
-	"VM")
-
-
-(in-package "C")
-
-(use-package "EXT")
-(use-package "KERNEL")
-(use-package "SYSTEM")
-(use-package "ASSEM")
-(use-package "BIGNUM")
-
-(export '(
-	  *compile-time-define-macros* *compiling-for-interpreter*
-	  compile-for-eval entry-node-info-nlx-tag entry-node-info-st-top
-	  lambda-eval-info-args-passed lambda-eval-info-entries
-	  lambda-eval-info-frame-size sc %more-arg %listify-rest-args
-	  more-arg-context verify-argument-count argument-count-error
-	  type-check-error odd-keyword-arguments-error
-	  unknown-keyword-argument-error save-dynamic-state
-	  restore-dynamic-state current-stack-pointer current-binding-pointer
-	  make-unwind-block make-catch-block set-unwind-protect
-	  %catch-breakup %unwind-protect-breakup nlx-entry nlx-entry-multiple
-	  uwp-entry %continue-unwind move non-descriptor-stack
-	  foreign-symbol-address compute-old-nfp unbind-to-here
-	  
-	  alloc-number-stack-space
-	  allocate-frame
-	  allocate-full-call-frame
-	  bind
-	  branch
-	  call
-	  call-local
-	  call-named
-	  call-out
-	  call-variable
-	  closure-init
-	  closure-ref
-	  coerce-to-function
-	  copy-more-arg
-	  current-stack-pointer
-	  dealloc-number-stack-space
-	  fast-safe-coerce-to-function
-	  fast-symbol-function
-	  fast-symbol-value
-	  if-eq
-	  known-call-local
-	  known-return
-	  make-catch-block
-	  make-closure
-	  make-unwind-block
-	  make-value-cell
-	  move
-	  multiple-call
-	  multiple-call-local
-	  multiple-call-named
-	  multiple-call-variable
-	  nil
-	  nlx-entry
-	  nlx-entry-multiple
-	  note-environment-start
-	  push-values
-	  reset-stack-pointer
-	  restore-dynamic-state
-	  return
-	  return-multiple
-	  save-dynamic-state
-	  set
-	  set-unwind-protect
-	  setup-closure-environment
-	  setup-environment
-	  structure-ref
-	  structure-set
-	  symbol-function
-	  symbol-value
-	  tail-call
-	  tail-call-named
-	  tail-call-variable
-	  throw
-	  unbind
-	  unwind
-	  uwp-entry
-	  value-cell-ref
-	  value-cell-set
-	  values-list
-	  xep-allocate-frame
-
-	  catch-block
-
-	  sxhash-simple-string sxhash-simple-substring check-cons
-	  check-symbol check-fixnum check-signed-byte-32
-	  check-unsigned-byte-32 check-function-or-symbol check-function
-	  code-constant-set allocate-code-object
-	  code-instructions compute-function
-	  get-vector-subtype set-vector-subtype
-	  halt make-fixnum make-other-immediate-type
-	  code-constant-ref
-	  ))
-
-(in-package "LISP")
-(import '(
-	  %aset
-	  %bitset
-	  %charset
-	  %primitive
-	  %put
-	  %rplaca
-	  %rplacd
-	  %sbitset
-	  %scharset
-	  %set-documentation
-	  %set-fdefinition
-	  %set-fill-pointer
-	  %set-row-major-aref
-	  %setelt
-	  %setnth
-	  %sp-set-plist
-	  %standard-char-p
-	  %string-char-p
-	  %svset
-	  %typep
-	  %array-typep
-	  array-header-p
-	  base-char-p
-	  double-float-p
-	  long-float-p
-	  short-float-p
-	  simple-array-p
-	  single-float-p
-	  string<*
-	  string>*
-	  string<=*
-	  string>=*
-	  string=*
-	  string/=*
-	  %sp-string-compare
-	  )
-	"C")
-
-
-(in-package "ASSEM")
-
-(export '(*current-position* align assemble define-argument-type
-	  define-fixup-type define-format define-instruction
-	  define-pseudo-instruction define-random-resources
-	  define-register-file dump-segment emit-code-vector emit-label
-	  finalize-segment fixup fixup-flavor fixup-name fixup-offset
-	  fixup-p gen-label insert-segment inst label label-id label-position
-	  make-fixup make-segment nuke-segment count-instructions))
-
-
-(in-package "EVAL")
-
-(use-package "KERNEL")
-
-(export '(internal-eval interpreted-function-arglist
-	  interpreted-function-closure
-	  interpreted-function-lambda-expression interpreted-function-name
-	  interpreted-function-p make-interpreted-function))
-
-
-(in-package "BIGNUM")
-(use-package "KERNEL")
-
-(export '(add-bignums multiply-bignums negate-bignum subtract-bignum
-	  multiply-bignum-and-fixnum multiply-fixnums
-	  bignum-ashift-right bignum-ashift-left bignum-gcd
-	  bignum-to-float float-bignum-ratio bignum-integer-length
-	  bignum-logical-and bignum-logical-ior bignum-logical-xor
-	  bignum-logical-not bignum-load-byte bignum-deposit-byte
-	  bignum-truncate bignum-plus-p bignum-compare make-small-bignum
-	  bignum-logcount bignum-index bignum-type bignum-element-type))
-
-(export '(bignum-type bignum-element-type bignum-index %allocate-bignum
-	  %bignum-length %bignum-set-length %bignum-ref %bignum-set
-	  %digit-0-or-plusp %add-with-carry %subtract-with-borrow
-	  %multiply-and-add %multiply %lognot %logand %logior %logxor
-	  %fixnum-to-digit %floor %fixnum-digit-with-correct-sign %ashl
-	  %ashr %digit-logical-shift-right))
-
-
-
-(in-package "DEBUG")
-
-(export '(internal-debug *in-the-debugger* backtrace *flush-debug-errors*
-	  *debug-print-level* *debug-print-length* *debug-prompt*
-
-	  var arg))
-
-
-(in-package "DEBUG-INTERNALS")
-
-(use-package "SYSTEM")
-(use-package "EXT")
-(use-package "KERNEL")
-
-;;; The compiler's debug-source structure is almost exactly what we want, so
-;;; just get these symbols and export them.
+;;; Machine generated.  Don't edit it unless you know what you are doing.
 ;;;
-(import '(c::debug-source-from c::debug-source-name c::debug-source-created
-	  c::debug-source-compiled c::debug-source-start-positions
-	  c::debug-source c::debug-source-p))
-
-(export '(debug-variable-name debug-variable-package debug-variable-symbol
-	  debug-variable-id debug-variable-value debug-variable-validity
-	  debug-variable-valid-value debug-variable debug-variable-p
-
-	  top-frame frame-down frame-up frame-debug-function
-	  frame-code-location eval-in-frame return-from-frame frame-catches
-	  frame-number frame frame-p
-
-	  do-blocks debug-function-lambda-list debug-variable-info-available
-	  do-debug-function-variables debug-function-symbol-variables
-	  ambiguous-debug-variables preprocess-for-eval function-debug-function
-	  debug-function-function debug-function-kind debug-function-name
-	  debug-function debug-function-p
-
-	  do-debug-block-locations debug-block-successors debug-block
-	  debug-block-p debug-block-elsewhere-p
 
-	  make-breakpoint activate-breakpoint deactivate-breakpoint
-	  breakpoint-hook-function breakpoint-info breakpoint-kind
-	  breakpoint-what breakpoint breakpoint-p
-
-	  code-location-debug-function code-location-debug-block
-	  code-location-top-level-form-offset code-location-form-number
-	  code-location-debug-source code-location code-location-p
-	  unknown-code-location unknown-code-location-p
-
-	  debug-source-from debug-source-name debug-source-created
-	  debug-source-compiled debug-source-root-number
-	  debug-source-start-positions form-number-translations
-	  source-path-context debug-source debug-source-p
-
-	  debug-condition no-debug-info no-debug-function-returns
-	  no-debug-blocks lambda-list-unavailable
-
-	  debug-error unhandled-condition invalid-control-stack-pointer
-	  unknown-code-location unknown-debug-variable invalid-value))
-
-
-(in-package "MACH")
-
-(use-package "SYSTEM")
-(use-package "KERNEL")
-(use-package "EXT")
+(in-package "LISP")
 
+(if (find-package "XLIB")
+    (rename-package "XLIB" "XLIB" '("OLD-XLIB"))
+    (make-package "XLIB" :nicknames '("OLD-XLIB") :use nil))
+(if (find-package "ASSEMBLER")
+    (rename-package "ASSEMBLER" "ASSEMBLER" '("ASSEM"))
+    (make-package "ASSEMBLER" :nicknames '("ASSEM") :use nil))
+(if (find-package "C-CALL")
+    (rename-package "C-CALL" "C-CALL" 'nil)
+    (make-package "C-CALL" :nicknames 'nil :use nil))
+(if (find-package "INSPECT")
+    (rename-package "INSPECT" "INSPECT" 'nil)
+    (make-package "INSPECT" :nicknames 'nil :use nil))
+(if (find-package "BIGNUM")
+    (rename-package "BIGNUM" "BIGNUM" 'nil)
+    (make-package "BIGNUM" :nicknames 'nil :use nil))
+(if (find-package "WALKER")
+    (rename-package "WALKER" "WALKER" 'nil)
+    (make-package "WALKER" :nicknames 'nil :use nil))
+(if (find-package "MACH")
+    (rename-package "MACH" "MACH" 'nil)
+    (make-package "MACH" :nicknames 'nil :use nil))
+(if (find-package "UNIX")
+    (rename-package "UNIX" "UNIX" 'nil)
+    (make-package "UNIX" :nicknames 'nil :use nil))
+(if (find-package "PCL")
+    (rename-package "PCL" "PCL" 'nil)
+    (make-package "PCL" :nicknames 'nil :use nil))
+(shadow '("DOCUMENTATION" "DESTRUCTURING-BIND") "PCL")
+(if (find-package "FORMAT")
+    (rename-package "FORMAT" "FORMAT" 'nil)
+    (make-package "FORMAT" :nicknames 'nil :use nil))
+(if (find-package "HEMLOCK")
+    (rename-package "HEMLOCK" "HEMLOCK" '("ED"))
+    (make-package "HEMLOCK" :nicknames '("ED") :use nil))
+(if (find-package "SPELL")
+    (rename-package "SPELL" "SPELL" 'nil)
+    (make-package "SPELL" :nicknames 'nil :use nil))
+(if (find-package "COMMON-LISP")
+    (rename-package "COMMON-LISP" "COMMON-LISP" '("CL" "LISP"))
+    (make-package "LISP" :nicknames 'nil :use nil))
+(if (find-package "EVAL")
+    (rename-package "EVAL" "EVAL" 'nil)
+    (make-package "EVAL" :nicknames 'nil :use nil))
+(if (find-package "ITERATE")
+    (rename-package "ITERATE" "ITERATE" 'nil)
+    (make-package "ITERATE" :nicknames 'nil :use nil))
+(if (find-package "MIPS")
+    (rename-package "MIPS" "MIPS" '("VM" "OLD-MIPS"))
+    (make-package "MIPS" :nicknames '("VM" "OLD-MIPS") :use nil))
+(if (find-package "CONDITIONS")
+    (rename-package "CONDITIONS" "CONDITIONS" 'nil)
+    (make-package "CONDITIONS" :nicknames 'nil :use nil))
+(if (find-package "DISASSEM")
+    (rename-package "DISASSEM" "DISASSEM" 'nil)
+    (make-package "DISASSEM" :nicknames 'nil :use nil))
+(if (find-package "DEBUG")
+    (rename-package "DEBUG" "DEBUG" 'nil)
+    (make-package "DEBUG" :nicknames 'nil :use nil))
+(if (find-package "EXTENSIONS")
+    (rename-package "EXTENSIONS" "EXTENSIONS" '("EXT"))
+    (make-package "EXTENSIONS" :nicknames '("EXT") :use nil))
+(if (find-package "LOOP")
+    (rename-package "LOOP" "LOOP" 'nil)
+    (make-package "LOOP" :nicknames 'nil :use nil))
+(if (find-package "HEMLOCK-INTERNALS")
+    (rename-package "HEMLOCK-INTERNALS" "HEMLOCK-INTERNALS" '("HI"))
+    (make-package "HEMLOCK-INTERNALS" :nicknames '("HI") :use nil))
+(if (find-package "DEBUG-INTERNALS")
+    (rename-package "DEBUG-INTERNALS" "DEBUG-INTERNALS" '("DI"))
+    (make-package "DEBUG-INTERNALS" :nicknames '("DI") :use nil))
+(if (find-package "C")
+    (rename-package "C" "C" '("OLD-C"))
+    (make-package "C" :nicknames '("OLD-C") :use nil))
+(if (find-package "DIRED")
+    (rename-package "DIRED" "DIRED" 'nil)
+    (make-package "DIRED" :nicknames 'nil :use nil))
+(shadow '("DELETE-FILE" "RENAME-FILE") "DIRED")
+(if (find-package "WIRE")
+    (rename-package "WIRE" "WIRE" 'nil)
+    (make-package "WIRE" :nicknames 'nil :use nil))
+(if (find-package "PRETTY-PRINT")
+    (rename-package "PRETTY-PRINT" "PRETTY-PRINT" '("PP"))
+    (make-package "PRETTY-PRINT" :nicknames '("PP") :use nil))
+(if (find-package "SYSTEM")
+    (rename-package "SYSTEM" "SYSTEM" '("SYS"))
+    (make-package "SYSTEM" :nicknames '("SYS") :use nil))
+(if (find-package "ALIEN")
+    (rename-package "ALIEN" "ALIEN" 'nil)
+    (make-package "ALIEN" :nicknames 'nil :use nil))
+(if (find-package "ALIEN-INTERNALS")
+    (rename-package "ALIEN-INTERNALS" "ALIEN-INTERNALS" 'nil)
+    (make-package "ALIEN-INTERNALS" :nicknames 'nil :use nil))
+(if (find-package "PROFILE")
+    (rename-package "PROFILE" "PROFILE" 'nil)
+    (make-package "PROFILE" :nicknames 'nil :use nil))
+(if (find-package "USER")
+    (rename-package "USER" "USER" 'nil)
+    (make-package "USER" :nicknames 'nil :use nil))
+(if (find-package "KERNEL")
+    (rename-package "KERNEL" "KERNEL" 'nil)
+    (make-package "KERNEL" :nicknames 'nil :use nil))
+(use-package '("LISP") "XLIB")
+(use-package '("LISP" "C" "EXTENSIONS" "KERNEL") "ASSEMBLER")
+(use-package '("SYSTEM" "ALIEN-INTERNALS" "ALIEN" "LISP") "C-CALL")
+(use-package '("KERNEL" "EXTENSIONS" "LISP") "INSPECT")
+(use-package '("LISP" "KERNEL") "BIGNUM")
+(use-package '("LISP") "WALKER")
+(use-package '("C-CALL" "SYSTEM" "LISP" "EXTENSIONS" "MACH" "KERNEL") "MACH")
+(use-package '("LISP") "UNIX")
+(use-package '("WALKER" "ITERATE" "LISP") "PCL")
+(use-package '("KERNEL" "LISP" "EXTENSIONS") "FORMAT")
+(use-package '("LISP" "HEMLOCK-INTERNALS" "EXTENSIONS" "SYSTEM") "HEMLOCK")
+(use-package '("LISP" "EXTENSIONS" "SYSTEM") "SPELL")
+(use-package '("EXTENSIONS" "SYSTEM" "DEBUG" "KERNEL" "BIGNUM") "LISP")
+(use-package '("LISP" "KERNEL") "EVAL")
+(use-package '("LISP" "WALKER") "ITERATE")
+(use-package
+ '("C-CALL" "ALIEN-INTERNALS" "ALIEN" "BIGNUM" "LISP" "KERNEL" "EXTENSIONS"
+   "SYSTEM" "ASSEMBLER" "C")
+ "MIPS")
+(use-package '("EXTENSIONS" "LISP") "CONDITIONS")
+(use-package '("LISP") "DISASSEM")
+(use-package '("EXTENSIONS" "LISP" "SYSTEM") "DEBUG")
+(use-package '("C-CALL" "ALIEN" "LISP" "SYSTEM" "MACH") "EXTENSIONS")
+(use-package '("LISP") "LOOP")
+(use-package '("LISP" "SYSTEM" "EXTENSIONS") "HEMLOCK-INTERNALS")
+(use-package '("LISP" "SYSTEM" "EXTENSIONS" "KERNEL") "DEBUG-INTERNALS")
+(use-package
+ '("ALIEN-INTERNALS" "ALIEN" "LISP" "EXTENSIONS" "KERNEL" "SYSTEM" "BIGNUM"
+   "ASSEMBLER")
+ "C")
+(use-package '("LISP") "DIRED")
+(use-package '("LISP") "WIRE")
+(use-package '("KERNEL" "EXTENSIONS" "LISP") "PRETTY-PRINT")
+(use-package '("EXTENSIONS" "LISP") "SYSTEM")
+(use-package '("SYSTEM" "EXTENSIONS" "LISP") "ALIEN")
+(use-package '("LISP") "ALIEN-INTERNALS")
+(use-package '("LISP") "PROFILE")
+(use-package '("PCL" "EXTENSIONS" "LISP") "USER")
+(use-package '("ALIEN-INTERNALS" "LISP" "EXTENSIONS" "SYSTEM" "BIGNUM")
+             "KERNEL")
+(intern "TYPE-ERROR" "LISP")
+(defpackage "XLIB"
+            (:import-from "LISP" "TYPE-ERROR")
+            (:export "*VERSION*" "ACCESS-CONTROL" "ACCESS-ERROR" "ACCESS-HOSTS"
+             "ACTIVATE-SCREEN-SAVER" "ADD-ACCESS-HOST" "ADD-RESOURCE"
+             "ADD-TO-SAVE-SET" "ALIST" "ALLOC-COLOR" "ALLOC-COLOR-CELLS"
+             "ALLOC-COLOR-PLANES" "ALLOC-ERROR" "ALLOW-EVENTS" "ANGLE"
+             "ARC-SEQ" "ARRAY-INDEX" "ATOM-ERROR" "ATOM-NAME" "BELL"
+             "BIT-GRAVITY" "BITMAP" "BITMAP-FORMAT" "BITMAP-FORMAT-LSB-FIRST-P"
+             "BITMAP-FORMAT-P" "BITMAP-FORMAT-PAD" "BITMAP-FORMAT-UNIT"
+             "BITMAP-IMAGE" "BOOLE-CONSTANT" "BOOLEAN" "CARD16" "CARD29"
+             "CARD32" "CARD8" "CARD8->CHAR" "CHANGE-ACTIVE-POINTER-GRAB"
+             "CHANGE-KEYBOARD-CONTROL" "CHANGE-KEYBOARD-MAPPING"
+             "CHANGE-POINTER-CONTROL" "CHANGE-PROPERTY" "CHAR->CARD8"
+             "CHAR-ASCENT" "CHAR-ATTRIBUTES" "CHAR-DESCENT" "CHAR-LEFT-BEARING"
+             "CHAR-RIGHT-BEARING" "CHAR-WIDTH" "CHARACTER->KEYSYMS"
+             "CHARACTER-IN-MAP-P" "CIRCULATE-WINDOW-DOWN" "CIRCULATE-WINDOW-UP"
+             "CLEAR-AREA" "CLOSE-DISPLAY" "CLOSE-DOWN-MODE" "CLOSE-FONT"
+             "CLOSED-DISPLAY" "COLOR" "COLOR-BLUE" "COLOR-GREEN" "COLOR-P"
+             "COLOR-RED" "COLOR-RGB" "COLORMAP" "COLORMAP-DISPLAY"
+             "COLORMAP-EQUAL" "COLORMAP-ERROR" "COLORMAP-ID" "COLORMAP-P"
+             "COLORMAP-PLIST" "COLORMAP-VISUAL-INFO" "CONNECTION-FAILURE"
+             "CONVERT-SELECTION" "COPY-AREA" "COPY-COLORMAP-AND-FREE"
+             "COPY-GCONTEXT" "COPY-GCONTEXT-COMPONENTS" "COPY-IMAGE"
+             "COPY-PLANE" "CREATE-COLORMAP" "CREATE-CURSOR" "CREATE-GCONTEXT"
+             "CREATE-GLYPH-CURSOR" "CREATE-IMAGE" "CREATE-PIXMAP"
+             "CREATE-WINDOW" "CURSOR" "CURSOR-DISPLAY" "CURSOR-EQUAL"
+             "CURSOR-ERROR" "CURSOR-ID" "CURSOR-P" "CURSOR-PLIST" "CUT-BUFFER"
+             "DECLARE-EVENT" "DECODE-CORE-ERROR" "DEFAULT-ERROR-HANDLER"
+             "DEFAULT-KEYSYM-INDEX" "DEFAULT-KEYSYM-TRANSLATE" "DEFINE-ERROR"
+             "DEFINE-EXTENSION" "DEFINE-GCONTEXT-ACCESSOR" "DEFINE-KEYSYM"
+             "DEFINE-KEYSYM-SET" "DELETE-PROPERTY" "DELETE-RESOURCE"
+             "DESTROY-SUBWINDOWS" "DESTROY-WINDOW" "DEVICE-BUSY"
+             "DEVICE-EVENT-MASK" "DEVICE-EVENT-MASK-CLASS"
+             "DISCARD-CURRENT-EVENT" "DISCARD-FONT-INFO" "DISPLAY"
+             "DISPLAY-AFTER-FUNCTION" "DISPLAY-AUTHORIZATION-DATA"
+             "DISPLAY-AUTHORIZATION-NAME" "DISPLAY-BITMAP-FORMAT"
+             "DISPLAY-BYTE-ORDER" "DISPLAY-DEFAULT-SCREEN" "DISPLAY-DISPLAY"
+             "DISPLAY-ERROR-HANDLER" "DISPLAY-FINISH-OUTPUT"
+             "DISPLAY-FORCE-OUTPUT" "DISPLAY-HOST" "DISPLAY-IMAGE-LSB-FIRST-P"
+             "DISPLAY-INVOKE-AFTER-FUNCTION" "DISPLAY-KEYCODE-RANGE"
+             "DISPLAY-MAX-KEYCODE" "DISPLAY-MAX-REQUEST-LENGTH"
+             "DISPLAY-MIN-KEYCODE" "DISPLAY-MOTION-BUFFER-SIZE"
+             "DISPLAY-NSCREENS" "DISPLAY-P" "DISPLAY-PIXMAP-FORMATS"
+             "DISPLAY-PLIST" "DISPLAY-PROTOCOL-MAJOR-VERSION"
+             "DISPLAY-PROTOCOL-MINOR-VERSION" "DISPLAY-PROTOCOL-VERSION"
+             "DISPLAY-RELEASE-NUMBER" "DISPLAY-REPORT-ASYNCHRONOUS-ERRORS"
+             "DISPLAY-RESOURCE-ID-BASE" "DISPLAY-RESOURCE-ID-MASK"
+             "DISPLAY-ROOTS" "DISPLAY-VENDOR" "DISPLAY-VENDOR-NAME"
+             "DISPLAY-XDEFAULTS" "DISPLAY-XID" "DRAW-ARC" "DRAW-ARCS"
+             "DRAW-DIRECTION" "DRAW-GLYPH" "DRAW-GLYPHS" "DRAW-IMAGE-GLYPH"
+             "DRAW-IMAGE-GLYPHS" "DRAW-LINE" "DRAW-LINES" "DRAW-POINT"
+             "DRAW-POINTS" "DRAW-RECTANGLE" "DRAW-RECTANGLES" "DRAW-SEGMENTS"
+             "DRAWABLE" "DRAWABLE-BORDER-WIDTH" "DRAWABLE-DEPTH"
+             "DRAWABLE-DISPLAY" "DRAWABLE-EQUAL" "DRAWABLE-ERROR"
+             "DRAWABLE-HEIGHT" "DRAWABLE-ID" "DRAWABLE-P" "DRAWABLE-PLIST"
+             "DRAWABLE-ROOT" "DRAWABLE-WIDTH" "DRAWABLE-X" "DRAWABLE-Y"
+             "ERROR-KEY" "EVENT-CASE" "EVENT-COND" "EVENT-HANDLER" "EVENT-KEY"
+             "EVENT-LISTEN" "EVENT-MASK" "EVENT-MASK-CLASS" "EXTENSION-OPCODE"
+             "FIND-ATOM" "FONT" "FONT-ALL-CHARS-EXIST-P" "FONT-ASCENT"
+             "FONT-DEFAULT-CHAR" "FONT-DESCENT" "FONT-DIRECTION" "FONT-DISPLAY"
+             "FONT-EQUAL" "FONT-ERROR" "FONT-ID" "FONT-MAX-BYTE1"
+             "FONT-MAX-BYTE2" "FONT-MAX-CHAR" "FONT-MIN-BYTE1" "FONT-MIN-BYTE2"
+             "FONT-MIN-CHAR" "FONT-NAME" "FONT-P" "FONT-PATH" "FONT-PLIST"
+             "FONT-PROPERTIES" "FONT-PROPERTY" "FONTABLE"
+             "FORCE-GCONTEXT-CHANGES" "FREE-COLORMAP" "FREE-COLORS"
+             "FREE-CURSOR" "FREE-GCONTEXT" "FREE-PIXMAP" "GCONTEXT"
+             "GCONTEXT-ARC-MODE" "GCONTEXT-BACKGROUND" "GCONTEXT-CACHE-P"
+             "GCONTEXT-CAP-STYLE" "GCONTEXT-CLIP-MASK" "GCONTEXT-CLIP-ORDERING"
+             "GCONTEXT-CLIP-X" "GCONTEXT-CLIP-Y" "GCONTEXT-DASH-OFFSET"
+             "GCONTEXT-DASHES" "GCONTEXT-DISPLAY" "GCONTEXT-EQUAL"
+             "GCONTEXT-ERROR" "GCONTEXT-EXPOSURES" "GCONTEXT-FILL-RULE"
+             "GCONTEXT-FILL-STYLE" "GCONTEXT-FONT" "GCONTEXT-FOREGROUND"
+             "GCONTEXT-FUNCTION" "GCONTEXT-ID" "GCONTEXT-JOIN-STYLE"
+             "GCONTEXT-KEY" "GCONTEXT-LINE-STYLE" "GCONTEXT-LINE-WIDTH"
+             "GCONTEXT-P" "GCONTEXT-PLANE-MASK" "GCONTEXT-PLIST"
+             "GCONTEXT-STIPPLE" "GCONTEXT-SUBWINDOW-MODE" "GCONTEXT-TILE"
+             "GCONTEXT-TS-X" "GCONTEXT-TS-Y" "GET-EXTERNAL-EVENT-CODE"
+             "GET-IMAGE" "GET-PROPERTY" "GET-RAW-IMAGE" "GET-RESOURCE"
+             "GET-SEARCH-RESOURCE" "GET-SEARCH-TABLE" "GET-STANDARD-COLORMAP"
+             "GET-WM-CLASS" "GLOBAL-POINTER-POSITION" "GRAB-BUTTON" "GRAB-KEY"
+             "GRAB-KEYBOARD" "GRAB-POINTER" "GRAB-SERVER" "GRAB-STATUS"
+             "ICON-SIZES" "ICONIFY-WINDOW" "ID-CHOICE-ERROR"
+             "ILLEGAL-REQUEST-ERROR" "IMAGE" "IMAGE-BLUE-MASK" "IMAGE-DEPTH"
+             "IMAGE-GREEN-MASK" "IMAGE-HEIGHT" "IMAGE-NAME" "IMAGE-PIXMAP"
+             "IMAGE-PLIST" "IMAGE-RED-MASK" "IMAGE-WIDTH" "IMAGE-X"
+             "IMAGE-X-HOT" "IMAGE-X-P" "IMAGE-XY" "IMAGE-XY-BITMAP-LIST"
+             "IMAGE-XY-P" "IMAGE-Y-HOT" "IMAGE-Z" "IMAGE-Z-BITS-PER-PIXEL"
+             "IMAGE-Z-P" "IMAGE-Z-PIXARRAY" "IMPLEMENTATION-ERROR"
+             "INPUT-FOCUS" "INSTALL-COLORMAP" "INSTALLED-COLORMAPS" "INT16"
+             "INT32" "INT8" "INTERN-ATOM" "INVALID-FONT" "KEYBOARD-CONTROL"
+             "KEYBOARD-MAPPING" "KEYCODE->CHARACTER" "KEYCODE->KEYSYM" "KEYSYM"
+             "KEYSYM->CHARACTER" "KEYSYM->KEYCODES" "KEYSYM-IN-MAP-P"
+             "KEYSYM-SET" "KILL-CLIENT" "KILL-TEMPORARY-CLIENTS" "LENGTH-ERROR"
+             "LIST-EXTENSIONS" "LIST-FONT-NAMES" "LIST-FONTS" "LIST-PROPERTIES"
+             "LOAD-CLX" "LOOKUP-COLOR" "LOOKUP-ERROR" "MAKE-COLOR"
+             "MAKE-EVENT-HANDLERS" "MAKE-EVENT-KEYS" "MAKE-EVENT-MASK"
+             "MAKE-RESOURCE-DATABASE" "MAKE-STATE-KEYS" "MAKE-STATE-MASK"
+             "MAKE-WM-HINTS" "MAKE-WM-SIZE-HINTS" "MAP-RESOURCE"
+             "MAP-SUBWINDOWS" "MAP-WINDOW" "MAPPING-NOTIFY" "MASK16" "MASK32"
+             "MATCH-ERROR" "MAX-CHAR-ASCENT" "MAX-CHAR-ATTRIBUTES"
+             "MAX-CHAR-DESCENT" "MAX-CHAR-LEFT-BEARING"
+             "MAX-CHAR-RIGHT-BEARING" "MAX-CHAR-WIDTH" "MERGE-RESOURCES"
+             "MIN-CHAR-ASCENT" "MIN-CHAR-ATTRIBUTES" "MIN-CHAR-DESCENT"
+             "MIN-CHAR-LEFT-BEARING" "MIN-CHAR-RIGHT-BEARING" "MIN-CHAR-WIDTH"
+             "MISSING-PARAMETER" "MODIFIER-KEY" "MODIFIER-MAPPING"
+             "MODIFIER-MASK" "MOTION-EVENTS" "NAME-ERROR" "NO-OPERATION"
+             "OPEN-DISPLAY" "OPEN-FONT" "PIXARRAY" "PIXEL" "PIXMAP"
+             "PIXMAP-DISPLAY" "PIXMAP-EQUAL" "PIXMAP-ERROR" "PIXMAP-FORMAT"
+             "PIXMAP-FORMAT-BITS-PER-PIXEL" "PIXMAP-FORMAT-DEPTH"
+             "PIXMAP-FORMAT-P" "PIXMAP-FORMAT-SCANLINE-PAD" "PIXMAP-ID"
+             "PIXMAP-P" "PIXMAP-PLIST" "POINT-SEQ" "POINTER-CONTROL"
+             "POINTER-EVENT-MASK" "POINTER-EVENT-MASK-CLASS" "POINTER-MAPPING"
+             "POINTER-POSITION" "PROCESS-EVENT" "PUT-IMAGE" "PUT-RAW-IMAGE"
+             "QUERY-BEST-CURSOR" "QUERY-BEST-STIPPLE" "QUERY-BEST-TILE"
+             "QUERY-COLORS" "QUERY-EXTENSION" "QUERY-KEYMAP" "QUERY-POINTER"
+             "QUERY-TREE" "QUEUE-EVENT" "READ-BITMAP-FILE" "READ-RESOURCES"
+             "RECOLOR-CURSOR" "RECT-SEQ" "REMOVE-ACCESS-HOST"
+             "REMOVE-FROM-SAVE-SET" "REPARENT-WINDOW" "REPEAT-SEQ"
+             "REPLY-LENGTH-ERROR" "REPLY-TIMEOUT" "REQUEST-ERROR"
+             "RESET-SCREEN-SAVER" "RESOURCE-DATABASE"
+             "RESOURCE-DATABASE-TIMESTAMP" "RESOURCE-ERROR" "RESOURCE-ID"
+             "RESOURCE-KEY" "RGB-COLORMAPS" "RGB-VAL" "ROOT-RESOURCES"
+             "ROTATE-CUT-BUFFERS" "ROTATE-PROPERTIES" "SCREEN"
+             "SCREEN-BACKING-STORES" "SCREEN-BLACK-PIXEL"
+             "SCREEN-DEFAULT-COLORMAP" "SCREEN-DEPTHS"
+             "SCREEN-EVENT-MASK-AT-OPEN" "SCREEN-HEIGHT"
+             "SCREEN-HEIGHT-IN-MILLIMETERS" "SCREEN-MAX-INSTALLED-MAPS"
+             "SCREEN-MIN-INSTALLED-MAPS" "SCREEN-P" "SCREEN-PLIST"
+             "SCREEN-ROOT" "SCREEN-ROOT-DEPTH" "SCREEN-ROOT-VISUAL"
+             "SCREEN-ROOT-VISUAL-INFO" "SCREEN-SAVE-UNDERS-P" "SCREEN-SAVER"
+             "SCREEN-WHITE-PIXEL" "SCREEN-WIDTH" "SCREEN-WIDTH-IN-MILLIMETERS"
+             "SEG-SEQ" "SELECTION-OWNER" "SEND-EVENT" "SEQUENCE-ERROR"
+             "SET-ACCESS-CONTROL" "SET-CLOSE-DOWN-MODE" "SET-INPUT-FOCUS"
+             "SET-MODIFIER-MAPPING" "SET-POINTER-MAPPING" "SET-SCREEN-SAVER"
+             "SET-SELECTION-OWNER" "SET-STANDARD-COLORMAP"
+             "SET-STANDARD-PROPERTIES" "SET-WM-CLASS" "SET-WM-PROPERTIES"
+             "SET-WM-RESOURCES" "STATE-KEYSYM-P" "STATE-MASK-KEY" "STORE-COLOR"
+             "STORE-COLORS" "STRINGABLE" "TEXT-EXTENTS" "TEXT-WIDTH"
+             "TIMESTAMP" "TRANSIENT-FOR" "TRANSLATE-COORDINATES"
+             "TRANSLATE-DEFAULT" "TRANSLATION-FUNCTION" "TYPE-ERROR"
+             "UNDEFINE-KEYSYM" "UNEXPECTED-REPLY" "UNGRAB-BUTTON" "UNGRAB-KEY"
+             "UNGRAB-KEYBOARD" "UNGRAB-POINTER" "UNGRAB-SERVER"
+             "UNINSTALL-COLORMAP" "UNKNOWN-ERROR" "UNMAP-SUBWINDOWS"
+             "UNMAP-WINDOW" "VALUE-ERROR" "VISUAL-INFO"
+             "VISUAL-INFO-BITS-PER-RGB" "VISUAL-INFO-BLUE-MASK"
+             "VISUAL-INFO-CLASS" "VISUAL-INFO-COLORMAP-ENTRIES"
+             "VISUAL-INFO-DISPLAY" "VISUAL-INFO-GREEN-MASK" "VISUAL-INFO-ID"
+             "VISUAL-INFO-P" "VISUAL-INFO-PLIST" "VISUAL-INFO-RED-MASK"
+             "WARP-POINTER" "WARP-POINTER-IF-INSIDE" "WARP-POINTER-RELATIVE"
+             "WARP-POINTER-RELATIVE-IF-INSIDE" "WIN-GRAVITY" "WINDOW"
+             "WINDOW-ALL-EVENT-MASKS" "WINDOW-BACKGROUND"
+             "WINDOW-BACKING-PIXEL" "WINDOW-BACKING-PLANES"
+             "WINDOW-BACKING-STORE" "WINDOW-BIT-GRAVITY" "WINDOW-BORDER"
+             "WINDOW-CLASS" "WINDOW-COLORMAP" "WINDOW-COLORMAP-INSTALLED-P"
+             "WINDOW-CURSOR" "WINDOW-DISPLAY" "WINDOW-DO-NOT-PROPAGATE-MASK"
+             "WINDOW-EQUAL" "WINDOW-ERROR" "WINDOW-EVENT-MASK" "WINDOW-GRAVITY"
+             "WINDOW-ID" "WINDOW-MAP-STATE" "WINDOW-OVERRIDE-REDIRECT"
+             "WINDOW-P" "WINDOW-PLIST" "WINDOW-PRIORITY" "WINDOW-SAVE-UNDER"
+             "WINDOW-VISUAL" "WINDOW-VISUAL-INFO" "WITH-DISPLAY"
+             "WITH-EVENT-QUEUE" "WITH-GCONTEXT" "WITH-SERVER-GRABBED"
+             "WITH-STATE" "WITHDRAW-WINDOW" "WM-CLIENT-MACHINE"
+             "WM-COLORMAP-WINDOWS" "WM-COMMAND" "WM-HINTS" "WM-HINTS-FLAGS"
+             "WM-HINTS-ICON-MASK" "WM-HINTS-ICON-PIXMAP" "WM-HINTS-ICON-WINDOW"
+             "WM-HINTS-ICON-X" "WM-HINTS-ICON-Y" "WM-HINTS-INITIAL-STATE"
+             "WM-HINTS-INPUT" "WM-HINTS-P" "WM-HINTS-WINDOW-GROUP"
+             "WM-ICON-NAME" "WM-NAME" "WM-NORMAL-HINTS" "WM-PROTOCOLS"
+             "WM-RESOURCES" "WM-SIZE-HINTS" "WM-SIZE-HINTS-BASE-HEIGHT"
+             "WM-SIZE-HINTS-BASE-WIDTH" "WM-SIZE-HINTS-HEIGHT"
+             "WM-SIZE-HINTS-HEIGHT-INC" "WM-SIZE-HINTS-MAX-ASPECT"
+             "WM-SIZE-HINTS-MAX-HEIGHT" "WM-SIZE-HINTS-MAX-WIDTH"
+             "WM-SIZE-HINTS-MIN-ASPECT" "WM-SIZE-HINTS-MIN-HEIGHT"
+             "WM-SIZE-HINTS-MIN-WIDTH" "WM-SIZE-HINTS-P"
+             "WM-SIZE-HINTS-USER-SPECIFIED-POSITION-P"
+             "WM-SIZE-HINTS-USER-SPECIFIED-SIZE-P" "WM-SIZE-HINTS-WIDTH"
+             "WM-SIZE-HINTS-WIDTH-INC" "WM-SIZE-HINTS-WIN-GRAVITY"
+             "WM-SIZE-HINTS-X" "WM-SIZE-HINTS-Y" "WM-ZOOM-HINTS"
+             "WRITE-BITMAP-FILE" "WRITE-RESOURCES" "XATOM"))
+(dolist
+    (name
+     '("BACKEND-SB-LIST" "DO-LIVE-TNS" "FINITE-SB" "FINITE-SB-LIVE-TNS"
+       "IR2-BLOCK-BLOCK" "IR2-BLOCK-LIVE-IN" "MAKE-INSTRUCTION" "PRINT-TN"
+       "REALLY-MAKE-INSTRUCTION" "SB-KIND" "SC-ELEMENT-SIZE" "TN" "TN-KIND"
+       "TN-NUMBER" "TN-READS" "TN-WRITES" "UNMAKE-INSTRUCTION" "VOP" "VOP-ARGS"
+       "VOP-BLOCK" "VOP-INFO" "VOP-INFO-ARG-COSTS" "VOP-INFO-ARG-TYPES"
+       "VOP-INFO-MOVE-ARGS" "VOP-INFO-NAME" "VOP-INFO-RESULT-COSTS"
+       "VOP-INFO-SAVE-P" "VOP-REFS" "VOP-RESULTS" "VOP-SAVE-SET" "VOP-TEMPS"))
+  (intern name "C"))
+(defpackage "ASSEMBLER"
+            (:import-from "C" "BACKEND-SB-LIST" "DO-LIVE-TNS" "FINITE-SB"
+             "FINITE-SB-LIVE-TNS" "IR2-BLOCK-BLOCK" "IR2-BLOCK-LIVE-IN"
+             "MAKE-INSTRUCTION" "PRINT-TN" "REALLY-MAKE-INSTRUCTION" "SB-KIND"
+             "SC-ELEMENT-SIZE" "TN" "TN-KIND" "TN-NUMBER" "TN-READS"
+             "TN-WRITES" "UNMAKE-INSTRUCTION" "VOP" "VOP-ARGS" "VOP-BLOCK"
+             "VOP-INFO" "VOP-INFO-ARG-COSTS" "VOP-INFO-ARG-TYPES"
+             "VOP-INFO-MOVE-ARGS" "VOP-INFO-NAME" "VOP-INFO-RESULT-COSTS"
+             "VOP-INFO-SAVE-P" "VOP-REFS" "VOP-RESULTS" "VOP-SAVE-SET"
+             "VOP-TEMPS")
+            (:export "*CURRENT-POSITION*" "ALIGN" "ASSEMBLE" "ASSEMBLY-CALL"
+             "COUNT-INSTRUCTIONS" "DEFINE-ARGUMENT-TYPE" "DEFINE-FIXUP-TYPE"
+             "DEFINE-FORMAT" "DEFINE-INSTRUCTION" "DEFINE-PSEUDO-INSTRUCTION"
+             "DEFINE-RANDOM-RESOURCES" "DEFINE-REGISTER-FILE"
+             "DEFINE-RESOURCES" "DELAYED-BRANCH" "DELAYED-LOAD" "DUMP-SEGMENT"
+             "EMIT-CODE-VECTOR" "EMIT-LABEL" "EXPAND-PSEUDO-INSTRUCTIONS"
+             "FINALIZE-SEGMENT" "FIXUP" "FIXUP-FLAVOR" "FIXUP-NAME"
+             "FIXUP-OFFSET" "FIXUP-P" "GEN-LABEL" "INSERT-SEGMENT" "INST"
+             "INSTRUCTION-ARGUMENT-ONE" "INSTRUCTION-ARGUMENT-THREE"
+             "INSTRUCTION-ARGUMENT-TWO" "INSTRUCTION-ARGUMENT-ZERO"
+             "INSTRUCTION-CONSTANT-ONE" "INSTRUCTION-CONSTANT-TWO"
+             "INSTRUCTION-CONSTANT-ZERO" "INSTRUCTION-RESULT-ZERO" "LABEL"
+             "LABEL-ID" "LABEL-POSITION" "MAKE-FIXUP" "MAKE-SEGMENT" "NOP"
+             "NUKE-SEGMENT" "OPTIMIZE-SEGMENT" "RELATIVE-BRANCH"
+             "SEGMENT-CHECK-REGISTERS" "UNCONDITIONAL-BRANCH"))
+(dolist (name '("CHAR" "FLOAT")) (intern name "LISP"))
+(defpackage "C-CALL"
+            (:import-from "LISP" "CHAR" "FLOAT")
+            (:export "C-STRING" "CHAR" "DOUBLE" "FLOAT" "INT" "LONG" "SHORT"
+             "UNSIGNED-CHAR" "UNSIGNED-INT" "UNSIGNED-LONG" "UNSIGNED-SHORT"
+             "VOID"))
+(defpackage "INSPECT"
+            (:export "*INTERFACE-STYLE*" "REMOVE-ALL-DISPLAYS"
+             "REMOVE-OBJECT-DISPLAY" "SHOW-OBJECT"))
+(defpackage "BIGNUM"
+            (:export "%ADD-WITH-CARRY" "%ALLOCATE-BIGNUM" "%ASHL" "%ASHR"
+             "%BIGNUM-LENGTH" "%BIGNUM-REF" "%BIGNUM-SET" "%BIGNUM-SET-LENGTH"
+             "%DIGIT-0-OR-PLUSP" "%DIGIT-LOGICAL-SHIFT-RIGHT"
+             "%FIXNUM-DIGIT-WITH-CORRECT-SIGN" "%FIXNUM-TO-DIGIT" "%FLOOR"
+             "%LOGAND" "%LOGIOR" "%LOGNOT" "%LOGXOR" "%MULTIPLY"
+             "%MULTIPLY-AND-ADD" "%SUBTRACT-WITH-BORROW" "ADD-BIGNUMS"
+             "BIGNUM-ASHIFT-LEFT" "BIGNUM-ASHIFT-RIGHT" "BIGNUM-COMPARE"
+             "BIGNUM-DEPOSIT-BYTE" "BIGNUM-ELEMENT-TYPE" "BIGNUM-GCD"
+             "BIGNUM-INDEX" "BIGNUM-INTEGER-LENGTH" "BIGNUM-LOAD-BYTE"
+             "BIGNUM-LOGCOUNT" "BIGNUM-LOGICAL-AND" "BIGNUM-LOGICAL-IOR"
+             "BIGNUM-LOGICAL-NOT" "BIGNUM-LOGICAL-XOR" "BIGNUM-PLUS-P"
+             "BIGNUM-TO-FLOAT" "BIGNUM-TRUNCATE" "BIGNUM-TYPE"
+             "FLOAT-BIGNUM-RATIO" "MAKE-SMALL-BIGNUM"
+             "MULTIPLY-BIGNUM-AND-FIXNUM" "MULTIPLY-BIGNUMS" "MULTIPLY-FIXNUMS"
+             "NEGATE-BIGNUM" "SUBTRACT-BIGNUM"))
+(defpackage "WALKER"
+            (:export "*VARIABLE-DECLARATIONS*" "DEFINE-WALKER-TEMPLATE"
+             "NESTED-WALK-FORM" "VARIABLE-DECLARATION"
+             "VARIABLE-GLOBALLY-SPECIAL-P" "VARIABLE-LEXICAL-P"
+             "VARIABLE-SPECIAL-P" "WALK-FORM"))
+(dolist
+    (name
+     '("*INTERRUPT-PENDING*" "*INTERRUPTS-ENABLED*" "DO-PENDING-INTERRUPT"))
+  (intern name "UNIX"))
+(defpackage "MACH"
+            (:import-from "UNIX" "*INTERRUPT-PENDING*" "*INTERRUPTS-ENABLED*"
+             "DO-PENDING-INTERRUPT")
+            (:export "*SIGCONTEXT" "AF-INET" "AF-UNIX" "BADMSGID" "BADREPLY"
+             "CHECK" "CLOSE-DIR" "CMU-GETAID" "DIRECT" "E2BIG" "EACCES"
+             "EADDRINUSE" "EADDRNOTAVAIL" "EAFNOSUPPORT" "EAGAIN" "EALREADY"
+             "EBADF" "EBUSY" "ECHILD" "ECONNABORTED" "ECONNREFUSED"
+             "ECONNRESET" "EDEADLK" "EDESTADDRREQ" "EDOM" "EDQUOT" "EEXIST"
+             "EFAULT" "EFBIG" "EHOSTDOWN" "EHOSTUNREACH" "EINPROGRESS" "EINTR"
+             "EINVAL" "EIO" "EISCONN" "EISDIR" "ELOCAL" "ELOOP" "EMFILE"
+             "EMLINK" "EMSGSIZE" "ENAMETOOLONG" "ENETDOWN" "ENETRESET"
+             "ENETUNREACH" "ENFILE" "ENOBUFS" "ENODEV" "ENOENT" "ENOEXEC"
+             "ENOMEM" "ENOPROTOOPT" "ENOSPC" "ENOTBLK" "ENOTCONN" "ENOTDIR"
+             "ENOTEMPTY" "ENOTSOCK" "ENOTTY" "ENXIO" "EOPNOTSUPP" "EPERM"
+             "EPFNOSUPPORT" "EPIPE" "EPROCLIM" "EPROTONOSUPPORT" "EPROTOTYPE"
+             "ERANGE" "EREMOTE" "ERESTART" "EROFS" "ESHUTDOWN"
+             "ESOCKTNOSUPPORT" "ESPIPE" "ESRCH" "ESUCCESS" "ETIMEDOUT"
+             "ETOOMANYREFS" "ETXTBSY" "EUSERS" "EVICEERR" "EVICEOP"
+             "EWOULDBLOCK" "EXDEV" "EXECGRP" "EXECOTH" "EXECOWN" "F-DUPFD"
+             "F-GETFD" "F-GETFL" "F-GETOWN" "F-SETFD" "F-SETFL" "F-SETOWN"
+             "FAPPEND" "FASYNC" "FCREAT" "FDARRAY" "FEXCL" "FILDES" "FIONREAD"
+             "FNDELAY" "FTRUNC" "F_OK" "GET-UNIX-ERROR-MSG"
+             "INDIRECT-*SIGCONTEXT" "INT-ARRAY" "INT-ARRAY-REF" "ITIMER-PROF"
+             "ITIMER-REAL" "ITIMER-VIRTUAL" "KBDARG" "KBDARG-END"
+             "KBDARG-INDEX" "KBDARG-SCAN" "KBDARG-TEXT" "KBDCGET" "KBDCRESET"
+             "KBDCRST" "KBDCSET" "KBDCSSTD" "KBDGCLICK" "KBDSCLICK" "KBDSGET"
+             "KERN-FAILURE" "KERN-INVALID-ADDRESS" "KERN-INVALID-ARGUMENT"
+             "KERN-NO-ACCESS" "KERN-NO-SPACE" "KERN-NOT-RECEIVER"
+             "KERN-PROTECTION-FAILURE" "KERN-RESOURCE-SHORTAGE" "KERN-SUCCESS"
+             "LOCK-EX" "LOCK-NB" "LOCK-SH" "LOCK-UN" "LTCHARS" "L_INCR" "L_SET"
+             "L_XTND" "MACH" "MACH-TASK_DATA" "MACH-TASK_NOTIFY"
+             "MACH-TASK_SELF" "MSG" "MSG-DONTROUTE" "MSG-ID" "MSG-LOCALPORT"
+             "MSG-MSGSIZE" "MSG-MSGTYPE" "MSG-OOB" "MSG-OPTION-NONE" "MSG-PEEK"
+             "MSG-RECEIVE" "MSG-REMOTEPORT" "MSG-SEND" "MSG-SIMPLEMSG"
+             "NOREPLY" "NOTIFY-LAST" "NOTIFY-MSG-ACCEPTED"
+             "NOTIFY-OWNERSHIP-RIGHTS" "NOTIFY-PORT-DELETED"
+             "NOTIFY-RECEIVE-RIGHTS" "NULLPORT" "OPEN-DIR" "O_APPEND" "O_CREAT"
+             "O_EXCL" "O_RDONLY" "O_RDWR" "O_TRUNC" "O_WRONLY" "PORT-ENABLED"
+             "PRIO-MAX" "PRIO-MIN" "PRIO-PGRP" "PRIO-PROCESS" "PRIO-USER"
+             "RCV-INTERRUPTED" "RCV-INVALID-MEMORY" "RCV-INVALID-PORT"
+             "RCV-NO-SENDERS" "RCV-NOT-ENOUGH-MEMORY" "RCV-ONLY-SENDER"
+             "RCV-SUCCESS" "RCV-TIMED-OUT" "RCV-TIMEOUT" "RCV-TOO-LARGE"
+             "READ-DIR" "READGRP" "READOTH" "READOWN" "RFS-AUTHENTICATE"
+             "RFSIOCGETRW" "RFSIOCGETS" "RFSIOCIDENTIFY" "RFSIOCSETRW"
+             "RFSIOCSETS" "RFSRW_ACCOUNT" "RFSRW_GROUP" "RFSRW_LOOKUP"
+             "RFSRW_NONE" "RFSRW_PASSWORD" "RFSRW_T" "RFSRW_USER" "RLIMIT-CORE"
+             "RLIMIT-CPU" "RLIMIT-DATA" "RLIMIT-FSIZE" "RLIMIT-INFINITY"
+             "RLIMIT-NLIMITS" "RLIMIT-RSS" "RLIMIT-STACK" "RPC-SUCCESS"
+             "RUSAGE" "RUSAGE_CHILDREN" "RUSAGE_SELF" "R_OK" "SAVETEXT"
+             "SEND-INTERRUPTED" "SEND-INVALID-MEMORY" "SEND-INVALID-PORT"
+             "SEND-KERNEL-REFUSED" "SEND-MSG-TOO-LARGE" "SEND-MSG-TOO-SMALL"
+             "SEND-NOTIFY" "SEND-SUCCESS" "SEND-TIMED-OUT" "SEND-TIMEOUT"
+             "SEND-WILL-NOTIFY-SEND-NOTIFY-IN-PROGRESS" "SET-UTARRAY"
+             "SETGIDEXEC" "SETUIDEXEC" "SGTTY" "SGTTY-ERASE" "SGTTY-FLAGS"
+             "SGTTY-ISPEED" "SGTTY-KILL" "SGTTY-OSPEED" "SIGALRM" "SIGBUS"
+             "SIGCHLD" "SIGCONT" "SIGCONTEXT" "SIGCONTEXT-BADPADDR"
+             "SIGCONTEXT-BADVADDR" "SIGCONTEXT-CAUSE" "SIGCONTEXT-FPC_CSR"
+             "SIGCONTEXT-FPC_EIR" "SIGCONTEXT-FPREGS" "SIGCONTEXT-MASK"
+             "SIGCONTEXT-MDHI" "SIGCONTEXT-MDLO" "SIGCONTEXT-ONSTACK"
+             "SIGCONTEXT-OWNEDFP" "SIGCONTEXT-PC" "SIGCONTEXT-REGS" "SIGEMSG"
+             "SIGEMT" "SIGFPE" "SIGHUP" "SIGILL" "SIGINT" "SIGIO" "SIGIOT"
+             "SIGKILL" "SIGMASK" "SIGMSG" "SIGPIPE" "SIGPROF" "SIGQUIT"
+             "SIGSEGV" "SIGSTOP" "SIGSYS" "SIGTERM" "SIGTRAP" "SIGTSTP"
+             "SIGTTIN" "SIGTTOU" "SIGURG" "SIGUSR1" "SIGUSR2" "SIGVTALRM"
+             "SIGWINCH" "SIGXCPU" "SIGXFSZ" "SIG_DFL" "SIG_IGN" "SOCK-DGRAM"
+             "SOCK-RAW" "SOCK-STREAM" "STAT" "TCHARS" "TERMINAL-SPEEDS"
+             "TIMEVAL" "TIMEZONE" "TIOCFLUSH" "TIOCGETC" "TIOCGETP" "TIOCGLTC"
+             "TIOCGPGRP" "TIOCGWINSZ" "TIOCNOTTY" "TIOCSETC" "TIOCSETP"
+             "TIOCSLTC" "TIOCSPGRP" "TIOCSWINSZ" "TTY-CBREAK" "TTY-CRMOD"
+             "TTY-ECHO" "TTY-LCASE" "TTY-RAW" "TTY-TANDEM" "TYPETYPE"
+             "UNIX-ACCEPT" "UNIX-ACCESS" "UNIX-BIND" "UNIX-CHDIR" "UNIX-CHMOD"
+             "UNIX-CHOWN" "UNIX-CLOSE" "UNIX-CONNECT" "UNIX-CREAT"
+             "UNIX-CURRENT-DIRECTORY" "UNIX-DUP" "UNIX-DUP2" "UNIX-ERRNO"
+             "UNIX-EXECVE" "UNIX-EXIT" "UNIX-FCHMOD" "UNIX-FCHOWN" "UNIX-FCNTL"
+             "UNIX-FILE-KIND" "UNIX-FLOCK" "UNIX-FORK" "UNIX-FSTAT"
+             "UNIX-FSYNC" "UNIX-FTRUNCATE" "UNIX-GETDTABLESIZE" "UNIX-GETEGID"
+             "UNIX-GETGID" "UNIX-GETGROUPS" "UNIX-GETHOSTID" "UNIX-GETHOSTNAME"
+             "UNIX-GETITIMER" "UNIX-GETPAGESIZE" "UNIX-GETPGRP" "UNIX-GETPID"
+             "UNIX-GETPPID" "UNIX-GETPRIORITY" "UNIX-GETRLIMIT"
+             "UNIX-GETRUSAGE" "UNIX-GETTIMEOFDAY" "UNIX-GETUID" "UNIX-IOCTL"
+             "UNIX-ISATTY" "UNIX-ISCONSOLE" "UNIX-KILL" "UNIX-KILLPG"
+             "UNIX-LINK" "UNIX-LISTEN" "UNIX-LSEEK" "UNIX-LSTAT"
+             "UNIX-MAYBE-PREPEND-CURRENT-DIRECTORY" "UNIX-MKDIR" "UNIX-OPEN"
+             "UNIX-PIPE" "UNIX-READ" "UNIX-READLINK" "UNIX-RECV"
+             "UNIX-RECVFROM" "UNIX-RENAME" "UNIX-RESOLVE-LINKS" "UNIX-RMDIR"
+             "UNIX-SELECT" "UNIX-SEND" "UNIX-SENDTO" "UNIX-SETGROUPS"
+             "UNIX-SETHOSTID" "UNIX-SETHOSTNAME" "UNIX-SETITIMER"
+             "UNIX-SETPGRP" "UNIX-SETPRIORITY" "UNIX-SETQUOTA" "UNIX-SETREGID"
+             "UNIX-SETREUID" "UNIX-SETRLIMIT" "UNIX-SETTIMEOFDAY"
+             "UNIX-SIGBLOCK" "UNIX-SIGNAL-DESCRIPTION" "UNIX-SIGNAL-NAME"
+             "UNIX-SIGNAL-NUMBER" "UNIX-SIGPAUSE" "UNIX-SIGSETMASK"
+             "UNIX-SIMPLIFY-PATHNAME" "UNIX-SOCKET" "UNIX-STAT" "UNIX-SYMLINK"
+             "UNIX-SYNC" "UNIX-TRUNCATE" "UNIX-TTYNAME" "UNIX-UNLINK"
+             "UNIX-UTIMES" "UNIX-WAIT" "UNIX-WRITE" "UNSPECEXCEPTION"
+             "VM_ALLOCATE" "VM_COPY" "VM_DEALLOCATE" "VM_STATISTICS" "WINSIZE"
+             "WINSIZE-WS_COL" "WINSIZE-WS_ROW" "WINSIZE-WS_XPIXEL"
+             "WINSIZE-WS_YPIXEL" "WITH-TRAP-ARG-BLOCK" "WNOHANG" "WRITEGRP"
+             "WRITEOTH" "WRITEOWN" "WRONGARGS" "WSTOPPED" "WUNTRACED" "W_OK"
+             "X_OK"))
+(defpackage "UNIX"
+            (:export "CADDR-T" "D-INO" "D-NAME" "D-NAMLEN" "D-OFF" "D-RECLEN"
+             "DADDR-T" "DEV-T" "DIRECT" "EXECGRP" "EXECOTH" "EXECOWN" "F-DUPFD"
+             "F-GETFD" "F-GETFL" "F-GETOWN" "F-SETFD" "F-SETFL" "F-SETOWN"
+             "FAPPEND" "FASYNC" "FCREAT" "FEXCL" "FIONREAD" "FNDELAY" "FTRUNC"
+             "F_OK" "GET-UNIX-ERROR-MSG" "GID-T" "INO-T" "IT-INTERVAL"
+             "IT-VALUE" "ITIMERVAL" "KBDCGET" "KBDCRESET" "KBDCRST" "KBDCSET"
+             "KBDCSSTD" "KBDGCLICK" "KBDSCLICK" "KBDSGET" "L_INCR" "L_SET"
+             "L_XTND" "OFF-T" "O_APPEND" "O_CREAT" "O_EXCL" "O_RDONLY" "O_RDWR"
+             "O_TRUNC" "O_WRONLY" "READGRP" "READOTH" "READOWN" "RLIM-CUR"
+             "RLIM-MAX" "RLIMIT" "RU-IDRSS" "RU-INBLOCK" "RU-ISRSS" "RU-IXRSS"
+             "RU-MAJFLT" "RU-MAXRSS" "RU-MINFLT" "RU-MSGRCV" "RU-MSGSND"
+             "RU-NIVCSW" "RU-NSIGNALS" "RU-NSWAP" "RU-NVCSW" "RU-OUBLOCK"
+             "RU-STIME" "RU-UTIME" "RUSAGE_CHILDREN" "RUSAGE_SELF" "RUSEAGE"
+             "R_OK" "S-IEXEC" "S-IFBLK" "S-IFCHR" "S-IFDIR" "S-IFLNK" "S-IFMT"
+             "S-IFREG" "S-IFSOCK" "S-IREAD" "S-ISGID" "S-ISUID" "S-ISVTX"
+             "S-IWRITE" "SAVETEXT" "SC-MASK" "SC-ONSTACK" "SC-PC" "SETGIDEXEC"
+             "SETUIDEXEC" "SG-ERASE" "SG-FLAGS" "SG-ISPEED" "SG-KILL"
+             "SG-OSPEED" "SGTTYB" "SIGCONTEXT" "SIZE-T" "ST-ATIME" "ST-BLKSIZE"
+             "ST-BLOCKS" "ST-CTIME" "ST-DEV" "ST-GID" "ST-MODE" "ST-MTIME"
+             "ST-NLINK" "ST-RDEV" "ST-SIZE" "ST-UID" "STAT" "SWBLK-T" "T-BRKC"
+             "T-DSUSPC" "T-EOFC" "T-FLUSHC" "T-INTRC" "T-LNEXTC" "T-QUITC"
+             "T-RPRNTC" "T-STARTC" "T-STOPC" "T-SUSPC" "T-WERASC" "TCHARS"
+             "TERMINAL-SPEEDS" "TIME-T" "TIMEVAL" "TIMEZONE" "TIOCFLUSH"
+             "TIOCGETC" "TIOCGETP" "TIOCGLTC" "TIOCGPGRP" "TIOCGWINSZ"
+             "TIOCNOTTY" "TIOCSETC" "TIOCSETP" "TIOCSLTC" "TIOCSPGRP"
+             "TIOCSWINSZ" "TTY-CBREAK" "TTY-CRMOD" "TTY-ECHO" "TTY-LCASE"
+             "TTY-RAW" "TTY-TANDEM" "TV-SEC" "TV-USEC" "TZ-DSTTIME"
+             "TZ-MINUTESWEST" "UID-T" "UNIX-ACCEPT" "UNIX-ACCESS" "UNIX-BIND"
+             "UNIX-CHDIR" "UNIX-CHMOD" "UNIX-CHOWN" "UNIX-CLOSE" "UNIX-CONNECT"
+             "UNIX-CREAT" "UNIX-CURRENT-DIRECTORY" "UNIX-DUP" "UNIX-DUP2"
+             "UNIX-ERRNO" "UNIX-EXECVE" "UNIX-EXIT" "UNIX-FCHMOD" "UNIX-FCHOWN"
+             "UNIX-FCNTL" "UNIX-FD" "UNIX-FILE-MODE" "UNIX-FORK" "UNIX-FSTAT"
+             "UNIX-FSYNC" "UNIX-FTRUNCATE" "UNIX-GETDTABLESIZE" "UNIX-GETEGID"
+             "UNIX-GETGID" "UNIX-GETHOSTID" "UNIX-GETHOSTNAME"
+             "UNIX-GETPAGESIZE" "UNIX-GETPGRP" "UNIX-GETPID" "UNIX-GETPPID"
+             "UNIX-GETRUSAGE" "UNIX-GETTIMEOFDAY" "UNIX-GETUID" "UNIX-GID"
+             "UNIX-IOCTL" "UNIX-ISATTY" "UNIX-LINK" "UNIX-LISTEN" "UNIX-LSEEK"
+             "UNIX-LSTAT" "UNIX-MKDIR" "UNIX-OPEN" "UNIX-PATHNAME" "UNIX-PID"
+             "UNIX-PIPE" "UNIX-READ" "UNIX-READLINK" "UNIX-RECV" "UNIX-RENAME"
+             "UNIX-RMDIR" "UNIX-SELECT" "UNIX-SEND" "UNIX-SETPGRP"
+             "UNIX-SETREGID" "UNIX-SETREUID" "UNIX-SOCKET" "UNIX-STAT"
+             "UNIX-SYMLINK" "UNIX-SYNC" "UNIX-TRUNCATE" "UNIX-TTYNAME"
+             "UNIX-UID" "UNIX-UNLINK" "UNIX-UTIMES" "UNIX-WRITE" "WINSIZE"
+             "WRITEGRP" "WRITEOTH" "WRITEOWN" "WS-COL" "WS-ROW" "WS-XPIXEL"
+             "WS-YPIXEL" "W_OK" "X_OK"))
+(intern "FUNCALLABLE-INSTANCE-P" "KERNEL")
+(defpackage "PCL"
+            (:import-from "KERNEL" "FUNCALLABLE-INSTANCE-P")
+            (:export "ADD-METHOD" "BUILT-IN-CLASS" "CALL-METHOD"
+             "CALL-NEXT-METHOD" "CHANGE-CLASS" "CLASS-NAME" "CLASS-OF"
+             "COMPUTE-APPLICABLE-METHODS" "DEFCLASS" "DEFGENERIC"
+             "DEFINE-METHOD-COMBINATION" "DEFMETHOD" "ENSURE-GENERIC-FUNCTION"
+             "FIND-CLASS" "FIND-METHOD" "FUNCTION-KEYWORDS" "GENERIC-FLET"
+             "GENERIC-LABELS" "INITIALIZE-INSTANCE" "INVALID-METHOD-ERROR"
+             "MAKE-INSTANCE" "MAKE-INSTANCES-OBSOLETE"
+             "METHOD-COMBINATION-ERROR" "METHOD-QUALIFIERS" "NEXT-METHOD-P"
+             "NO-APPLICABLE-METHOD" "NO-NEXT-METHOD" "PRINT-OBJECT"
+             "REINITIALIZE-INSTANCE" "REMOVE-METHOD" "SHARED-INITIALIZE"
+             "SLOT-BOUNDP" "SLOT-EXISTS-P" "SLOT-MAKUNBOUND" "SLOT-MISSING"
+             "SLOT-UNBOUND" "SLOT-VALUE" "STANDARD" "STANDARD-CLASS"
+             "STANDARD-GENERIC-FUNCTION" "STANDARD-METHOD" "STANDARD-OBJECT"
+             "STRUCTURE-CLASS" "UPDATE-INSTANCE-FOR-DIFFERENT-CLASS"
+             "UPDATE-INSTANCE-FOR-REDEFINED-CLASS" "WITH-ACCESSORS"
+             "WITH-ADDED-METHODS" "WITH-SLOTS"))
+(defpackage "FORMAT")
+(defpackage "HEMLOCK")
+(defpackage "SPELL"
+            (:export "CORRECT-SPELLING" "MAX-ENTRY-LENGTH"
+             "MAYBE-READ-SPELL-DICTIONARY" "SPELL-ADD-ENTRY"
+             "SPELL-COLLECT-CLOSE-WORDS" "SPELL-READ-DICTIONARY"
+             "SPELL-REMOVE-ENTRY" "SPELL-ROOT-FLAGS" "SPELL-ROOT-WORD"
+             "SPELL-TRY-WORD"))
+(defpackage "LISP"
+            (:export "&ALLOW-OTHER-KEYS" "&AUX" "&BODY" "&ENVIRONMENT" "&KEY"
+             "&OPTIONAL" "&REST" "&WHOLE" "*" "**" "***" "*APPLYHOOK*"
+             "*BREAK-ON-SIGNALS*" "*BREAK-ON-WARNINGS*"
+             "*COMPILE-FILE-PATHNAME*" "*COMPILE-FILE-TRUENAME*"
+             "*COMPILE-PRINT*" "*COMPILE-VERBOSE*" "*DEBUG-IO*"
+             "*DEBUGGER-HOOK*" "*DEFAULT-PATHNAME-DEFAULTS*"
+             "*DESCRIBE-INDENTATION*" "*DESCRIBE-LEVEL*"
+             "*DESCRIBE-PRINT-LENGTH*" "*DESCRIBE-PRINT-LEVEL*"
+             "*DESCRIBE-VERBOSE*" "*ERROR-OUTPUT*" "*EVALHOOK*" "*FEATURES*"
+             "*GENSYM-COUNTER*" "*LOAD-VERBOSE*" "*MACROEXPAND-HOOK*"
+             "*MODULES*" "*PACKAGE*" "*PRINT-ARRAY*" "*PRINT-BASE*"
+             "*PRINT-CASE*" "*PRINT-CIRCLE*" "*PRINT-ESCAPE*" "*PRINT-GENSYM*"
+             "*PRINT-LENGTH*" "*PRINT-LEVEL*" "*PRINT-LINES*"
+             "*PRINT-MISER-WIDTH*" "*PRINT-PPRINT-DISPATCH*" "*PRINT-PRETTY*"
+             "*PRINT-RADIX*" "*PRINT-READABLY*" "*PRINT-RIGHT-MARGIN*"
+             "*QUERY-IO*" "*RANDOM-STATE*" "*READ-BASE*"
+             "*READ-DEFAULT-FLOAT-FORMAT*" "*READ-EVAL*" "*READ-SUPPRESS*"
+             "*READTABLE*" "*STANDARD-INPUT*" "*STANDARD-OUTPUT*"
+             "*TERMINAL-IO*" "*TRACE-OUTPUT*" "+" "++" "+++" "-" "/" "//" "///"
+             "/=" "1+" "1-" "<" "<=" "=" ">" ">=" "ABORT" "ABS" "ACONS" "ACOS"
+             "ACOSH" "ADJOIN" "ADJUST-ARRAY" "ADJUSTABLE-ARRAY-P"
+             "ALPHA-CHAR-P" "ALPHANUMERICP" "AND" "APPEND" "APPLY" "APPLYHOOK"
+             "APROPOS" "APROPOS-LIST" "AREF" "ARITHMETIC-ERROR"
+             "ARITHMETIC-ERROR-OPERANDS" "ARITHMETIC-ERROR-OPERATION" "ARRAY"
+             "ARRAY-DIMENSION" "ARRAY-DIMENSION-LIMIT" "ARRAY-DIMENSIONS"
+             "ARRAY-ELEMENT-TYPE" "ARRAY-HAS-FILL-POINTER-P"
+             "ARRAY-IN-BOUNDS-P" "ARRAY-RANK" "ARRAY-RANK-LIMIT"
+             "ARRAY-ROW-MAJOR-INDEX" "ARRAY-TOTAL-SIZE"
+             "ARRAY-TOTAL-SIZE-LIMIT" "ARRAYP" "ASH" "ASIN" "ASINH" "ASSERT"
+             "ASSOC" "ASSOC-IF" "ASSOC-IF-NOT" "ATAN" "ATANH" "ATOM"
+             "BASE-CHAR" "BASE-CHARACTER" "BASE-STRING" "BIGNUM" "BIT"
+             "BIT-AND" "BIT-ANDC1" "BIT-ANDC2" "BIT-EQV" "BIT-IOR" "BIT-NAND"
+             "BIT-NOR" "BIT-NOT" "BIT-ORC1" "BIT-ORC2" "BIT-VECTOR"
+             "BIT-VECTOR-P" "BIT-XOR" "BLOCK" "BOOLE" "BOOLE-1" "BOOLE-2"
+             "BOOLE-AND" "BOOLE-ANDC1" "BOOLE-ANDC2" "BOOLE-C1" "BOOLE-C2"
+             "BOOLE-CLR" "BOOLE-EQV" "BOOLE-IOR" "BOOLE-NAND" "BOOLE-NOR"
+             "BOOLE-ORC1" "BOOLE-ORC2" "BOOLE-SET" "BOOLE-XOR" "BOTH-CASE-P"
+             "BOUNDP" "BREAK" "BUTLAST" "BYTE" "BYTE-POSITION" "BYTE-SIZE"
+             "CAAAAR" "CAAADR" "CAAAR" "CAADAR" "CAADDR" "CAADR" "CAAR"
+             "CADAAR" "CADADR" "CADAR" "CADDAR" "CADDDR" "CADDR" "CADR"
+             "CALL-ARGUMENTS-LIMIT" "CAR" "CASE" "CATCH" "CCASE" "CDAAAR"
+             "CDAADR" "CDAAR" "CDADAR" "CDADDR" "CDADR" "CDAR" "CDDAAR"
+             "CDDADR" "CDDAR" "CDDDAR" "CDDDDR" "CDDDR" "CDDR" "CDR" "CEILING"
+             "CELL-ERROR" "CERROR" "CHAR" "CHAR-BIT" "CHAR-BITS"
+             "CHAR-BITS-LIMIT" "CHAR-CODE" "CHAR-CODE-LIMIT" "CHAR-CONTROL-BIT"
+             "CHAR-DOWNCASE" "CHAR-EQUAL" "CHAR-FONT" "CHAR-FONT-LIMIT"
+             "CHAR-GREATERP" "CHAR-HYPER-BIT" "CHAR-INT" "CHAR-LESSP"
+             "CHAR-META-BIT" "CHAR-NAME" "CHAR-NOT-EQUAL" "CHAR-NOT-GREATERP"
+             "CHAR-NOT-LESSP" "CHAR-SUPER-BIT" "CHAR-UPCASE" "CHAR/=" "CHAR<"
+             "CHAR<=" "CHAR=" "CHAR>" "CHAR>=" "CHARACTER" "CHARACTERP"
+             "CHECK-TYPE" "CIS" "CLEAR-INPUT" "CLEAR-OUTPUT" "CLOSE" "CLRHASH"
+             "CODE-CHAR" "COERCE" "COMMON" "COMMONP" "COMPILATION-SPEED"
+             "COMPILE" "COMPILE-FILE" "COMPILED-FUNCTION" "COMPILED-FUNCTION-P"
+             "COMPILER-LET" "COMPLEMENT" "COMPLEX" "COMPLEXP"
+             "COMPUTE-RESTARTS" "CONCATENATE" "COND" "CONDITION" "CONJUGATE"
+             "CONS" "CONSP" "CONSTANTLY" "CONSTANTP" "CONTINUE" "CONTROL-ERROR"
+             "COPY-ALIST" "COPY-LIST" "COPY-PPRINT-DISPATCH" "COPY-READTABLE"
+             "COPY-SEQ" "COPY-SYMBOL" "COPY-TREE" "COS" "COSH" "COUNT"
+             "COUNT-IF" "COUNT-IF-NOT" "CTYPECASE" "DEBUG-INFO" "DECF"
+             "DECLAIM" "DECLARATION" "DECLARE" "DECODE-FLOAT"
+             "DECODE-UNIVERSAL-TIME" "DEFCONSTANT" "DEFINE-CONDITION"
+             "DEFINE-MODIFY-MACRO" "DEFINE-SETF-METHOD" "DEFMACRO" "DEFPACKAGE"
+             "DEFPARAMETER" "DEFSETF" "DEFSTRUCT" "DEFTYPE" "DEFUN" "DEFVAR"
+             "DELETE" "DELETE-DUPLICATES" "DELETE-FILE" "DELETE-IF"
+             "DELETE-IF-NOT" "DENOMINATOR" "DEPOSIT-FIELD" "DESCRIBE"
+             "DESTRUCTURING-BIND" "DIGIT-CHAR" "DIGIT-CHAR-P" "DIRECTORY"
+             "DIRECTORY-NAMESTRING" "DISASSEMBLE" "DIVISION-BY-ZERO" "DO" "DO*"
+             "DO-ALL-SYMBOLS" "DO-EXTERNAL-SYMBOLS" "DO-SYMBOLS"
+             "DOCUMENTATION" "DOLIST" "DOTIMES" "DOUBLE-FLOAT"
+             "DOUBLE-FLOAT-EPSILON" "DOUBLE-FLOAT-NEGATIVE-EPSILON" "DPB"
+             "DRIBBLE" "ECASE" "ED" "EIGHTH" "ELT" "ENCODE-UNIVERSAL-TIME"
+             "END-OF-FILE" "ENDP" "ENOUGH-NAMESTRING" "EQ" "EQL" "EQUAL"
+             "EQUALP" "ERROR" "ETYPECASE" "EVAL" "EVAL-WHEN" "EVALHOOK" "EVENP"
+             "EVERY" "EXP" "EXPORT" "EXPT" "EXTENDED-CHAR" "FBOUNDP" "FCEILING"
+             "FDEFINITION" "FFLOOR" "FIFTH" "FILE-AUTHOR" "FILE-ERROR"
+             "FILE-ERROR-PATHNAME" "FILE-LENGTH" "FILE-NAMESTRING"
+             "FILE-POSITION" "FILE-WRITE-DATE" "FILL" "FILL-POINTER" "FIND"
+             "FIND-ALL-SYMBOLS" "FIND-IF" "FIND-IF-NOT" "FIND-PACKAGE"
+             "FIND-RESTART" "FIND-SYMBOL" "FINISH-OUTPUT" "FIRST" "FIXNUM"
+             "FLET" "FLOAT" "FLOAT-DIGITS" "FLOAT-PRECISION" "FLOAT-RADIX"
+             "FLOAT-SIGN" "FLOATING-POINT-OVERFLOW" "FLOATING-POINT-UNDERFLOW"
+             "FLOATP" "FLOOR" "FMAKUNBOUND" "FORCE-OUTPUT" "FORMAT" "FORMATTER"
+             "FOURTH" "FRESH-LINE" "FROUND" "FTRUNCATE" "FTYPE" "FUNCALL"
+             "FUNCTION" "FUNCTION-LAMBDA-EXPRESSION" "FUNCTIONP" "GCD" "GENSYM"
+             "GENTEMP" "GET" "GET-DECODED-TIME" "GET-DISPATCH-MACRO-CHARACTER"
+             "GET-INTERNAL-REAL-TIME" "GET-INTERNAL-RUN-TIME"
+             "GET-MACRO-CHARACTER" "GET-OUTPUT-STREAM-STRING" "GET-PROPERTIES"
+             "GET-SETF-METHOD" "GET-SETF-METHOD-MULTIPLE-VALUE"
+             "GET-UNIVERSAL-TIME" "GETF" "GETHASH" "GO" "GRAPHIC-CHAR-P"
+             "HANDLER-BIND" "HANDLER-CASE" "HASH-TABLE" "HASH-TABLE-COUNT"
+             "HASH-TABLE-P" "HOST-NAMESTRING" "IDENTITY" "IF" "IGNORABLE"
+             "IGNORE" "IGNORE-ERRORS" "IMAGPART" "IMPORT" "IN-PACKAGE" "INCF"
+             "INLINE" "INPUT-STREAM-P" "INSPECT" "INT-CHAR" "INTEGER"
+             "INTEGER-DECODE-FLOAT" "INTEGER-LENGTH" "INTEGERP" "INTERN"
+             "INTERNAL-TIME-UNITS-PER-SECOND" "INTERSECTION" "INVOKE-DEBUGGER"
+             "INVOKE-RESTART" "INVOKE-RESTART-INTERACTIVELY" "ISQRT" "KEYWORD"
+             "KEYWORDP" "LABELS" "LAMBDA" "LAMBDA-LIST-KEYWORDS"
+             "LAMBDA-PARAMETERS-LIMIT" "LAST" "LCM" "LDB" "LDB-TEST" "LDIFF"
+             "LEAST-NEGATIVE-DOUBLE-FLOAT" "LEAST-NEGATIVE-LONG-FLOAT"
+	     "LEAST-NEGATIVE-NORMALIZED-DOUBLE-FLOAT"
+	     "LEAST-NEGATIVE-NORMALIZED-LONG-FLOAT"
+	     "LEAST-NEGATIVE-NORMALIZED-SHORT-FLOAT"
+	     "LEAST-NEGATIVE-NORMALIZED-SINGLE-FLOAT"
+             "LEAST-NEGATIVE-SHORT-FLOAT" "LEAST-NEGATIVE-SINGLE-FLOAT"
+             "LEAST-POSITIVE-DOUBLE-FLOAT" "LEAST-POSITIVE-LONG-FLOAT"
+             "LEAST-POSITIVE-NORMALIZED-DOUBLE-FLOAT"
+             "LEAST-POSITIVE-NORMALIZED-LONG-FLOAT"
+             "LEAST-POSITIVE-NORMALIZED-SHORT-FLOAT"
+             "LEAST-POSITIVE-NORMALIZED-SINGLE-FLOAT"
+             "LEAST-POSITIVE-SHORT-FLOAT" "LEAST-POSITIVE-SINGLE-FLOAT"
+             "LENGTH" "LET" "LET*" "LISP-IMPLEMENTATION-TYPE"
+             "LISP-IMPLEMENTATION-VERSION" "LIST" "LIST*" "LIST-ALL-PACKAGES"
+             "LIST-LENGTH" "LISTEN" "LISTP" "LOAD" "LOAD-TIME-VALUE" "LOCALLY"
+             "LOG" "LOGAND" "LOGANDC1" "LOGANDC2" "LOGBITP" "LOGCOUNT" "LOGEQV"
+             "LOGIOR" "LOGNAND" "LOGNOR" "LOGNOT" "LOGORC1" "LOGORC2" "LOGTEST"
+             "LOGXOR" "LONG-FLOAT" "LONG-FLOAT-EPSILON"
+             "LONG-FLOAT-NEGATIVE-EPSILON" "LONG-SITE-NAME" "LOOP"
+             "LOOP-FINISH" "LOWER-CASE-P" "MACHINE-INSTANCE" "MACHINE-TYPE"
+             "MACHINE-VERSION" "MACRO-FUNCTION" "MACROEXPAND" "MACROEXPAND-1"
+             "MACROLET" "MAKE-ARRAY" "MAKE-BROADCAST-STREAM" "MAKE-CHAR"
+             "MAKE-CONCATENATED-STREAM" "MAKE-CONDITION"
+             "MAKE-DISPATCH-MACRO-CHARACTER" "MAKE-ECHO-STREAM"
+             "MAKE-HASH-TABLE" "MAKE-LIST" "MAKE-PACKAGE" "MAKE-PATHNAME"
+             "MAKE-RANDOM-STATE" "MAKE-SEQUENCE" "MAKE-STRING"
+             "MAKE-STRING-INPUT-STREAM" "MAKE-STRING-OUTPUT-STREAM"
+             "MAKE-SYMBOL" "MAKE-SYNONYM-STREAM" "MAKE-TWO-WAY-STREAM"
+             "MAKUNBOUND" "MAP" "MAPC" "MAPCAN" "MAPCAR" "MAPCON" "MAPHASH"
+             "MAPL" "MAPLIST" "MASK-FIELD" "MAX" "MEMBER" "MEMBER-IF"
+             "MEMBER-IF-NOT" "MERGE" "MERGE-PATHNAMES" "MIN" "MINUSP"
+             "MISMATCH" "MOD" "MOST-NEGATIVE-DOUBLE-FLOAT"
+             "MOST-NEGATIVE-FIXNUM" "MOST-NEGATIVE-LONG-FLOAT"
+             "MOST-NEGATIVE-SHORT-FLOAT" "MOST-NEGATIVE-SINGLE-FLOAT"
+             "MOST-POSITIVE-DOUBLE-FLOAT" "MOST-POSITIVE-FIXNUM"
+             "MOST-POSITIVE-LONG-FLOAT" "MOST-POSITIVE-SHORT-FLOAT"
+             "MOST-POSITIVE-SINGLE-FLOAT" "MUFFLE-WARNING"
+             "MULTIPLE-VALUE-BIND" "MULTIPLE-VALUE-CALL" "MULTIPLE-VALUE-LIST"
+             "MULTIPLE-VALUE-PROG1" "MULTIPLE-VALUE-SETQ"
+             "MULTIPLE-VALUES-LIMIT" "NAME-CHAR" "NAMESTRING" "NBUTLAST"
+             "NCONC" "NIL" "NINTERSECTION" "NINTH" "NOT" "NOTANY" "NOTEVERY"
+             "NOTINLINE" "NRECONC" "NREVERSE" "NSET-DIFFERENCE"
+             "NSET-EXCLUSIVE-OR" "NSTRING-CAPITALIZE" "NSTRING-DOWNCASE"
+             "NSTRING-UPCASE" "NSUBLIS" "NSUBST" "NSUBST-IF" "NSUBST-IF-NOT"
+             "NSUBSTITUTE" "NSUBSTITUTE-IF" "NSUBSTITUTE-IF-NOT" "NTH"
+             "NTH-VALUE" "NTHCDR" "NULL" "NUMBER" "NUMBERP" "NUMERATOR"
+             "NUNION" "ODDP" "OPEN" "OPTIMIZE" "OR" "OTHERWISE"
+             "OUTPUT-STREAM-P" "PACKAGE" "PACKAGE-ERROR"
+             "PACKAGE-ERROR-PACKAGE" "PACKAGE-NAME" "PACKAGE-NICKNAMES"
+             "PACKAGE-SHADOWING-SYMBOLS" "PACKAGE-USE-LIST"
+             "PACKAGE-USED-BY-LIST" "PACKAGEP" "PAIRLIS" "PARSE-INTEGER"
+             "PARSE-NAMESTRING" "PATHNAME" "PATHNAME-DEVICE"
+             "PATHNAME-DIRECTORY" "PATHNAME-HOST" "PATHNAME-MATCH-P"
+             "PATHNAME-NAME" "PATHNAME-TYPE" "PATHNAME-VERSION" "PATHNAMEP"
+             "PEEK-CHAR" "PHASE" "PI" "PLUSP" "POP" "POSITION" "POSITION-IF"
+             "POSITION-IF-NOT" "PPRINT" "PPRINT-DISPATCH"
+             "PPRINT-EXIT-IF-LIST-EXHAUSTED" "PPRINT-FILL" "PPRINT-INDENT"
+             "PPRINT-LINEAR" "PPRINT-LOGICAL-BLOCK" "PPRINT-NEWLINE"
+             "PPRINT-POP" "PPRINT-TAB" "PPRINT-TABULAR" "PRIN1"
+             "PRIN1-TO-STRING" "PRINC" "PRINC-TO-STRING" "PRINT"
+             "PRINT-UNREADABLE-OBJECT" "PROBE-FILE" "PROCLAIM" "PROG" "PROG*"
+             "PROG1" "PROG2" "PROGN" "PROGRAM-ERROR" "PROGV" "PROVIDE" "PSETF"
+             "PSETQ" "PUSH" "PUSHNEW" "QUOTE" "RANDOM" "RANDOM-STATE"
+             "RANDOM-STATE-P" "RASSOC" "RASSOC-IF" "RASSOC-IF-NOT" "RATIO"
+             "RATIONAL" "RATIONALIZE" "RATIONALP" "READ" "READ-BYTE"
+             "READ-CHAR" "READ-CHAR-NO-HANG" "READ-DELIMITED-LIST"
+             "READ-FROM-STRING" "READ-LINE" "READ-PRESERVING-WHITESPACE"
+             "READTABLE" "READTABLEP" "REAL" "REALPART" "REDUCE" "REM" "REMF"
+             "REMHASH" "REMOVE" "REMOVE-DUPLICATES" "REMOVE-IF" "REMOVE-IF-NOT"
+             "REMPROP" "RENAME-FILE" "RENAME-PACKAGE" "REPLACE" "REQUIRE"
+             "REST" "RESTART" "RESTART-BIND" "RESTART-CASE" "RESTART-NAME"
+             "RETURN" "RETURN-FROM" "REVAPPEND" "REVERSE" "ROOM" "ROTATEF"
+             "ROUND" "ROW-MAJOR-AREF" "RPLACA" "RPLACD" "SAFETY" "SATISFIES"
+             "SBIT" "SCALE-FLOAT" "SCHAR" "SEARCH" "SECOND" "SEQUENCE"
+             "SERIOUS-CONDITION" "SET" "SET-CHAR-BIT" "SET-DIFFERENCE"
+             "SET-DISPATCH-MACRO-CHARACTER" "SET-EXCLUSIVE-OR"
+             "SET-MACRO-CHARACTER" "SET-PPRINT-DISPATCH" "SET-SYNTAX-FROM-CHAR"
+             "SETF" "SETQ" "SEVENTH" "SHADOW" "SHADOWING-IMPORT" "SHIFTF"
+             "SHORT-FLOAT" "SHORT-FLOAT-EPSILON" "SHORT-FLOAT-NEGATIVE-EPSILON"
+             "SHORT-SITE-NAME" "SIGNAL" "SIGNED-BYTE" "SIGNUM" "SIMPLE-ARRAY"
+             "SIMPLE-BASE-STRING" "SIMPLE-BIT-VECTOR" "SIMPLE-BIT-VECTOR-P"
+             "SIMPLE-CONDITION" "SIMPLE-CONDITION-FORMAT-ARGUMENTS"
+             "SIMPLE-CONDITION-FORMAT-STRING" "SIMPLE-ERROR" "SIMPLE-STRING"
+             "SIMPLE-STRING-P" "SIMPLE-TYPE-ERROR" "SIMPLE-VECTOR"
+             "SIMPLE-VECTOR-P" "SIMPLE-WARNING" "SIN" "SINGLE-FLOAT"
+             "SINGLE-FLOAT-EPSILON" "SINGLE-FLOAT-NEGATIVE-EPSILON" "SINH"
+             "SIXTH" "SLEEP" "SOFTWARE-TYPE" "SOFTWARE-VERSION" "SOME" "SORT"
+             "SPACE" "SPECIAL" "SPECIAL-FORM-P" "SPEED" "SQRT" "STABLE-SORT"
+             "STACK-OVERFLOW" "STANDARD-CHAR" "STANDARD-CHAR-P" "STEP"
+             "STORAGE-CONDITION" "STORAGE-EXHAUSTED" "STORE-VALUE" "STREAM"
+             "STREAM-ELEMENT-TYPE" "STREAM-ERROR" "STREAM-ERROR-STREAM"
+             "STREAMP" "STRING" "STRING-CAPITALIZE" "STRING-CHAR"
+             "STRING-CHAR-P" "STRING-DOWNCASE" "STRING-EQUAL" "STRING-GREATERP"
+             "STRING-LEFT-TRIM" "STRING-LESSP" "STRING-NOT-EQUAL"
+             "STRING-NOT-GREATERP" "STRING-NOT-LESSP" "STRING-RIGHT-TRIM"
+             "STRING-TRIM" "STRING-UPCASE" "STRING/=" "STRING<" "STRING<="
+             "STRING=" "STRING>" "STRING>=" "STRINGP" "STRUCTURE" "SUBLIS"
+             "SUBSEQ" "SUBSETP" "SUBST" "SUBST-IF" "SUBST-IF-NOT" "SUBSTITUTE"
+             "SUBSTITUTE-IF" "SUBSTITUTE-IF-NOT" "SUBTYPEP" "SVREF" "SXHASH"
+             "SYMBOL" "SYMBOL-FUNCTION" "SYMBOL-MACROLET" "SYMBOL-NAME"
+             "SYMBOL-PACKAGE" "SYMBOL-PLIST" "SYMBOL-VALUE" "SYMBOLP" "T"
+             "TAGBODY" "TAILP" "TAN" "TANH" "TENTH" "TERPRI" "THE" "THIRD"
+             "THROW" "TIME" "TRACE" "TRANSLATE-PATHNAME" "TREE-EQUAL"
+             "TRUENAME" "TRUNCATE" "TYPE" "TYPE-ERROR" "TYPE-ERROR-DATUM"
+             "TYPE-ERROR-EXPECTED-TYPE" "TYPE-OF" "TYPECASE" "TYPEP"
+             "UNBOUND-VARIABLE" "UNDEFINED-FUNCTION" "UNEXPORT" "UNINTERN"
+             "UNION" "UNLESS" "UNREAD-CHAR" "UNSIGNED-BYTE" "UNTRACE"
+             "UNUSE-PACKAGE" "UNWIND-PROTECT" "UPPER-CASE-P" "USE-PACKAGE"
+             "USE-VALUE" "USER-HOMEDIR-PATHNAME" "VALUES" "VALUES-LIST"
+             "VARIABLE" "VECTOR" "VECTOR-POP" "VECTOR-PUSH"
+             "VECTOR-PUSH-EXTEND" "VECTORP" "WARN" "WARNING" "WHEN"
+             "WILD-PATHNAME-P" "WITH-COMPILATION-UNIT"
+             "WITH-HASH-TABLE-ITERATOR" "WITH-INPUT-FROM-STRING"
+             "WITH-OPEN-FILE" "WITH-OPEN-STREAM" "WITH-OUTPUT-TO-STRING"
+             "WITH-PACKAGE-ITERATOR" "WITH-SIMPLE-RESTART"
+             "WITH-STANDARD-IO-SYNTAX" "WRITE" "WRITE-BYTE" "WRITE-CHAR"
+             "WRITE-LINE" "WRITE-STRING" "WRITE-TO-STRING" "Y-OR-N-P"
+             "YES-OR-NO-P" "ZEROP"))
+(defpackage "EVAL"
+            (:export "*EVAL-STACK-TRACE*" "*INTERNAL-APPLY-NODE-TRACE*"
+             "*INTERPRETED-FUNCTION-CACHE-MINIMUM-SIZE*"
+             "*INTERPRETED-FUNCTION-CACHE-THRESHOLD*"
+             "FLUSH-INTERPRETED-FUNCTION-CACHE" "INTERNAL-EVAL"
+             "INTERPRETED-FUNCTION-ARGLIST" "INTERPRETED-FUNCTION-CLOSURE"
+             "INTERPRETED-FUNCTION-LAMBDA-EXPRESSION"
+             "INTERPRETED-FUNCTION-NAME" "INTERPRETED-FUNCTION-P"
+             "INTERPRETED-FUNCTION-TYPE" "MAKE-INTERPRETED-FUNCTION"
+             "TRACE-EVAL"))
+(defpackage "ITERATE"
+            (:export "*ITERATE-WARNINGS*" "COLLECTING" "EACHTIME" "ELEMENTS"
+             "GATHER" "GATHERING" "INTERVAL" "ITERATE" "ITERATE*" "JOINING"
+             "LIST-ELEMENTS" "LIST-TAILS" "MAXIMIZING" "MINIMIZING"
+             "PLIST-ELEMENTS" "SUMMING" "UNTIL" "WHILE" "WITH-GATHERING"))
+(dolist
+    (name
+     '("%ARRAY-TYPEP" "%ASET" "%BITSET" "%CHARSET" "%PUT" "%RPLACA" "%RPLACD"
+       "%SBITSET" "%SCHARSET" "%SET-DOCUMENTATION" "%SET-FDEFINITION"
+       "%SET-FILL-POINTER" "%SET-ROW-MAJOR-AREF" "%SETELT" "%SETNTH"
+       "%SP-STRING-COMPARE" "%SVSET" "%TYPEP" "*READ-ONLY-SPACE-FREE-POINTER*"
+       "*STATIC-SPACE-FREE-POINTER*" "CURRENT-DYNAMIC-SPACE-START"
+       "DYNAMIC-0-SPACE-START" "DYNAMIC-1-SPACE-START" "FIXNUM" "LONG-FLOAT-P"
+       "READ-ONLY-SPACE-START" "SHORT-FLOAT-P" "STATIC-SPACE-START" "STRING/=*"
+       "STRING<*" "STRING<=*" "STRING=*" "STRING>*" "STRING>=*"))
+  (intern name "LISP"))
+(dolist (name '("%PRIMITIVE" "%STANDARD-CHAR-P" "%STRING-CHAR-P"))
+  (intern name "SYSTEM"))
+(intern "BIGNUM-TYPE" "BIGNUM")
+(dolist
+    (name
+     '("%SP-SET-DEFINITION" "%SP-SET-PLIST" "ARRAY-HEADER-P" "BASE-CHAR-P"
+       "DOUBLE-FLOAT-P" "SIMPLE-ARRAY-P" "SINGLE-FLOAT-P"))
+  (intern name "KERNEL"))
+(defpackage "MIPS"
+            (:import-from "LISP" "%ARRAY-TYPEP" "%ASET" "%BITSET" "%CHARSET"
+             "%PUT" "%RPLACA" "%RPLACD" "%SBITSET" "%SCHARSET"
+             "%SET-DOCUMENTATION" "%SET-FDEFINITION" "%SET-FILL-POINTER"
+             "%SET-ROW-MAJOR-AREF" "%SETELT" "%SETNTH" "%SP-STRING-COMPARE"
+             "%SVSET" "%TYPEP" "*READ-ONLY-SPACE-FREE-POINTER*"
+             "*STATIC-SPACE-FREE-POINTER*" "CURRENT-DYNAMIC-SPACE-START"
+             "DYNAMIC-0-SPACE-START" "DYNAMIC-1-SPACE-START" "FIXNUM"
+             "LONG-FLOAT-P" "READ-ONLY-SPACE-START" "SHORT-FLOAT-P"
+             "STATIC-SPACE-START" "STRING/=*" "STRING<*" "STRING<=*" "STRING=*"
+             "STRING>*" "STRING>=*")
+            (:import-from "SYSTEM" "%PRIMITIVE" "%STANDARD-CHAR-P"
+             "%STRING-CHAR-P")
+            (:import-from "BIGNUM" "BIGNUM-TYPE")
+            (:import-from "KERNEL" "%SP-SET-DEFINITION" "%SP-SET-PLIST"
+             "ARRAY-HEADER-P" "BASE-CHAR-P" "DOUBLE-FLOAT-P" "SIMPLE-ARRAY-P"
+             "SINGLE-FLOAT-P")
+            (:export "*ASSEMBLY-UNIT-LENGTH*" "*PRIMITIVE-OBJECTS*"
+             "ANY-REG-SC-NUMBER" "ARRAY-DATA-SLOT" "ARRAY-DIMENSIONS-OFFSET"
+             "ARRAY-DISPLACED-P-SLOT" "ARRAY-DISPLACEMENT-SLOT"
+             "ARRAY-ELEMENTS-SLOT" "ARRAY-FILL-POINTER-P-SLOT"
+             "ARRAY-FILL-POINTER-SLOT" "ATOMIC-FLAG" "BASE-CHAR-REG-SC-NUMBER"
+             "BASE-CHAR-STACK-SC-NUMBER" "BASE-CHAR-TYPE"
+             "BIGNUM-DIGITS-OFFSET" "BIGNUM-TYPE" "BINDING-SIZE"
+             "BINDING-SYMBOL-SLOT" "BINDING-VALUE-SLOT" "BREAKPOINT-TRAP"
+             "BYTE-BITS" "CATCH-BLOCK-CURRENT-CODE-SLOT"
+             "CATCH-BLOCK-CURRENT-CONT-SLOT" "CATCH-BLOCK-CURRENT-UWP-SLOT"
+             "CATCH-BLOCK-ENTRY-PC-SLOT" "CATCH-BLOCK-PREVIOUS-CATCH-SLOT"
+             "CATCH-BLOCK-SC-NUMBER" "CATCH-BLOCK-SIZE" "CATCH-BLOCK-SIZE-SLOT"
+             "CATCH-BLOCK-TAG-SLOT" "CERROR-TRAP"
+             "CLOSURE-FUNCTION-HEADER-TYPE" "CLOSURE-FUNCTION-SLOT"
+             "CLOSURE-HEADER-TYPE" "CLOSURE-INFO-OFFSET" "CODE-BREAKDOWN"
+             "CODE-CODE-SIZE-SLOT" "CODE-CONSTANTS-OFFSET"
+             "CODE-DEBUG-INFO-SLOT" "CODE-ENTRY-POINTS-SLOT" "CODE-HEADER-TYPE"
+             "CODE-TRACE-TABLE-OFFSET-SLOT" "COMPLEX-ARRAY-TYPE"
+             "COMPLEX-BIT-VECTOR-TYPE" "COMPLEX-IMAG-SLOT" "COMPLEX-REAL-SLOT"
+             "COMPLEX-SIZE" "COMPLEX-STRING-TYPE" "COMPLEX-TYPE"
+             "COMPLEX-VECTOR-TYPE" "CONS-CAR-SLOT" "CONS-CDR-SLOT" "CONS-SIZE"
+             "CONSTANT-SC-NUMBER" "CONTROL-STACK-SC-NUMBER" "COUNT-NO-OPS"
+             "CURRENT-FLOAT-TRAP" "DEFINE-FOR-EACH-PRIMITIVE-OBJECT"
+             "DESCRIPTOR-REG-SC-NUMBER" "DESCRIPTOR-VS-NON-DESCRIPTOR-STORAGE"
+             "DOUBLE-FLAOT-EXPONENT-BYTE" "DOUBLE-FLOAT-BIAS"
+             "DOUBLE-FLOAT-DIGITS" "DOUBLE-FLOAT-EXPONENT-BYTE"
+             "DOUBLE-FLOAT-FILLER-SLOT" "DOUBLE-FLOAT-HIDDEN-BIT"
+             "DOUBLE-FLOAT-NORMAL-EXPONENT-MAX"
+             "DOUBLE-FLOAT-NORMAL-EXPONENT-MIN" "DOUBLE-FLOAT-SIGNIFICAND-BYTE"
+             "DOUBLE-FLOAT-SIZE" "DOUBLE-FLOAT-TRAPPING-NAN-BIT"
+             "DOUBLE-FLOAT-TYPE" "DOUBLE-FLOAT-VALUE-SLOT"
+             "DOUBLE-REG-SC-NUMBER" "DOUBLE-STACK-SC-NUMBER" "ERROR-TRAP"
+             "EVEN-FIXNUM-TYPE" "EXPORTED-STATIC-SYMBOLS" "FIND-HOLES" "FIXNUM"
+             "FIXUP-CODE-OBJECT" "FLOAT-DIVIDE-BY-ZERO-TRAP-BIT"
+             "FLOAT-IMPRECISE-TRAP-BIT" "FLOAT-INVALID-TRAP-BIT"
+             "FLOAT-OVERFLOW-TRAP-BIT" "FLOAT-SIGN-SHIFT"
+             "FLOAT-UNDERFLOW-TRAP-BIT" "FLOATING-POINT-MODES"
+             "FUNCALLABLE-INSTANCE-FUNCTION-SLOT"
+             "FUNCALLABLE-INSTANCE-HEADER-TYPE"
+             "FUNCALLABLE-INSTANCE-INFO-OFFSET" "FUNCTION-END-BREAKPOINT-TRAP"
+             "FUNCTION-HEADER-ARGLIST-SLOT" "FUNCTION-HEADER-CODE-OFFSET"
+             "FUNCTION-HEADER-NAME-SLOT" "FUNCTION-HEADER-NEXT-SLOT"
+             "FUNCTION-HEADER-SELF-SLOT" "FUNCTION-HEADER-TYPE"
+             "FUNCTION-HEADER-TYPE-SLOT" "FUNCTION-POINTER-TYPE" "GENESIS"
+             "HALT-TRAP" "IMMEDIATE-BASE-CHAR-SC-NUMBER"
+             "IMMEDIATE-SAP-SC-NUMBER" "IMMEDIATE-SC-NUMBER"
+             "INTERIOR-REG-SC-NUMBER" "INTERNAL-ERROR-ARGUMENTS"
+             "INTERRUPTED-FLAG" "LIST-POINTER-TYPE" "LOWTAG-BITS"
+             "LOWTAG-LIMIT" "LOWTAG-MASK" "MEMORY-USAGE" "MOST-POSITIVE-COST"
+             "NEGATIVE-IMMEDIATE-SC-NUMBER" "NON-DESCRIPTOR-REG-SC-NUMBER"
+             "NULL-SC-NUMBER" "ODD-FIXNUM-TYPE" "OFFSET-STATIC-SYMBOL"
+             "OTHER-IMMEDIATE-0-TYPE" "OTHER-IMMEDIATE-1-TYPE"
+             "OTHER-POINTER-TYPE" "PAD-DATA-BLOCK" "PENDING-INTERRUPT-TRAP"
+             "PRIMITIVE-OBJECT" "PRIMITIVE-OBJECT-HEADER"
+             "PRIMITIVE-OBJECT-LOWTAG" "PRIMITIVE-OBJECT-NAME"
+             "PRIMITIVE-OBJECT-OPTIONS" "PRIMITIVE-OBJECT-P"
+             "PRIMITIVE-OBJECT-SIZE" "PRIMITIVE-OBJECT-SLOTS"
+             "PRIMITIVE-OBJECT-VARIABLE-LENGTH" "PRINT-ALLOCATED-OBJECTS"
+             "RANDOM-IMMEDIATE-SC-NUMBER" "RATIO-DENOMINATOR-SLOT"
+             "RATIO-NUMERATOR-SLOT" "RATIO-SIZE" "RATIO-TYPE"
+             "REGISTER-SAVE-PENALTY" "RETURN-PC-HEADER-TYPE"
+             "RETURN-PC-RETURN-POINT-OFFSET" "SAP-POINTER-SLOT"
+             "SAP-REG-SC-NUMBER" "SAP-SIZE" "SAP-STACK-SC-NUMBER" "SAP-TYPE"
+             "SIGFPE-HANDLER" "SIGNED-REG-SC-NUMBER" "SIGNED-STACK-SC-NUMBER"
+             "SIMPLE-ARRAY-DOUBLE-FLOAT-TYPE" "SIMPLE-ARRAY-SINGLE-FLOAT-TYPE"
+             "SIMPLE-ARRAY-TYPE" "SIMPLE-ARRAY-UNSIGNED-BYTE-16-TYPE"
+             "SIMPLE-ARRAY-UNSIGNED-BYTE-2-TYPE"
+             "SIMPLE-ARRAY-UNSIGNED-BYTE-32-TYPE"
+             "SIMPLE-ARRAY-UNSIGNED-BYTE-4-TYPE"
+             "SIMPLE-ARRAY-UNSIGNED-BYTE-8-TYPE" "SIMPLE-BIT-VECTOR-TYPE"
+             "SIMPLE-STRING-TYPE" "SIMPLE-VECTOR-TYPE" "SINGLE-FLOAT-BIAS"
+             "SINGLE-FLOAT-DIGITS" "SINGLE-FLOAT-EXPONENT-BYTE"
+             "SINGLE-FLOAT-HIDDEN-BIT" "SINGLE-FLOAT-NORMAL-EXPONENT-MAX"
+             "SINGLE-FLOAT-NORMAL-EXPONENT-MIN" "SINGLE-FLOAT-SIGNIFICAND-BYTE"
+             "SINGLE-FLOAT-SIZE" "SINGLE-FLOAT-TRAPPING-NAN-BIT"
+             "SINGLE-FLOAT-TYPE" "SINGLE-FLOAT-VALUE-SLOT"
+             "SINGLE-REG-SC-NUMBER" "SINGLE-STACK-SC-NUMBER" "SLOT-DOCS"
+             "SLOT-LENGTH" "SLOT-NAME" "SLOT-OFFSET" "SLOT-OPTIONS"
+             "SLOT-REST-P" "STATIC-SYMBOL-OFFSET" "STATIC-SYMBOL-P"
+             "STATIC-SYMBOLS" "STRUCTURE-HEADER-TYPE" "STRUCTURE-POINTER-TYPE"
+             "STRUCTURE-SLOTS-OFFSET" "STRUCTURE-USAGE" "SYMBOL-FUNCTION-SLOT"
+             "SYMBOL-HEADER-TYPE" "SYMBOL-NAME-SLOT" "SYMBOL-PACKAGE-SLOT"
+             "SYMBOL-PLIST-SLOT" "SYMBOL-RAW-FUNCTION-ADDR-SLOT"
+             "SYMBOL-SETF-FUNCTION-SLOT" "SYMBOL-SIZE" "SYMBOL-VALUE-SLOT"
+             "TARGET-BINDING-STACK-START" "TARGET-BYTE-ORDER"
+             "TARGET-CONTROL-STACK-START" "TARGET-DYNAMIC-SPACE-START"
+             "TARGET-FASL-CODE-FORMAT" "TARGET-FASL-FILE-TYPE"
+             "TARGET-HEAP-ADDRESS-SPACE" "TARGET-MOST-NEGATIVE-FIXNUM"
+             "TARGET-MOST-POSITIVE-FIXNUM" "TARGET-READ-ONLY-SPACE-START"
+             "TARGET-STATIC-SPACE-START" "TRACE-TABLE-CALL-SITE"
+             "TRACE-TABLE-FUNCTION-EPILOGUE" "TRACE-TABLE-FUNCTION-PROLOGUE"
+             "TRACE-TABLE-NORMAL" "TYPE-BITS" "TYPE-MASK" "UNBOUND-MARKER-TYPE"
+             "UNINTERNED-SYMBOL-COUNT" "UNSIGNED-IMMEDIATE-SC-NUMBER"
+             "UNSIGNED-REG-SC-NUMBER" "UNSIGNED-STACK-SC-NUMBER"
+             "UNWIND-BLOCK-CURRENT-CODE-SLOT" "UNWIND-BLOCK-CURRENT-CONT-SLOT"
+             "UNWIND-BLOCK-CURRENT-UWP-SLOT" "UNWIND-BLOCK-ENTRY-PC-SLOT"
+             "UNWIND-BLOCK-SIZE" "VALUE-CELL-HEADER-TYPE" "VALUE-CELL-SIZE"
+             "VALUE-CELL-VALUE-SLOT" "VECTOR-DATA-OFFSET" "VECTOR-LENGTH-SLOT"
+             "VECTOR-MUST-REHASH-SUBTYPE" "VECTOR-NORMAL-SUBTYPE"
+             "VECTOR-STRUCTURE-SUBTYPE" "VECTOR-VALID-HASHING-SUBTYPE"
+             "WEAK-POINTER-BROKEN-SLOT" "WEAK-POINTER-NEXT-SLOT"
+             "WEAK-POINTER-SIZE" "WEAK-POINTER-TYPE" "WEAK-POINTER-VALUE-SLOT"
+             "WORD-BITS" "WORD-BYTES" "WORD-SHIFT" "ZERO-SC-NUMBER"))
+(defpackage "CONDITIONS")
+(intern "DISASSEMBLE" "LISP")
+(defpackage "DISASSEM"
+            (:import-from "LISP" "DISASSEMBLE")
+            (:export "*NOTE-COLUMN*" "*OPCODE-COLUMN-WIDTH*" "ADD-COMMENT-HOOK"
+             "ADD-HOOK" "ADD-NOTE-HOOK" "ARG-VALUE" "CREATE-DSTATE"
+             "DISASSEM-STATE" "DISASSEMBLE" "DISASSEMBLE-CODE-COMPONENT"
+             "DISASSEMBLE-FUNCTION" "DISASSEMBLE-MEMORY" "DISASSEMBLE-SEGMENT"
+             "DISASSEMBLE-SEGMENTS" "DSTATE-CODE" "DSTATE-CURPOS"
+             "DSTATE-GET-PROP" "DSTATE-NEXTPOS" "DSTATE-SEGMENT-LENGTH"
+             "DSTATE-SEGMENT-SAP" "DSTATE-SEGMENT-START" "FIELD-TYPE"
+             "FIND-INST" "GEN-FIELD-TYPE-DECL-FORM" "GEN-INST-DECL-FORM"
+             "GEN-INST-FORMAT-DECL-FORM" "GET-CODE-SEGMENTS"
+             "GET-FUNCTION-SEGMENTS" "GET-INST-SPACE" "HANDLE-BREAK-ARGS"
+             "INST" "INST-FORMAT" "LABEL-SEGMENTS"
+             "MAYBE-NOTE-ASSEMBLER-ROUTINE" "MAYBE-NOTE-ASSOCIATED-STORAGE-REF"
+             "MAYBE-NOTE-NIL-INDEXED-OBJECT"
+             "MAYBE-NOTE-NIL-INDEXED-SYMBOL-SLOT-REF"
+             "MAYBE-NOTE-SINGLE-STORAGE-REF" "NOTE" "NOTE-CODE-CONSTANT"
+             "PARAMS" "PRIN1-QUOTED-SHORT" "PRIN1-SHORT" "PRINT-BYTES"
+             "PRINT-CURRENT-ADDRESS" "PRINT-FIELD" "PRINT-INST"
+             "PRINT-INST-USING" "PRINT-NOTES-AND-NEWLINE" "PRINT-WORDS"
+             "SAP-REF-DCHUNK" "SEG-DEBUG-FUNCTION" "SEG-LENGTH" "SEG-START"
+             "SEGMENT" "SET-ADDRESS-PRINTING-RANGE" "SET-DISASSEM-PARAMS"
+             "SET-DSTATE-SEGMENT" "SIGN-EXTEND" "SPECIALIZE"))
+(dolist
+    (name
+     '("*MAX-TRACE-INDENTATION*" "*TRACE-PRINT-LENGTH*" "*TRACE-PRINT-LEVEL*"
+       "*TRACED-FUNCTION-LIST*"))
+  (intern name "EXTENSIONS"))
+(defpackage "DEBUG"
+            (:import-from "EXTENSIONS" "*MAX-TRACE-INDENTATION*"
+             "*TRACE-PRINT-LENGTH*" "*TRACE-PRINT-LEVEL*"
+             "*TRACED-FUNCTION-LIST*")
+            (:export "*AUTO-EVAL-IN-FRAME*" "*DEBUG-PRINT-LENGTH*"
+             "*DEBUG-PRINT-LEVEL*" "*DEBUG-PROMPT*" "*FLUSH-DEBUG-ERRORS*"
+             "*HELP-LINE-SCROLL-COUNT*" "*IN-THE-DEBUGGER*"
+             "*MAX-TRACE-INDENTATION*" "*TRACE-FRAME*" "*TRACE-PRINT-LENGTH*"
+             "*TRACE-PRINT-LEVEL*" "*TRACED-FUNCTION-LIST*" "ARG" "BACKTRACE"
+             "INTERNAL-DEBUG" "VAR"))
+(intern "CHAR" "LISP")
+(defpackage "EXTENSIONS"
+            (:import-from "LISP" "CHAR")
+            (:export "*AFTER-GC-HOOKS*" "*AFTER-SAVE-INITIALIZATIONS*"
+             "*ALL-MODIFIER-NAMES*" "*BACKUP-EXTENSION*" "*BEFORE-GC-HOOKS*"
+             "*BEFORE-SAVE-INITIALIZATIONS*" "*BLOCK-COMPILE-DEFAULT*"
+             "*BYTES-CONSED-BETWEEN-GCS*" "*CHAR" "*CLX-FDS-TO-DISPLAYS*"
+             "*COMMAND-LINE-STRINGS*" "*COMMAND-LINE-SWITCHES*"
+             "*COMMAND-LINE-UTILITY-NAME*" "*COMMAND-LINE-WORDS*"
+             "*COMMAND-SWITCH-DEMONS*" "*COMPATIBILITY-WARNINGS*"
+             "*COMPILE-PROGRESS*" "*DERIVE-FUNCTION-TYPES*"
+             "*DESCRIBE-IMPLEMENTATION-DETAILS*" "*DESCRIBE-INDENTATION*"
+             "*DESCRIBE-LEVEL*" "*DESCRIBE-PRINT-LENGTH*"
+             "*DESCRIBE-PRINT-LEVEL*" "*DESCRIBE-VERBOSE*"
+             "*DISPLAY-EVENT-HANDLERS*" "*EDITOR-LISP-P*"
+             "*EFFICENCY-NOTE-COST-THRESHOLD*" "*EFFICENCY-NOTE-LIMIT*"
+             "*ENCLOSING-SOURCE-CUTOFF*" "*ENVIRONMENT-LIST*"
+             "*ERROR-PRINT-LENGTH*" "*ERROR-PRINT-LEVEL*" "*GC-INHIBIT-HOOK*"
+             "*GC-NOTIFY-AFTER*" "*GC-NOTIFY-BEFORE*" "*GC-VERBOSE*"
+             "*HEMLOCK-VERSION*" "*IGNORE-FLOATING-POINT-UNDERFLOW*"
+             "*INFO-ENVIRONMENT*" "*INTEXP-MAXIMUM-EXPONENENT*"
+             "*KEYWORD-PACKAGE*" "*LISP-PACKAGE*" "*LOAD-IF-SOURCE-NEWER*"
+             "*MAX-OLD-TRACE-INDENTATION*" "*MAX-STEP-INDENTATION*"
+             "*MAX-TRACE-INDENTATION*" "*MODULE-FILE-TRANSLATIONS*"
+             "*OLD-TRACE-PRINT-LENGTH*" "*OLD-TRACE-PRINT-LEVEL*"
+             "*OLD-TRACED-FUNCTION-LIST*" "*PROMPT*" "*REQUIRE-VERBOSE*"
+             "*SAFE-DEFSTRUCT-ACCESSORS*" "*SETF-FDEFINITION-HOOK*"
+             "*STEP-PRINT-LENGTH*" "*STEP-PRINT-LEVEL*" "*TERMINAL-LINE-MODE*"
+             "*TOP-LEVEL-AUTO-DECLARE*" "*TRACE-PRINT-LENGTH*"
+             "*TRACE-PRINT-LEVEL*" "*TRACED-FUNCTION-LIST*"
+             "*UNDEFINED-WARNING-LIMIT*" "ACCEPT-TCP-CONNECTION"
+             "ADD-OOB-HANDLER" "AMBIGUOUS-FILES" "ARGUMENT-LIST" "ASSQ"
+             "BASIC-DEFINITION" "BIGNUMP" "BITP" "CACHE-HASH-EQ"
+             "CALL-USER-MISCOP" "CANCEL-FINALIZATION" "CAREFUL-SYMBOL-FUNCTION"
+             "CAREFULLY-ADD-FONT-PATHS" "CHAR" "CHAR-KEY-EVENT"
+             "CLEAN-UP-COMPILER" "CLEAR-INFO" "CLEAR-SEARCH-LIST"
+             "CLOSE-SOCKET" "CMD-SWITCH-ARG" "CMD-SWITCH-NAME"
+             "CMD-SWITCH-STRING" "CMD-SWITCH-VALUE" "CMD-SWITCH-WORDS"
+             "COLLECT" "COMMAND-LINE-SWITCH" "COMMAND-LINE-SWITCH-P"
+             "COMPACT-INFO-ENVIRONMENT" "COMPILE-FROM-STREAM" "COMPILEDP"
+             "COMPLETE-FILE" "CONCAT-PNAMES" "CONNECT-TO-INET-SOCKET"
+             "CONSTANT" "CONSTANT-ARGUMENT" "CONSTANT-FUNCTION"
+             "CREATE-INET-LISTENER" "CREATE-INET-SOCKET" "DEBUG"
+	     "DEF-SOURCE-CONTEXT"
+             "DEFAULT-CLX-EVENT-HANDLER" "DEFAULT-DIRECTORY"
+             "DEFINE-CLX-MODIFIER" "DEFINE-HASH-CACHE" "DEFINE-INFO-CLASS"
+             "DEFINE-INFO-TYPE" "DEFINE-KEY-EVENT-MODIFIER"
+             "DEFINE-KEYBOARD-MODIFIER" "DEFINE-KEYSYM" "DEFINE-MOUSE-CODE"
+             "DEFINE-MOUSE-KEYSYM" "DEFMODULE" "DEFSWITCH" "DEFUN-CACHED"
+             "DELETEF" "DELQ" "DISABLE-CLX-EVENT-HANDLING"
+             "DO-ALPHA-KEY-EVENTS" "DO-ANONYMOUS" "DO-INFO"
+             "DOUBLE-FLOAT-NEGATIVE-INFINITY" "DOUBLE-FLOAT-POSITIVE-INFINITY"
+             "DOUBLE-FLOATP" "DOVECTOR" "E" "ENABLE-CLX-EVENT-HANDLING"
+             "ENCAPSULATE" "ENCAPSULATED-DEFINITION" "ENCAPSULATED-P"
+             "END-BLOCK" "ENUMERATE-SEARCH-LIST" "FILE-COMMENT" "FILE-WRITABLE"
+             "FINALIZE" "FIXNUMP" "FLOAT-DENORMALIZED-P" "FLOAT-INFINITY-P"
+             "FLOAT-NAN-P" "FLOAT-TRAPPING-NAN-P" "FLOATING-POINT-INEXACT"
+             "FLOATING-POINT-INVALID" "FLUSH-DISPLAY-EVENTS"
+             "FORMAT-DECODED-TIME" "FORMAT-UNIVERSAL-TIME" "FREEZE-TYPE" "GC"
+             "GC-OFF" "GC-ON" "GET-BYTES-CONSED" "GET-CODE-POINTER"
+             "GET-COMMAND-LINE-SWITCH" "GET-DATA-POINTER"
+             "GET-FLOATING-POINT-MODES" "GET-STREAM-COMMAND" "GRINDEF"
+             "HOST-ENTRY" "HOST-ENTRY-ADDR" "HOST-ENTRY-ADDR-LIST"
+             "HOST-ENTRY-ALIASES" "HOST-ENTRY-NAME" "HTONL" "HTONS"
+             "IGNORE-ERRORS" "INADDR-ANY" "INDENTING-FURTHER" "INFO"
+             "INHIBIT-WARNINGS" "INTERACTIVE-EVAL" "IPPROTO-TCP" "IPPROTO-UDP"
+             "ITERATE" "KEY-EVENT" "KEY-EVENT-BIT-P" "KEY-EVENT-BITS"
+             "KEY-EVENT-BITS-MODIFIERS" "KEY-EVENT-CHAR" "KEY-EVENT-KEYSYM"
+             "KEY-EVENT-MODIFIER-MASK" "KEY-EVENT-P" "KEYSYM-NAMES"
+             "KEYSYM-PREFERRED-NAME" "LETF" "LETF*" "LISTEN-SKIP-WHITESPACE"
+             "LOAD-FOREIGN" "LONG-FLOAT-NEGATIVE-INFINITY"
+             "LONG-FLOAT-POSITIVE-INFINITY" "LONG-FLOATP" "LOOKUP-HOST-ENTRY"
+             "MAKE-CASE-FROB-STREAM" "MAKE-INFO-ENVIRONMENT" "MAKE-KEY-EVENT"
+             "MAKE-KEY-EVENT-BITS" "MAKE-STREAM-COMMAND" "MAKE-WEAK-POINTER"
+             "MAYBE-INLINE" "MEMQ" "NAME-KEYSYM" "NTOHL" "NTOHS"
+             "OBJECT-SET-EVENT-HANDLER" "OLD-TRACE" "OLD-UNTRACE" "ONCE-ONLY"
+             "OPEN-CLX-DISPLAY" "OPTIMIZE-INTERFACE" "PARSE-TIME"
+             "PRINT-DIRECTORY" "PRINT-HERALD" "PRINT-PRETTY-KEY"
+             "PRINT-PRETTY-KEY-EVENT" "PROCESS-ALIVE-P" "PROCESS-CLOSE"
+             "PROCESS-CORE-DUMPED" "PROCESS-ERROR" "PROCESS-EXIT-CODE"
+             "PROCESS-INPUT" "PROCESS-KILL" "PROCESS-OUTPUT" "PROCESS-P"
+             "PROCESS-PID" "PROCESS-PLIST" "PROCESS-PTY" "PROCESS-STATUS"
+             "PROCESS-STATUS-HOOK" "PROCESS-WAIT" "PUTF" "QUIT" "RATIOP"
+             "READ-CHAR-NO-EDIT" "REALP" "REMOVE-ALL-OOB-HANDLERS"
+             "REMOVE-OOB-HANDLER" "REQUIRED-ARGUMENT" "RESET-FOREIGN-POINTERS"
+             "RUN-PROGRAM" "SAVE" "SAVE-ALL-BUFFERS" "SAVE-LISP"
+             "SCAVENGER-HOOK" "SCAVENGER-HOOK-P" "SEARCH-LIST"
+             "SEND-CHARACTER-OUT-OF-BAND" "SERVE-BUTTON-PRESS"
+             "SERVE-BUTTON-RELEASE" "SERVE-CIRCULATE-NOTIFY"
+             "SERVE-CIRCULATE-REQUEST" "SERVE-CLIENT-MESSAGE"
+             "SERVE-COLORMAP-NOTIFY" "SERVE-CONFIGURE-NOTIFY"
+             "SERVE-CONFIGURE-REQUEST" "SERVE-CREATE-NOTIFY"
+             "SERVE-DESTROY-NOTIFY" "SERVE-ENTER-NOTIFY" "SERVE-EXPOSURE"
+             "SERVE-FOCUS-IN" "SERVE-FOCUS-OUT" "SERVE-GRAPHICS-EXPOSURE"
+             "SERVE-GRAVITY-NOTIFY" "SERVE-KEY-PRESS" "SERVE-KEY-RELEASE"
+             "SERVE-LEAVE-NOTIFY" "SERVE-MAP-NOTIFY" "SERVE-MAP-REQUEST"
+             "SERVE-MOTION-NOTIFY" "SERVE-NO-EXPOSURE" "SERVE-PROPERTY-NOTIFY"
+             "SERVE-REPARENT-NOTIFY" "SERVE-RESIZE-REQUEST"
+             "SERVE-SELECTION-CLEAR" "SERVE-SELECTION-NOTIFY"
+             "SERVE-SELECTION-REQUEST" "SERVE-UNMAP-NOTIFY"
+             "SERVE-VISIBILITY-NOTIFY" "SET-FLOATING-POINT-MODES"
+             "SET-SYMBOL-FUNCTION-CAREFULLY" "SHORT-FLOAT-NEGATIVE-INFINITY"
+             "SHORT-FLOAT-POSITIVE-INFINITY" "SHORT-FLOATP"
+             "SINGLE-FLOAT-NEGATIVE-INFINITY" "SINGLE-FLOAT-POSITIVE-INFINITY"
+             "SINGLE-FLOATP" "START-BLOCK" "STREAM-COMMAND"
+             "STREAM-COMMAND-ARGS" "STREAM-COMMAND-NAME" "STREAM-COMMAND-P"
+             "STRUCTUREP" "SYMBOLICATE" "TRANSLATE-CHARACTER"
+             "TRANSLATE-KEY-EVENT" "TRANSLATE-MOUSE-CHARACTER"
+             "TRANSLATE-MOUSE-KEY-EVENT" "TRULY-THE" "UNCOMPILE"
+             "UNDEFINED-VALUE" "UNENCAPSULATE" "UNIX-NAMESTRING" "WEAK-POINTER"
+             "WEAK-POINTER-P" "WEAK-POINTER-VALUE" "WITH-CLX-EVENT-HANDLING"))
+(defpackage "LOOP")
+(defpackage "HEMLOCK-INTERNALS"
+            (:export "*BUFFER-LIST*" "*BUFFER-NAMES*"
+             "*CHARACTER-ATTRIBUTE-NAMES*" "*COMMAND-NAMES*"
+             "*CREATE-INITIAL-WINDOWS-HOOK*" "*CREATE-WINDOW-HOOK*"
+             "*DELETE-WINDOW-HOOK*" "*ECHO-AREA-BUFFER*" "*ECHO-AREA-STREAM*"
+             "*ECHO-AREA-WINDOW*" "*EDITOR-INPUT*" "*GLOBAL-VARIABLE-NAMES*"
+             "*INPUT-TRANSCRIPT*" "*INVOKE-HOOK*" "*KEY-EVENT-HISTORY*"
+             "*LAST-KEY-EVENT-TYPED*" "*LOGICAL-KEY-EVENT-NAMES*"
+             "*MODE-NAMES*" "*PARSE-DEFAULT*" "*PARSE-DEFAULT-STRING*"
+             "*PARSE-HELP*" "*PARSE-INPUT-REGION*" "*PARSE-PROMPT*"
+             "*PARSE-STARTING-MARK*" "*PARSE-STRING-TABLES*" "*PARSE-TYPE*"
+             "*PARSE-VALUE-MUST-EXIST*" "*PARSE-VERIFICATION-FUNCTION*"
+             "*PRINT-REGION*" "*RANDOM-TYPEOUT-BUFFERS*"
+             "*RANDOM-TYPEOUT-HOOK*" "*REAL-EDITOR-INPUT*" "*WINDOW-LIST*"
+             "ABORT-RECURSIVE-EDIT" "ADD-HOOK" "AFTER-EDITOR-INITIALIZATIONS"
+             "BIND-KEY" "BLANK-AFTER-P" "BLANK-BEFORE-P" "BLANK-LINE-P"
+             "BUFFER" "BUFFER-DELETE-HOOK" "BUFFER-END" "BUFFER-END-MARK"
+             "BUFFER-MAJOR-MODE" "BUFFER-MINOR-MODE" "BUFFER-MODELINE-FIELD-P"
+             "BUFFER-MODELINE-FIELDS" "BUFFER-MODES" "BUFFER-MODIFIED"
+             "BUFFER-NAME" "BUFFER-PATHNAME" "BUFFER-POINT" "BUFFER-REGION"
+             "BUFFER-SIGNATURE" "BUFFER-START" "BUFFER-START-MARK"
+             "BUFFER-VARIABLES" "BUFFER-WINDOWS" "BUFFER-WRITABLE"
+             "BUFFER-WRITE-DATE" "BUFFERP" "CENTER-WINDOW"
+             "CHARACTER-ATTRIBUTE" "CHARACTER-ATTRIBUTE-DOCUMENTATION"
+             "CHARACTER-ATTRIBUTE-HOOKS" "CHARACTER-ATTRIBUTE-NAME"
+             "CHARACTER-ATTRIBUTE-P" "CHARACTER-OFFSET" "CLEAR-ECHO-AREA"
+             "CLEAR-EDITOR-INPUT" "CLRSTRING" "COMMAND" "COMMAND-BINDINGS"
+             "COMMAND-CASE" "COMMAND-DOCUMENTATION" "COMMAND-FUNCTION"
+             "COMMAND-NAME" "COMMANDP" "COMPLETE-STRING" "COPY-MARK"
+             "COPY-REGION" "COUNT-CHARACTERS" "COUNT-LINES" "CURRENT-BUFFER"
+             "CURRENT-POINT" "CURRENT-VARIABLE-TABLES" "CURRENT-WINDOW"
+             "CURSORPOS-TO-MARK" "DEFATTRIBUTE" "DEFAULT-FONT" "DEFCOMMAND"
+             "DEFHVAR" "DEFINE-LOGICAL-KEY-EVENT" "DEFINE-TTY-FONT" "DEFMODE"
+             "DELETE-AND-SAVE-REGION" "DELETE-BUFFER" "DELETE-CHARACTERS"
+             "DELETE-FONT-MARK" "DELETE-KEY-BINDING" "DELETE-LINE-FONT-MARKS"
+             "DELETE-MARK" "DELETE-REGION" "DELETE-STRING" "DELETE-VARIABLE"
+             "DELETE-WINDOW" "DIRECTORYP" "DISPLAYED-P" "DO-ALPHA-CHARS"
+             "DO-STRINGS" "EDITOR-DESCRIBE-FUNCTION" "EDITOR-ERROR"
+             "EDITOR-ERROR-FORMAT-ARGUMENTS" "EDITOR-ERROR-FORMAT-STRING"
+             "EDITOR-FINISH-OUTPUT" "EDITOR-SLEEP" "EMPTY-LINE-P" "END-LINE-P"
+             "ENTER-WINDOW-AUTORAISE" "EXIT-HEMLOCK" "EXIT-RECURSIVE-EDIT"
+             "FETCH-CUT-STRING" "FILTER-REGION" "FIND-AMBIGUOUS"
+             "FIND-ATTRIBUTE" "FIND-CONTAINING" "FIND-PATTERN" "FIRST-LINE-P"
+             "FONT-MARK" "FUN-DEFINED-FROM-PATHNAME" "GET-COMMAND"
+             "GET-KEY-EVENT" "GETSTRING" "HANDLE-LISP-ERRORS" "HEMLOCK-BOUND-P"
+             "HEMLOCK-OUTPUT-STREAM" "HEMLOCK-OUTPUT-STREAM-P"
+             "HEMLOCK-REGION-STREAM" "HEMLOCK-REGION-STREAM-P" "HLET"
+             "IN-RECURSIVE-EDIT" "INPUT-WAITING" "INSERT-CHARACTER"
+             "INSERT-REGION" "INSERT-STRING" "INVOKE-HOOK" "KEY-TRANSLATION"
+             "LAST-COMMAND-TYPE" "LAST-KEY-EVENT-CURSORPOS" "LAST-LINE-P"
+             "LINE" "LINE-BUFFER" "LINE-CHARACTER" "LINE-END" "LINE-LENGTH"
+             "LINE-NEXT" "LINE-OFFSET" "LINE-PLIST" "LINE-PREVIOUS"
+             "LINE-SIGNATURE" "LINE-START" "LINE-STRING" "LINE-TO-REGION"
+             "LINE<" "LINE<=" "LINE>" "LINE>=" "LINEP" "LINES-RELATED"
+             "LISTEN-EDITOR-INPUT" "LOGICAL-KEY-EVENT-DOCUMENTATION"
+             "LOGICAL-KEY-EVENT-KEY-EVENTS" "LOGICAL-KEY-EVENT-NAME"
+             "LOGICAL-KEY-EVENT-P" "LOUD-MESSAGE" "MAKE-BUFFER" "MAKE-COMMAND"
+             "MAKE-EMPTY-REGION" "MAKE-HEMLOCK-OUTPUT-STREAM"
+             "MAKE-HEMLOCK-REGION-STREAM" "MAKE-KBDMAC-STREAM"
+             "MAKE-MODELINE-FIELD" "MAKE-RING" "MAKE-STRING-TABLE"
+             "MAKE-WINDOW" "MAKE-XWINDOW-LIKE-HWINDOW" "MAP-BINDINGS" "MARK"
+             "MARK-AFTER" "MARK-BEFORE" "MARK-CHARPOS" "MARK-COLUMN"
+             "MARK-KIND" "MARK-LINE" "MARK-TO-CURSORPOS" "MARK/=" "MARK<"
+             "MARK<=" "MARK=" "MARK>" "MARK>=" "MARKP"
+             "MERGE-RELATIVE-PATHNAMES" "MESSAGE" "MODE-DOCUMENTATION"
+             "MODE-MAJOR-P" "MODE-VARIABLES" "MODELINE-FIELD"
+             "MODELINE-FIELD-FUNCTION" "MODELINE-FIELD-NAME" "MODELINE-FIELD-P"
+             "MODELINE-FIELD-WIDTH" "MODIFY-KBDMAC-STREAM" "MOVE-FONT-MARK"
+             "MOVE-MARK" "MOVE-TO-COLUMN" "MOVE-TO-POSITION"
+             "NEW-SEARCH-PATTERN" "NEXT-CHARACTER" "NEXT-WINDOW"
+             "NINSERT-REGION" "PAUSE-HEMLOCK" "PREFIX-ARGUMENT"
+             "PREVIOUS-CHARACTER" "PREVIOUS-WINDOW" "PROMPT-FOR-BUFFER"
+             "PROMPT-FOR-EXPRESSION" "PROMPT-FOR-FILE" "PROMPT-FOR-INTEGER"
+             "PROMPT-FOR-KEY" "PROMPT-FOR-KEY-EVENT" "PROMPT-FOR-KEYWORD"
+             "PROMPT-FOR-STRING" "PROMPT-FOR-VARIABLE" "PROMPT-FOR-Y-OR-N"
+             "PROMPT-FOR-YES-OR-NO" "READ-FILE" "RECURSIVE-EDIT" "REDISPLAY"
+             "REDISPLAY-ALL" "REGION" "REGION-BOUNDS" "REGION-END"
+             "REGION-START" "REGION-TO-STRING" "REGIONP" "REMOVE-HOOK"
+             "REMOVE-SCHEDULED-EVENT" "REPLACE-PATTERN" "REPROMPT"
+             "REVERSE-FIND-ATTRIBUTE" "RING" "RING-LENGTH" "RING-POP"
+             "RING-PUSH" "RING-REF" "RINGP" "ROTATE-RING" "SAME-LINE-P"
+             "SCHEDULE-EVENT" "SCROLL-WINDOW" "SEARCH-CHAR-CODE-LIMIT"
+             "SEARCH-PATTERN" "SEARCH-PATTERN-P" "SET-REGION-BOUNDS" "SETV"
+             "SHADOW-ATTRIBUTE" "SHOW-MARK" "START-LINE-P" "STORE-CUT-STRING"
+             "STRING-TABLE" "STRING-TABLE-P" "STRING-TABLE-SEPARATOR"
+             "STRING-TO-REGION" "STRING-TO-VARIABLE" "SYNTAX-CHAR-CODE-LIMIT"
+             "UNGET-KEY-EVENT" "UNSHADOW-ATTRIBUTE" "UPDATE-MODELINE-FIELD"
+             "UPDATE-MODELINE-FIELDS" "USE-BUFFER" "VALUE"
+             "VARIABLE-DOCUMENTATION" "VARIABLE-HOOKS" "VARIABLE-NAME"
+             "VARIABLE-VALUE" "WINDOW" "WINDOW-BUFFER" "WINDOW-DISPLAY-END"
+             "WINDOW-DISPLAY-RECENTERING" "WINDOW-DISPLAY-START" "WINDOW-FONT"
+             "WINDOW-HEIGHT" "WINDOW-POINT" "WINDOW-WIDTH" "WINDOWP"
+             "WITH-INPUT-FROM-REGION" "WITH-MARK" "WITH-OUTPUT-TO-MARK"
+             "WITH-POP-UP-DISPLAY" "WITH-WRITABLE-BUFFER" "WRITE-FILE"))
+(dolist
+    (name
+     '("DEBUG-SOURCE" "DEBUG-SOURCE-COMPILED" "DEBUG-SOURCE-CREATED"
+       "DEBUG-SOURCE-FROM" "DEBUG-SOURCE-NAME" "DEBUG-SOURCE-P"
+       "DEBUG-SOURCE-START-POSITIONS"))
+  (intern name "C"))
+(defpackage "DEBUG-INTERNALS"
+            (:import-from "C" "DEBUG-SOURCE" "DEBUG-SOURCE-COMPILED"
+             "DEBUG-SOURCE-CREATED" "DEBUG-SOURCE-FROM" "DEBUG-SOURCE-NAME"
+             "DEBUG-SOURCE-P" "DEBUG-SOURCE-START-POSITIONS")
+            (:export "*DEBUGGING-INTERPRETER*" "ACTIVATE-BREAKPOINT"
+             "AMBIGUOUS-DEBUG-VARIABLES" "AMBIGUOUS-VARIABLE-NAME" "BREAKPOINT"
+             "BREAKPOINT-ACTIVE-P" "BREAKPOINT-HOOK-FUNCTION" "BREAKPOINT-INFO"
+             "BREAKPOINT-KIND" "BREAKPOINT-P" "BREAKPOINT-WHAT" "CODE-LOCATION"
+             "CODE-LOCATION-DEBUG-BLOCK" "CODE-LOCATION-DEBUG-FUNCTION"
+             "CODE-LOCATION-DEBUG-SOURCE" "CODE-LOCATION-FORM-NUMBER"
+             "CODE-LOCATION-P" "CODE-LOCATION-TOP-LEVEL-FORM-OFFSET"
+             "CODE-LOCATION-UNKNOWN-P" "CODE-LOCATION=" "DEACTIVATE-BREAKPOINT"
+             "DEBUG-BLOCK" "DEBUG-BLOCK-ELSEWHERE-P" "DEBUG-BLOCK-P"
+             "DEBUG-BLOCK-SUCCESSORS" "DEBUG-CONDITION" "DEBUG-ERROR"
+             "DEBUG-FUNCTION" "DEBUG-FUNCTION-FUNCTION" "DEBUG-FUNCTION-KIND"
+             "DEBUG-FUNCTION-LAMBDA-LIST" "DEBUG-FUNCTION-NAME"
+             "DEBUG-FUNCTION-P" "DEBUG-FUNCTION-START-LOCATION"
+             "DEBUG-FUNCTION-SYMBOL-VARIABLES" "DEBUG-SOURCE"
+             "DEBUG-SOURCE-COMPILED" "DEBUG-SOURCE-CREATED" "DEBUG-SOURCE-FROM"
+             "DEBUG-SOURCE-NAME" "DEBUG-SOURCE-P" "DEBUG-SOURCE-ROOT-NUMBER"
+             "DEBUG-SOURCE-START-POSITIONS" "DEBUG-VARIABLE"
+             "DEBUG-VARIABLE-ID" "DEBUG-VARIABLE-INFO-AVAILABLE"
+             "DEBUG-VARIABLE-NAME" "DEBUG-VARIABLE-P" "DEBUG-VARIABLE-PACKAGE"
+             "DEBUG-VARIABLE-SYMBOL" "DEBUG-VARIABLE-VALID-VALUE"
+             "DEBUG-VARIABLE-VALIDITY" "DEBUG-VARIABLE-VALUE"
+             "DELETE-BREAKPOINT" "DELETE-BREAKPOINT-FOR-EDITOR" "DO-BLOCKS"
+             "DO-DEBUG-BLOCK-LOCATIONS" "DO-DEBUG-FUNCTION-BLOCKS"
+             "DO-DEBUG-FUNCTION-VARIABLES" "EVAL-IN-FRAME"
+             "FORM-NUMBER-TRANSLATIONS" "FRAME" "FRAME-CATCHES"
+             "FRAME-CODE-LOCATION" "FRAME-DEBUG-FUNCTION" "FRAME-DOWN"
+             "FRAME-FUNCTION-MISMATCH" "FRAME-NUMBER" "FRAME-P" "FRAME-UP"
+             "FUNCTION-DEBUG-FUNCTION" "FUNCTION-END-COOKIE-VALID-P"
+             "INVALID-CONTROL-STACK-POINTER" "INVALID-VALUE"
+             "LAMBDA-LIST-UNAVAILABLE" "MAKE-BREAKPOINT" "NO-DEBUG-BLOCKS"
+             "NO-DEBUG-FUNCTION-RETURNS" "NO-DEBUG-INFO" "PREPROCESS-FOR-EVAL"
+             "RETURN-FROM-FRAME" "SET-BREAKPOINT-FOR-EDITOR"
+             "SET-LOCATION-BREAKPOINT-FOR-EDITOR" "SOURCE-PATH-CONTEXT"
+             "TOP-FRAME" "UNHANDLED-CONDITION" "UNKNOWN-CODE-LOCATION"
+             "UNKNOWN-CODE-LOCATION-P" "UNKNOWN-DEBUG-VARIABLE"))
+(dolist
+    (name
+     '("%ALIGNED-SAP" "%ARRAY-TYPEP" "%ASET" "%BITSET" "%CHARSET" "%PUT"
+       "%RPLACA" "%RPLACD" "%SBITSET" "%SCHARSET" "%SET-DOCUMENTATION"
+       "%SET-FDEFINITION" "%SET-FILL-POINTER" "%SET-ROW-MAJOR-AREF"
+       "%SET-SAP-REF-DESCRIPTOR" "%SETELT" "%SETNTH" "%SP-STRING-COMPARE"
+       "%SVSET" "%TYPEP" "LONG-FLOAT-P" "NIL" "RETURN" "SET" "SHORT-FLOAT-P"
+       "STRING/=*" "STRING<*" "STRING<=*" "STRING=*" "STRING>*" "STRING>=*"
+       "SYMBOL-FUNCTION" "SYMBOL-VALUE" "THROW" "VALUES-LIST"))
+  (intern name "LISP"))
+(intern "BOOLEAN" "ALIEN")
+(dolist
+    (name
+     '("%PRIMITIVE" "%STANDARD-CHAR-P" "%STRING-CHAR-P" "BITS" "BYTES"
+       "C-PROCEDURE" "CHECK<=" "CHECK=" "CT-A-VAL" "CT-A-VAL-OFFSET"
+       "CT-A-VAL-P" "CT-A-VAL-SAP" "CT-A-VAL-SIZE" "CT-A-VAL-TYPE"
+       "DEFENUMERATION" "DEFOPERATOR" "DEPORT-BOOLEAN" "DEPORT-INTEGER"
+       "ENUMERATION" "FOREIGN-SYMBOL-ADDRESS" "LONG-WORDS" "MAKE-CT-A-VAL"
+       "NATURALIZE-BOOLEAN" "NATURALIZE-INTEGER" "NULL-TERMINATED-STRING"
+       "PERQ-STRING" "POINTER" "PORT" "RECORD-SIZE" "SAP+" "SAP-REF-16"
+       "SAP-REF-32" "SAP-REF-8" "SAP-REF-SAP" "SIGNED-SAP-REF-16"
+       "SIGNED-SAP-REF-32" "SIGNED-SAP-REF-8" "SYSTEM-AREA-POINTER" "WORDS"))
+  (intern name "SYSTEM"))
+(intern "SYMBOLICATE" "EXTENSIONS")
+(dolist
+    (name
+     '("%RAW-BITS" "%SET-SAP-REF-16" "%SET-SAP-REF-32" "%SET-SAP-REF-8"
+       "%SET-SAP-REF-DOUBLE" "%SET-SAP-REF-SAP" "%SET-SAP-REF-SINGLE"
+       "%SP-SET-DEFINITION" "%SP-SET-PLIST" "ARRAY-HEADER-P" "BASE-CHAR-P"
+       "CODE-INSTRUCTIONS" "DOUBLE-FLOAT-P" "ODD-KEYWORD-ARGUMENTS-ERROR"
+       "SIMPLE-ARRAY-P" "SINGLE-FLOAT-P" "STRUCTURE-REF" "STRUCTURE-SET"
+       "UNKNOWN-KEYWORD-ARGUMENT-ERROR"))
+  (intern name "KERNEL"))
+(defpackage "C"
+            (:import-from "LISP" "%ALIGNED-SAP" "%ARRAY-TYPEP" "%ASET"
+             "%BITSET" "%CHARSET" "%PUT" "%RPLACA" "%RPLACD" "%SBITSET"
+             "%SCHARSET" "%SET-DOCUMENTATION" "%SET-FDEFINITION"
+             "%SET-FILL-POINTER" "%SET-ROW-MAJOR-AREF"
+             "%SET-SAP-REF-DESCRIPTOR" "%SETELT" "%SETNTH" "%SP-STRING-COMPARE"
+             "%SVSET" "%TYPEP" "LONG-FLOAT-P" "NIL" "RETURN" "SET"
+             "SHORT-FLOAT-P" "STRING/=*" "STRING<*" "STRING<=*" "STRING=*"
+             "STRING>*" "STRING>=*" "SYMBOL-FUNCTION" "SYMBOL-VALUE" "THROW"
+             "VALUES-LIST")
+            (:import-from "ALIEN" "BOOLEAN")
+            (:import-from "SYSTEM" "%PRIMITIVE" "%STANDARD-CHAR-P"
+             "%STRING-CHAR-P" "BITS" "BYTES" "C-PROCEDURE" "CHECK<=" "CHECK="
+             "CT-A-VAL" "CT-A-VAL-OFFSET" "CT-A-VAL-P" "CT-A-VAL-SAP"
+             "CT-A-VAL-SIZE" "CT-A-VAL-TYPE" "DEFENUMERATION" "DEFOPERATOR"
+             "DEPORT-BOOLEAN" "DEPORT-INTEGER" "ENUMERATION"
+             "FOREIGN-SYMBOL-ADDRESS" "LONG-WORDS" "MAKE-CT-A-VAL"
+             "NATURALIZE-BOOLEAN" "NATURALIZE-INTEGER" "NULL-TERMINATED-STRING"
+             "PERQ-STRING" "POINTER" "PORT" "RECORD-SIZE" "SAP+" "SAP-REF-16"
+             "SAP-REF-32" "SAP-REF-8" "SAP-REF-SAP" "SIGNED-SAP-REF-16"
+             "SIGNED-SAP-REF-32" "SIGNED-SAP-REF-8" "SYSTEM-AREA-POINTER"
+             "WORDS")
+            (:import-from "EXTENSIONS" "SYMBOLICATE")
+            (:import-from "KERNEL" "%RAW-BITS" "%SET-SAP-REF-16"
+             "%SET-SAP-REF-32" "%SET-SAP-REF-8" "%SET-SAP-REF-DOUBLE"
+             "%SET-SAP-REF-SAP" "%SET-SAP-REF-SINGLE" "%SP-SET-DEFINITION"
+             "%SP-SET-PLIST" "ARRAY-HEADER-P" "BASE-CHAR-P" "CODE-INSTRUCTIONS"
+             "DOUBLE-FLOAT-P" "ODD-KEYWORD-ARGUMENTS-ERROR" "SIMPLE-ARRAY-P"
+             "SINGLE-FLOAT-P" "STRUCTURE-REF" "STRUCTURE-SET"
+             "UNKNOWN-KEYWORD-ARGUMENT-ERROR")
+            (:export "%ALIEN-FUNCALL" "%CATCH-BREAKUP" "%CONTINUE-UNWIND"
+             "%LISTIFY-REST-ARGS" "%MORE-ARG" "%UNWIND-PROTECT-BREAKUP"
+             "*BACKEND*" "*CODE-SEGMENT*" "*COLLECT-DYNAMIC-STATISTICS*"
+             "*COMPILE-TIME-DEFINE-MACROS*" "*COMPILER-NOTIFICATION-FUNCTION*"
+             "*COMPILING-FOR-INTERPRETER*" "*CONVERTING-FOR-INTERPRETER*"
+             "*COUNT-VOP-USAGES*" "*ELSEWHERE*" "*NATIVE-BACKEND*"
+             "*SUPPRESS-VALUES-DECLARATION*" "*TARGET-BACKEND*"
+             "ALLOC-NUMBER-STACK-SPACE" "ALLOCATE-CODE-OBJECT" "ALLOCATE-FRAME"
+             "ALLOCATE-FULL-CALL-FRAME" "ANY" "ARGUMENT-COUNT-ERROR"
+             "ATTRIBUTES" "ATTRIBUTES-INTERSECTION" "ATTRIBUTES-UNION"
+             "ATTRIBUTES=" "BACKEND-ANY-PRIMITIVE-TYPE"
+             "BACKEND-ASSEMBLER-RESOURCES" "BACKEND-BYTE-ORDER"
+             "BACKEND-DISASSEM-PARAMS" "BACKEND-FASL-FILE-IMPLEMENTATION"
+             "BACKEND-FASL-FILE-TYPE" "BACKEND-FASL-FILE-VERSION"
+             "BACKEND-FEATURES" "BACKEND-INFO-ENVIRONMENT"
+             "BACKEND-INSTRUCTION-FLAVORS" "BACKEND-INSTRUCTION-FORMATS"
+             "BACKEND-NAME" "BACKEND-REGISTER-SAVE-PENALTY"
+             "BACKEND-SPECIAL-ARG-TYPES" "BACKEND-VERSION" "BIND" "BRANCH"
+             "CALL" "CALL-LOCAL" "CALL-NAMED" "CALL-OUT" "CALL-VARIABLE"
+             "CALLEE-NFP-TN" "CALLEE-RETURN-PC-TN" "CATCH-BLOCK" "CHECK-CONS"
+             "CHECK-FIXNUM" "CHECK-FUNCTION" "CHECK-FUNCTION-OR-SYMBOL"
+             "CHECK-SIGNED-BYTE-32" "CHECK-SYMBOL" "CHECK-UNSIGNED-BYTE-32"
+             "CLOSURE-INIT" "CLOSURE-REF" "CODE-CONSTANT-REF"
+             "CODE-CONSTANT-SET" "CODE-INSTRUCTIONS" "COERCE-TO-FUNCTION"
+             "COMPILE-FOR-EVAL" "COMPONENT" "COMPONENT-HEADER-LENGTH"
+             "COMPONENT-INFO" "COMPONENT-LIVE-TN" "COMPUTE-FUNCTION"
+             "COMPUTE-OLD-NFP" "COPY-MORE-ARG" "COUNT-ME"
+             "CURRENT-BINDING-POINTER" "CURRENT-NFP-TN" "CURRENT-STACK-POINTER"
+             "DEALLOC-NUMBER-STACK-SPACE" "DEF-BOOLEAN-ATTRIBUTE"
+             "DEF-IR1-TRANSLATOR" "DEF-PRIMITIVE-TRANSLATOR"
+             "DEF-PRIMITIVE-TYPE" "DEF-PRIMITIVE-TYPE-ALIAS"
+             "DEF-SOURCE-TRANSFORM" "DEF-VM-SUPPORT-ROUTINE"
+             "DEFINE-ASSEMBLY-ROUTINE" "DEFINE-MOVE-FUNCTION" "DEFINE-MOVE-VOP"
+             "DEFINE-STORAGE-BASE" "DEFINE-STORAGE-CLASS" "DEFINE-VOP"
+             "DEFKNOWN" "DEFOPTIMIZER" "DEFTRANSFORM" "DERIVE-TYPE"
+             "ENTRY-NODE-INFO-NLX-TAG" "ENTRY-NODE-INFO-ST-TOP"
+             "ENVIRONMENT-DEBUG-LIVE-TN" "ENVIRONMENT-LIVE-TN"
+             "FASL-FILE-IMPLEMENTATIONS" "FAST-SAFE-COERCE-TO-FUNCTION"
+             "FAST-SYMBOL-FUNCTION" "FAST-SYMBOL-VALUE" "FLUSHABLE" "FOLDABLE"
+             "FORCE-TN-TO-STACK" "FOREIGN-SYMBOL-ADDRESS" "GET-VECTOR-SUBTYPE"
+             "HALT" "IF-EQ" "IR2-COMPONENT-CONSTANTS" "IR2-CONVERT"
+             "IR2-ENVIRONMENT-NUMBER-STACK-P" "KNOWN-CALL-LOCAL" "KNOWN-RETURN"
+             "LAMBDA-EVAL-INFO-ARGS-PASSED" "LAMBDA-EVAL-INFO-ENTRIES"
+             "LAMBDA-EVAL-INFO-FRAME-SIZE" "LAMBDA-EVAL-INFO-FUNCTION"
+             "LOCATION=" "LTN-ANNOTATE" "MAKE-ALIAS-TN" "MAKE-CATCH-BLOCK"
+             "MAKE-CLOSURE" "MAKE-CONSTANT-TN" "MAKE-FIXNUM"
+             "MAKE-LOAD-TIME-CONSTANT-TN" "MAKE-N-TNS" "MAKE-NORMAL-TN"
+             "MAKE-OTHER-IMMEDIATE-TYPE" "MAKE-RANDOM-TN"
+             "MAKE-REPRESENTATION-TN" "MAKE-RESTRICTED-TN" "MAKE-SC-OFFSET"
+             "MAKE-STACK-POINTER-TN" "MAKE-TN-REF" "MAKE-UNWIND-BLOCK"
+             "MAKE-VALUE-CELL" "MAKE-WIRED-TN" "META-PRIMITIVE-TYPE-OR-LOSE"
+             "META-SB-OR-LOSE" "META-SC-NUMBER-OR-LOSE" "META-SC-OR-LOSE"
+             "MORE-ARG-CONTEXT" "MOVABLE" "MOVE" "MULTIPLE-CALL"
+             "MULTIPLE-CALL-LOCAL" "MULTIPLE-CALL-NAMED"
+             "MULTIPLE-CALL-VARIABLE" "NIL" "NLX-ENTRY" "NLX-ENTRY-MULTIPLE"
+             "NON-DESCRIPTOR-STACK" "NOTE-ENVIRONMENT-START"
+             "NOTE-THIS-LOCATION" "ODD-KEYWORD-ARGUMENTS-ERROR" "OPTIMIZER"
+             "PACK-TRACE-TABLE" "PMAX-FASL-FILE-IMPLEMENTATION" "POLICY"
+             "PREDICATE" "PRIMITIVE-TYPE" "PRIMITIVE-TYPE-OF"
+             "PRIMITIVE-TYPE-OR-LOSE" "PRIMITIVE-TYPE-VOP" "PUSH-VALUES"
+             "READ-PACKED-BIT-VECTOR" "READ-VAR-INTEGER" "READ-VAR-STRING"
+             "RESET-STACK-POINTER" "RESTORE-DYNAMIC-STATE" "RETURN"
+             "RETURN-MULTIPLE" "RT-AFPA-FASL-FILE-IMPLEMENTATION"
+             "RT-FASL-FILE-IMPLEMENTATION" "SAVE-DYNAMIC-STATE" "SB"
+             "SB-ALLOCATED-SIZE" "SB-NAME" "SB-OR-LOSE" "SB-P" "SC" "SC-CASE"
+             "SC-IS" "SC-NAME" "SC-NUMBER" "SC-NUMBER-OR-LOSE"
+             "SC-OFFSET-OFFSET" "SC-OFFSET-SCN" "SC-OR-LOSE" "SC-P" "SC-SB"
+             "SET" "SET-UNWIND-PROTECT" "SET-VECTOR-SUBTYPE"
+             "SETUP-CLOSURE-ENVIRONMENT" "SETUP-ENVIRONMENT"
+             "SPARC-FASL-FILE-IMPLEMENTATION" "SPECIFY-SAVE-TN" "STRUCTURE-REF"
+             "STRUCTURE-SET" "SXHASH-SIMPLE-STRING" "SXHASH-SIMPLE-SUBSTRING"
+             "SYMBOL-FUNCTION" "SYMBOL-VALUE" "SYMBOLICATE" "TAIL-CALL"
+             "TAIL-CALL-NAMED" "TAIL-CALL-VARIABLE" "TEMPLATE-OR-LOSE" "THROW"
+             "TN" "TN-OFFSET" "TN-P" "TN-REF" "TN-REF-ACROSS" "TN-REF-LOAD-TN"
+             "TN-REF-NEXT" "TN-REF-NEXT-REF" "TN-REF-P" "TN-REF-TARGET"
+             "TN-REF-TN" "TN-REF-VOP" "TN-REF-WRITE-P" "TN-SC" "TN-VALUE"
+             "TRACE-TABLE-ENTRY" "TYPE-CHECK-ERROR" "UNBIND" "UNBIND-TO-HERE"
+             "UNKNOWN-KEYWORD-ARGUMENT-ERROR" "UNSAFE" "UNWIND" "UWP-ENTRY"
+             "VALUE-CELL-REF" "VALUE-CELL-SET" "VALUES-LIST"
+             "VERIFY-ARGUMENT-COUNT" "WRITE-PACKED-BIT-VECTOR"
+             "WRITE-VAR-INTEGER" "WRITE-VAR-STRING" "XEP-ALLOCATE-FRAME"))
+(defpackage "DIRED"
+            (:export "*CLOBBER-DEFAULT*" "*ERROR-FUNCTION*"
+             "*RECURSIVE-DEFAULT*" "*REPORT-FUNCTION*" "*UPDATE-DEFAULT*"
+             "*YESP-FUNCTION*" "COPY-FILE" "DELETE-FILE" "FIND-FILE"
+             "MAKE-DIRECTORY" "PATHNAMES-FROM-PATTERN" "RENAME-FILE"))
+(defpackage "WIRE"
+            (:export "*CURRENT-WIRE*" "CONNECT-TO-REMOTE-SERVER"
+             "CREATE-REQUEST-SERVER" "DESTROY-REQUEST-SERVER"
+             "FORGET-REMOTE-TRANSLATION" "MAKE-REMOTE-OBJECT" "MAKE-WIRE"
+             "REMOTE" "REMOTE-OBJECT" "REMOTE-OBJECT-EQ"
+             "REMOTE-OBJECT-LOCAL-P" "REMOTE-OBJECT-P" "REMOTE-OBJECT-VALUE"
+             "REMOTE-VALUE" "REMOTE-VALUE-BIND" "WIRE-EOF" "WIRE-ERROR"
+             "WIRE-FD" "WIRE-FORCE-OUTPUT" "WIRE-GET-BIGNUM" "WIRE-GET-BYTE"
+             "WIRE-GET-NUMBER" "WIRE-GET-OBJECT" "WIRE-GET-STRING"
+             "WIRE-IO-ERROR" "WIRE-LISTEN" "WIRE-OUTPUT-BIGNUM"
+             "WIRE-OUTPUT-BYTE" "WIRE-OUTPUT-FUNCALL" "WIRE-OUTPUT-NUMBER"
+             "WIRE-OUTPUT-OBJECT" "WIRE-OUTPUT-STRING" "WIRE-P"))
+(defpackage "PRETTY-PRINT" (:export "PRETTY-STREAM" "PRETTY-STREAM-P"))
+(intern "LOAD-FOREIGN" "EXTENSIONS")
+(defpackage "SYSTEM"
+            (:import-from "EXTENSIONS" "LOAD-FOREIGN")
+            (:export "%ASSEMBLER-CODE-TYPE" "%BIND-ALIGNED-SAP" "%PRIMITIVE"
+             "%SP-BYTE-BLT" "%SP-FIND-CHARACTER"
+             "%SP-FIND-CHARACTER-WITH-ATTRIBUTE"
+             "%SP-REVERSE-FIND-CHARACTER-WITH-ATTRIBUTE" "%STANDARD-CHAR-P"
+             "%STRING-CHAR-P" "*BEEP-FUNCTION*" "*GR-MESSAGES*"
+             "*IN-THE-COMPILER*" "*LONG-SITE-NAME*"
+             "*MAXIMUM-INTERPRETER-ERROR-CHECKING*" "*NAMESERVERPORT*"
+             "*PORNOGRAPHY-OF-DEATH*" "*PORT-OWNERSHIP-RIGHTS-HANDLERS*"
+             "*PORT-RECEIVE-RIGHTS-HANDLERS*" "*SHORT-SITE-NAME*"
+             "*SOFTWARE-TYPE*" "*STDERR*" "*STDIN*" "*STDOUT*" "*TASK-DATA*"
+             "*TASK-NOTIFY*" "*TASK-SELF*" "*TTY*" "*TYPESCRIPTPORT*"
+             "*USERTYPESCRIPT*" "*USERWINDOW*" "*XWINDOW-TABLE*"
+             "ADD-FD-HANDLER" "ADD-PORT-DEATH-HANDLER" "ADD-PORT-OBJECT"
+             "ADD-XWINDOW-OBJECT" "ALLOCATE-SYSTEM-MEMORY" "BEEP" "BITS"
+             "BYTES" "C-PROCEDURE" "CHECK<=" "CHECK=" "COMPILER-VERSION"
+             "CT-A-VAL" "CT-A-VAL-OFFSET" "CT-A-VAL-P" "CT-A-VAL-SAP"
+             "CT-A-VAL-SIZE" "CT-A-VAL-TYPE" "DEALLOCATE-SYSTEM-MEMORY"
+             "DEFAULT-INTERRUPT" "DEFENUMERATION" "DEFOPERATOR" "DEFRECORD"
+             "DEPORT-BOOLEAN" "DEPORT-INTEGER" "DOUBLE-FLOAT-RADIX"
+             "ENABLE-INTERRUPT" "ENUMERATION" "FD-STREAM" "FD-STREAM-FD"
+             "FD-STREAM-P" "FEXPR" "FIND-IF-IN-CLOSURE"
+             "FOREIGN-SYMBOL-ADDRESS" "GET-PAGE-SIZE" "GET-SYSTEM-INFO"
+             "GR-BIND" "GR-CALL" "GR-CALL*" "GR-ERROR" "IGNORE-INTERRUPT"
+             "INT-SAP" "INVALIDATE-DESCRIPTOR" "IO-TIMEOUT" "LONG-FLOAT-RADIX"
+             "LONG-WORDS" "MACRO" "MAKE-CT-A-VAL" "MAKE-FD-STREAM"
+             "MAKE-INDENTING-STREAM" "MAKE-OBJECT-SET" "MAP-PORT" "MAP-XWINDOW"
+             "NATURALIZE-BOOLEAN" "NATURALIZE-INTEGER" "NULL-TERMINATED-STRING"
+             "OBJECT-SET-OPERATION" "OUTPUT-RAW-BYTES" "PARSE-BODY"
+             "PERQ-STRING" "POINTER" "POINTER<" "POINTER>" "PORT" "PRIMEP"
+             "READ-N-BYTES" "REALLOCATE-SYSTEM-MEMORY" "RECORD-SIZE"
+             "REMOVE-FD-HANDLER" "REMOVE-PORT-DEATH-HANDLER"
+             "REMOVE-PORT-OBJECT" "REMOVE-XWINDOW-OBJECT"
+             "RESOLVE-LOADED-ASSEMBLER-REFERENCES" "SAP+" "SAP-" "SAP-INT"
+             "SAP-REF-16" "SAP-REF-32" "SAP-REF-8" "SAP-REF-DESCRIPTOR"
+             "SAP-REF-DOUBLE" "SAP-REF-SAP" "SAP-REF-SINGLE" "SAP<" "SAP<="
+             "SAP=" "SAP>" "SAP>=" "SCRUB-CONTROL-STACK" "SERVE-ALL-EVENTS"
+             "SERVE-EVENT" "SERVER" "SERVER-MESSAGE" "SHORT-FLOAT-RADIX"
+             "SIGNED-SAP-REF-16" "SIGNED-SAP-REF-32" "SIGNED-SAP-REF-8"
+             "SINGLE-FLOAT-RADIX" "SYMBOL-MACRO-LET" "SYSTEM-AREA-POINTER"
+             "SYSTEM-AREA-POINTER-P" "UNPROCLAIM" "UNSTRUCTURED" "VECTOR-SAP"
+             "WAIT-UNTIL-FD-USABLE" "WITH-ENABLED-INTERRUPTS" "WITH-FD-HANDLER"
+             "WITH-INTERRUPTS" "WITH-REPLY-PORT" "WITHOUT-GCING"
+             "WITHOUT-HEMLOCK" "WITHOUT-INTERRUPTS" "WORDS"))
+(dolist
+    (name
+     '("*" "ARRAY" "DOUBLE-FLOAT" "FUNCTION" "INTEGER" "SINGLE-FLOAT" "UNION"
+       "VALUES"))
+  (intern name "LISP"))
+(defpackage "ALIEN"
+            (:import-from "LISP" "*" "ARRAY" "DOUBLE-FLOAT" "FUNCTION"
+             "INTEGER" "SINGLE-FLOAT" "UNION" "VALUES")
+            (: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"
+             "SAP-ALIEN" "SIGNED" "SINGLE-FLOAT" "SLOT" "STRUCT" "UNION"
+             "UNSIGNED" "VALUES" "WITH-ALIEN"))
+(dolist
+    (name
+     '("%CAST" "%DEREF-ADDR" "%HEAP-ALIEN" "%HEAP-ALIEN-ADDR"
+       "%LOCAL-ALIEN-ADDR" "%LOCAL-ALIEN-FORCED-TO-MEMORY-P" "%SAP-ALIEN"
+       "%SET-DEREF" "%SET-HEAP-ALIEN" "%SET-LOCAL-ALIEN" "%SET-SLOT"
+       "%SLOT-ADDR" "ALIEN" "ALIEN-ARRAY-TYPE" "ALIEN-ARRAY-TYPE-DIMENSIONS"
+       "ALIEN-ARRAY-TYPE-ELEMENT-TYPE" "ALIEN-ARRAY-TYPE-P"
+       "ALIEN-BOOLEAN-TYPE" "ALIEN-BOOLEAN-TYPE-P" "ALIEN-ENUM-TYPE"
+       "ALIEN-ENUM-TYPE-P" "ALIEN-FUNCTION-TYPE"
+       "ALIEN-FUNCTION-TYPE-ARG-TYPES" "ALIEN-FUNCTION-TYPE-P"
+       "ALIEN-FUNCTION-TYPE-RESULT-TYPE" "ALIEN-INTEGER-TYPE"
+       "ALIEN-INTEGER-TYPE-P" "ALIEN-INTEGER-TYPE-SIGNED" "ALIEN-POINTER-TYPE"
+       "ALIEN-POINTER-TYPE-P" "ALIEN-POINTER-TYPE-TO" "ALIEN-RECORD-FIELD"
+       "ALIEN-RECORD-FIELD-NAME" "ALIEN-RECORD-FIELD-OFFSET"
+       "ALIEN-RECORD-FIELD-P" "ALIEN-RECORD-FIELD-TYPE" "ALIEN-RECORD-TYPE"
+       "ALIEN-RECORD-TYPE-FIELDS" "ALIEN-RECORD-TYPE-P" "ALIEN-SUBTYPE-P"
+       "ALIEN-TYPE" "ALIEN-TYPE-=" "ALIEN-TYPE-ALIGNMENT" "ALIEN-TYPE-BITS"
+       "ALIEN-TYPE-P" "ALIEN-TYPEP" "ALIEN-VALUE" "ALIEN-VALUES-TYPE"
+       "ALIEN-VALUES-TYPE-P" "ALIEN-VALUES-TYPE-VALUES" "ALIGN-OFFSET"
+       "COMPUTE-ALIEN-REP-TYPE" "COMPUTE-DEPORT-LAMBDA"
+       "COMPUTE-DEPOSIT-LAMBDA" "COMPUTE-EXTRACT-LAMBDA"
+       "COMPUTE-LISP-REP-TYPE" "COMPUTE-NATURALIZE-LAMBDA"
+       "DEF-ALIEN-TYPE-CLASS" "DEF-ALIEN-TYPE-METHOD"
+       "DEF-ALIEN-TYPE-TRANSLATOR" "DEPORT" "DEPOSIT-ALIEN-VALUE"
+       "DISPOSE-LOCAL-ALIEN" "EXTRACT-ALIEN-VALUE" "HEAP-ALIEN-INFO"
+       "HEAP-ALIEN-INFO-P" "HEAP-ALIEN-INFO-SAP-FORM" "HEAP-ALIEN-INFO-TYPE"
+       "INVOKE-ALIEN-TYPE-METHOD" "LOCAL-ALIEN" "LOCAL-ALIEN-INFO"
+       "LOCAL-ALIEN-INFO-FORCE-TO-MEMORY-P" "LOCAL-ALIEN-INFO-P"
+       "LOCAL-ALIEN-INFO-TYPE" "MAKE-ALIEN-POINTER-TYPE" "MAKE-LOCAL-ALIEN"
+       "NATURALIZE" "NOTE-LOCAL-ALIEN-TYPE" "PARSE-ALIEN-TYPE"
+       "UNPARSE-ALIEN-TYPE"))
+  (intern name "ALIEN"))
+(defpackage "ALIEN-INTERNALS"
+            (:import-from "ALIEN" "%CAST" "%DEREF-ADDR" "%HEAP-ALIEN"
+             "%HEAP-ALIEN-ADDR" "%LOCAL-ALIEN-ADDR"
+             "%LOCAL-ALIEN-FORCED-TO-MEMORY-P" "%SAP-ALIEN" "%SET-DEREF"
+             "%SET-HEAP-ALIEN" "%SET-LOCAL-ALIEN" "%SET-SLOT" "%SLOT-ADDR"
+             "ALIEN" "ALIEN-ARRAY-TYPE" "ALIEN-ARRAY-TYPE-DIMENSIONS"
+             "ALIEN-ARRAY-TYPE-ELEMENT-TYPE" "ALIEN-ARRAY-TYPE-P"
+             "ALIEN-BOOLEAN-TYPE" "ALIEN-BOOLEAN-TYPE-P" "ALIEN-ENUM-TYPE"
+             "ALIEN-ENUM-TYPE-P" "ALIEN-FUNCTION-TYPE"
+             "ALIEN-FUNCTION-TYPE-ARG-TYPES" "ALIEN-FUNCTION-TYPE-P"
+             "ALIEN-FUNCTION-TYPE-RESULT-TYPE" "ALIEN-INTEGER-TYPE"
+             "ALIEN-INTEGER-TYPE-P" "ALIEN-INTEGER-TYPE-SIGNED"
+             "ALIEN-POINTER-TYPE" "ALIEN-POINTER-TYPE-P"
+             "ALIEN-POINTER-TYPE-TO" "ALIEN-RECORD-FIELD"
+             "ALIEN-RECORD-FIELD-NAME" "ALIEN-RECORD-FIELD-OFFSET"
+             "ALIEN-RECORD-FIELD-P" "ALIEN-RECORD-FIELD-TYPE"
+             "ALIEN-RECORD-TYPE" "ALIEN-RECORD-TYPE-FIELDS"
+             "ALIEN-RECORD-TYPE-P" "ALIEN-SUBTYPE-P" "ALIEN-TYPE"
+             "ALIEN-TYPE-=" "ALIEN-TYPE-ALIGNMENT" "ALIEN-TYPE-BITS"
+             "ALIEN-TYPE-P" "ALIEN-TYPEP" "ALIEN-VALUE" "ALIEN-VALUES-TYPE"
+             "ALIEN-VALUES-TYPE-P" "ALIEN-VALUES-TYPE-VALUES" "ALIGN-OFFSET"
+             "COMPUTE-ALIEN-REP-TYPE" "COMPUTE-DEPORT-LAMBDA"
+             "COMPUTE-DEPOSIT-LAMBDA" "COMPUTE-EXTRACT-LAMBDA"
+             "COMPUTE-LISP-REP-TYPE" "COMPUTE-NATURALIZE-LAMBDA"
+             "DEF-ALIEN-TYPE-CLASS" "DEF-ALIEN-TYPE-METHOD"
+             "DEF-ALIEN-TYPE-TRANSLATOR" "DEPORT" "DEPOSIT-ALIEN-VALUE"
+             "DISPOSE-LOCAL-ALIEN" "EXTRACT-ALIEN-VALUE" "HEAP-ALIEN-INFO"
+             "HEAP-ALIEN-INFO-P" "HEAP-ALIEN-INFO-SAP-FORM"
+             "HEAP-ALIEN-INFO-TYPE" "INVOKE-ALIEN-TYPE-METHOD" "LOCAL-ALIEN"
+             "LOCAL-ALIEN-INFO" "LOCAL-ALIEN-INFO-FORCE-TO-MEMORY-P"
+             "LOCAL-ALIEN-INFO-P" "LOCAL-ALIEN-INFO-TYPE"
+             "MAKE-ALIEN-POINTER-TYPE" "MAKE-LOCAL-ALIEN" "NATURALIZE"
+             "NOTE-LOCAL-ALIEN-TYPE" "PARSE-ALIEN-TYPE" "UNPARSE-ALIEN-TYPE")
+            (:export "%CAST" "%DEREF-ADDR" "%HEAP-ALIEN" "%HEAP-ALIEN-ADDR"
+             "%LOCAL-ALIEN-ADDR" "%LOCAL-ALIEN-FORCED-TO-MEMORY-P" "%SAP-ALIEN"
+             "%SET-DEREF" "%SET-HEAP-ALIEN" "%SET-LOCAL-ALIEN" "%SET-SLOT"
+             "%SLOT-ADDR" "ALIEN" "ALIEN-ARRAY-TYPE"
+             "ALIEN-ARRAY-TYPE-DIMENSIONS" "ALIEN-ARRAY-TYPE-ELEMENT-TYPE"
+             "ALIEN-ARRAY-TYPE-P" "ALIEN-BOOLEAN-TYPE" "ALIEN-BOOLEAN-TYPE-P"
+             "ALIEN-ENUM-TYPE" "ALIEN-ENUM-TYPE-P" "ALIEN-FUNCTION-TYPE"
+             "ALIEN-FUNCTION-TYPE-ARG-TYPES" "ALIEN-FUNCTION-TYPE-P"
+             "ALIEN-FUNCTION-TYPE-RESULT-TYPE" "ALIEN-INTEGER-TYPE"
+             "ALIEN-INTEGER-TYPE-P" "ALIEN-INTEGER-TYPE-SIGNED"
+             "ALIEN-POINTER-TYPE" "ALIEN-POINTER-TYPE-P"
+             "ALIEN-POINTER-TYPE-TO" "ALIEN-RECORD-FIELD"
+             "ALIEN-RECORD-FIELD-NAME" "ALIEN-RECORD-FIELD-OFFSET"
+             "ALIEN-RECORD-FIELD-P" "ALIEN-RECORD-FIELD-TYPE"
+             "ALIEN-RECORD-TYPE" "ALIEN-RECORD-TYPE-FIELDS"
+             "ALIEN-RECORD-TYPE-P" "ALIEN-SUBTYPE-P" "ALIEN-TYPE"
+             "ALIEN-TYPE-=" "ALIEN-TYPE-ALIGNMENT" "ALIEN-TYPE-BITS"
+             "ALIEN-TYPE-P" "ALIEN-TYPEP" "ALIEN-VALUE" "ALIEN-VALUES-TYPE"
+             "ALIEN-VALUES-TYPE-P" "ALIEN-VALUES-TYPE-VALUES" "ALIGN-OFFSET"
+             "COMPUTE-ALIEN-REP-TYPE" "COMPUTE-DEPORT-LAMBDA"
+             "COMPUTE-DEPOSIT-LAMBDA" "COMPUTE-EXTRACT-LAMBDA"
+             "COMPUTE-LISP-REP-TYPE" "COMPUTE-NATURALIZE-LAMBDA"
+             "DEF-ALIEN-TYPE-CLASS" "DEF-ALIEN-TYPE-METHOD"
+             "DEF-ALIEN-TYPE-TRANSLATOR" "DEPORT" "DEPOSIT-ALIEN-VALUE"
+             "DISPOSE-LOCAL-ALIEN" "EXTRACT-ALIEN-VALUE" "HEAP-ALIEN-INFO"
+             "HEAP-ALIEN-INFO-P" "HEAP-ALIEN-INFO-SAP-FORM"
+             "HEAP-ALIEN-INFO-TYPE" "INVOKE-ALIEN-TYPE-METHOD" "LOCAL-ALIEN"
+             "LOCAL-ALIEN-INFO" "LOCAL-ALIEN-INFO-FORCE-TO-MEMORY-P"
+             "LOCAL-ALIEN-INFO-P" "LOCAL-ALIEN-INFO-TYPE"
+             "MAKE-ALIEN-POINTER-TYPE" "MAKE-LOCAL-ALIEN" "NATURALIZE"
+             "NOTE-LOCAL-ALIEN-TYPE" "PARSE-ALIEN-TYPE" "UNPARSE-ALIEN-TYPE"))
+(defpackage "PROFILE"
+            (:export "*TIMED-FUNCTIONS*" "PROFILE" "REPORT-TIME" "RESET-TIME"
+             "UNPROFILE"))
+(defpackage "USER" (:export "DUMP-HASH-TABLE"))
+(dolist
+    (name
+     '("ARRAY-RANK" "ARRAY-TOTAL-SIZE" "CHAR-INT" "FLOAT-DIGITS" "FLOAT-RADIX"
+       "PATHNAME-DEVICE" "PATHNAME-DIRECTORY" "PATHNAME-HOST" "PATHNAME-NAME"
+       "PATHNAME-TYPE" "PATHNAME-VERSION"))
+  (intern name "LISP"))
+(intern "BOOLEAN" "ALIEN")
+(defpackage "KERNEL"
+            (:import-from "LISP" "ARRAY-RANK" "ARRAY-TOTAL-SIZE" "CHAR-INT"
+             "FLOAT-DIGITS" "FLOAT-RADIX" "PATHNAME-DEVICE"
+             "PATHNAME-DIRECTORY" "PATHNAME-HOST" "PATHNAME-NAME"
+             "PATHNAME-TYPE" "PATHNAME-VERSION")
+            (:import-from "ALIEN" "BOOLEAN")
+            (:export "%ACOS" "%ACOSH" "%ARRAY-AVAILABLE-ELEMENTS"
+             "%ARRAY-DATA-VECTOR" "%ARRAY-DIMENSION" "%ARRAY-DISPLACED-P"
+             "%ARRAY-DISPLACEMENT" "%ARRAY-FILL-POINTER"
+             "%ARRAY-FILL-POINTER-P" "%ASIN" "%ASINH" "%ATAN" "%ATAN2" "%ATANH"
+             "%CALLER-FRAME-AND-PC" "%CBRT" "%CHECK-BOUND" "%CLOSURE-FUNCTION"
+             "%CLOSURE-INDEX-REF" "%COS" "%COSH" "%DEPOSIT-FIELD"
+             "%DOUBLE-FLOAT" "%DPB" "%EXP" "%EXPM1" "%FUNCTION-HEADER-ARGLIST"
+             "%FUNCTION-HEADER-NAME" "%FUNCTION-HEADER-TYPE" "%HYPOT" "%LDB"
+             "%LOG" "%LOG10" "%LOG1P" "%MAKE-COMPLEX"
+             "%MAKE-FUNCALLABLE-INSTANCE" "%MAKE-RATIO" "%MASK-FIELD" "%NEGATE"
+             "%POW" "%RAW-BITS" "%SET-FUNCALLABLE-INSTANCE-FUNCTION"
+             "%SET-FUNCALLABLE-INSTANCE-INFO" "%SET-RAW-BITS" "%SET-SAP-REF-16"
+             "%SET-SAP-REF-32" "%SET-SAP-REF-8" "%SET-SAP-REF-DOUBLE"
+             "%SET-SAP-REF-SAP" "%SET-SAP-REF-SINGLE" "%SET-STACK-REF" "%SIN"
+             "%SINGLE-FLOAT" "%SINH" "%SP-SET-DEFINITION" "%SP-SET-PLIST"
+             "%SQRT" "%SXHASH-SIMPLE-STRING" "%SXHASH-SIMPLE-SUBSTRING" "%TAN"
+             "%TANH" "%UNARY-ROUND" "%UNARY-TRUNCATE" "%WITH-ARRAY-DATA"
+             "*CURRENT-LEVEL*" "*EMPTY-TYPE*" "*EVAL-STACK-TOP*" "*NULL-TYPE*"
+             "*PRETTY-PRINTER*" "*UNIVERSAL-TYPE*"
+             "*UNPARSE-FUNCTION-TYPE-SIMPLIFY*" "*WILD-TYPE*"
+             "32BIT-LOGICAL-AND" "32BIT-LOGICAL-ANDC1" "32BIT-LOGICAL-ANDC2"
+             "32BIT-LOGICAL-EQV" "32BIT-LOGICAL-NAND" "32BIT-LOGICAL-NOR"
+             "32BIT-LOGICAL-NOT" "32BIT-LOGICAL-OR" "32BIT-LOGICAL-ORC1"
+             "32BIT-LOGICAL-ORC2" "32BIT-LOGICAL-XOR" "ALIEN-TYPE-TYPE"
+             "ALIEN-TYPE-TYPE-ALIEN-TYPE" "ALIEN-TYPE-TYPE-P" "ALLOCATE-VECTOR"
+             "ALWAYS-SUBTYPEP" "ARGS-TYPE" "ARGS-TYPE-ALLOWP" "ARGS-TYPE-KEYP"
+             "ARGS-TYPE-KEYWORDS" "ARGS-TYPE-OPTIONAL" "ARGS-TYPE-P"
+             "ARGS-TYPE-REQUIRED" "ARGS-TYPE-REST" "ARRAY-HEADER-P"
+             "ARRAY-RANK" "ARRAY-TOTAL-SIZE" "ARRAY-TYPE" "ARRAY-TYPE-COMPLEXP"
+             "ARRAY-TYPE-DIMENSIONS" "ARRAY-TYPE-ELEMENT-TYPE" "ARRAY-TYPE-P"
+             "ARRAY-TYPE-SPECIALIZED-ELEMENT-TYPE" "ASH-INDEX" "BASE-CHAR-P"
+             "BINDING-STACK-POINTER-SAP" "BIT-BASH-AND" "BIT-BASH-ANDC1"
+             "BIT-BASH-ANDC2" "BIT-BASH-CLEAR" "BIT-BASH-COPY" "BIT-BASH-EQV"
+             "BIT-BASH-IOR" "BIT-BASH-LOGNAND" "BIT-BASH-LOGNOR" "BIT-BASH-NOT"
+             "BIT-BASH-ORC1" "BIT-BASH-ORC2" "BIT-BASH-SET" "BIT-BASH-XOR"
+             "BIT-INDEX" "BOGUS-ARGUMENT-TO-VALUES-LIST-ERROR" "BOOLE-CODE"
+             "BOOLEAN" "BYTE-SPECIFIER" "CALLABLE" "CHAR-INT"
+             "CHECK-FOR-CIRCULARITY" "CODE-COMPONENT" "CODE-COMPONENT-P"
+             "CODE-DEBUG-INFO" "CODE-HEADER-REF" "CODE-HEADER-SET"
+             "CODE-INSTRUCTIONS" "CONSED-SEQUENCE" "CONSTANT-TYPE"
+             "CONSTANT-TYPE-P" "CONSTANT-TYPE-TYPE" "CONTAINING-INTEGER-TYPE"
+             "CONTROL-STACK-POINTER-SAP" "COPY-FROM-SYSTEM-AREA"
+             "COPY-NUMERIC-TYPE" "COPY-TO-SYSTEM-AREA" "CSUBTYPEP" "CTYPE"
+             "CTYPE-OF" "CTYPE-P" "CTYPEP" "CURRENT-FP" "CURRENT-SP"
+             "DATA-VECTOR-REF" "DATA-VECTOR-SET" "DECODE-DOUBLE-FLOAT"
+             "DECODE-SINGLE-FLOAT" "DESCEND-INTO" "DIVISION-BY-ZERO-ERROR"
+             "DOUBLE-FLOAT-EXPONENT" "DOUBLE-FLOAT-HIGH-BITS"
+             "DOUBLE-FLOAT-LOW-BITS" "DOUBLE-FLOAT-P"
+             "DYNAMIC-SPACE-FREE-POINTER" "ERROR-NUMBER-OR-LOSE" "FILENAME"
+             "FLOAT-DIGITS" "FLOAT-EXPONENT" "FLOAT-FORMAT-DIGITS"
+             "FLOAT-FORMAT-MAX" "FLOAT-RADIX" "FORM" "FUNCALLABLE-INSTANCE-P"
+             "FUNCTION-CODE-HEADER" "FUNCTION-TYPE" "FUNCTION-TYPE-ALLOWP"
+             "FUNCTION-TYPE-KEYP" "FUNCTION-TYPE-KEYWORDS"
+             "FUNCTION-TYPE-NARGS" "FUNCTION-TYPE-OPTIONAL" "FUNCTION-TYPE-P"
+             "FUNCTION-TYPE-REQUIRED" "FUNCTION-TYPE-REST"
+             "FUNCTION-TYPE-RETURNS" "FUNCTION-TYPE-WILD-ARGS"
+             "FUNCTION-WORD-OFFSET" "GET-CLOSURE-LENGTH" "GET-HEADER-DATA"
+             "GET-LISP-OBJ-ADDRESS" "GET-LOWTAG" "GET-TYPE" "HAIRY-TYPE"
+             "HAIRY-TYPE-CHECK-TEMPLATE" "HAIRY-TYPE-SPECIFIER"
+             "HANDLE-CIRCULARITY" "INDEX" "INTEGER-DECODE-DOUBLE-FLOAT"
+             "INTEGER-DECODE-SINGLE-FLOAT" "INTERNAL-TIME"
+             "INVALID-ARGUMENT-COUNT-ERROR" "INVALID-ARRAY-INDEX-ERROR"
+             "INVALID-UNWIND-ERROR" "IRRATIONAL" "KEY-INFO" "KEY-INFO-NAME"
+             "KEY-INFO-P" "KEY-INFO-TYPE" "LEXICAL-ENVIRONMENT" "LRA"
+             "LRA-CODE-HEADER" "LRA-P" "MAKE-ALIEN-TYPE-TYPE" "MAKE-ARGS-TYPE"
+             "MAKE-ARRAY-HEADER" "MAKE-DOUBLE-FLOAT" "MAKE-FUNCTION-TYPE"
+             "MAKE-KEY-INFO" "MAKE-LISP-OBJ" "MAKE-MEMBER-TYPE"
+             "MAKE-NAMED-TYPE" "MAKE-NUMERIC-TYPE" "MAKE-SINGLE-FLOAT"
+             "MAKE-STRUCTURE" "MAKE-STRUCTURE-TYPE" "MAKE-UNION-TYPE"
+             "MAKE-VALUES-TYPE" "MEMBER-TYPE" "MEMBER-TYPE-MEMBERS"
+             "MEMBER-TYPE-P" "MERGE-BITS" "MUTATOR-SELF" "NAMED-TYPE"
+             "NAMED-TYPE-NAME" "NAMED-TYPE-P" "NATIVE-BYTE-ORDER" "NEGATE"
+             "NEVER-SUBTYPEP" "NIL-FUNCTION-RETURNED-ERROR" "NOT-<=-ERROR"
+             "NOT-=-ERROR" "NUMERIC-CONTAGION" "NUMERIC-TYPE"
+             "NUMERIC-TYPE-CLASS" "NUMERIC-TYPE-COMPLEXP" "NUMERIC-TYPE-FORMAT"
+             "NUMERIC-TYPE-HIGH" "NUMERIC-TYPE-LOW" "NUMERIC-TYPE-P"
+             "OBJECT-NOT-ARRAY-ERROR" "OBJECT-NOT-BASE-CHAR-ERROR"
+             "OBJECT-NOT-BIGNUM-ERROR" "OBJECT-NOT-BIT-VECTOR-ERROR"
+             "OBJECT-NOT-COERCABLE-TO-FUNCTION-ERROR"
+             "OBJECT-NOT-COMPLEX-ERROR" "OBJECT-NOT-CONS-ERROR"
+             "OBJECT-NOT-DOUBLE-FLOAT-ERROR" "OBJECT-NOT-FIXNUM-ERROR"
+             "OBJECT-NOT-FLOAT-ERROR" "OBJECT-NOT-FUNCTION-ERROR"
+             "OBJECT-NOT-FUNCTION-OR-SYMBOL-ERROR" "OBJECT-NOT-INTEGER-ERROR"
+             "OBJECT-NOT-LIST-ERROR" "OBJECT-NOT-NUMBER-ERROR"
+             "OBJECT-NOT-RATIO-ERROR" "OBJECT-NOT-RATIONAL-ERROR"
+             "OBJECT-NOT-REAL-ERROR" "OBJECT-NOT-SAP-ERROR"
+             "OBJECT-NOT-SIGNED-BYTE-32-ERROR"
+             "OBJECT-NOT-SIMPLE-ARRAY-DOUBLE-FLOAT-ERROR"
+             "OBJECT-NOT-SIMPLE-ARRAY-ERROR"
+             "OBJECT-NOT-SIMPLE-ARRAY-SINGLE-FLOAT-ERROR"
+             "OBJECT-NOT-SIMPLE-ARRAY-UNSIGNED-BYTE-16-ERROR"
+             "OBJECT-NOT-SIMPLE-ARRAY-UNSIGNED-BYTE-2-ERROR"
+             "OBJECT-NOT-SIMPLE-ARRAY-UNSIGNED-BYTE-32-ERROR"
+             "OBJECT-NOT-SIMPLE-ARRAY-UNSIGNED-BYTE-4-ERROR"
+             "OBJECT-NOT-SIMPLE-ARRAY-UNSIGNED-BYTE-8-ERROR"
+             "OBJECT-NOT-SIMPLE-BIT-VECTOR-ERROR"
+             "OBJECT-NOT-SIMPLE-STRING-ERROR" "OBJECT-NOT-SIMPLE-VECTOR-ERROR"
+             "OBJECT-NOT-SINGLE-FLOAT-ERROR" "OBJECT-NOT-STRING-ERROR"
+             "OBJECT-NOT-STRUCTURE-ERROR" "OBJECT-NOT-SYMBOL-ERROR"
+             "OBJECT-NOT-TYPE-ERROR" "OBJECT-NOT-UNSIGNED-BYTE-32-ERROR"
+             "OBJECT-NOT-VECTOR-ERROR" "OBJECT-NOT-WEAK-POINTER-ERROR"
+             "ODD-KEYWORD-ARGUMENTS-ERROR" "OUTPUT-OBJECT" "OUTPUT-UGLY-OBJECT"
+             "PARSE-LAMBDA-LIST" "PARSE-UNKNOWN-TYPE"
+             "PARSE-UNKNOWN-TYPE-SPECIFIER" "PATHNAME-DEVICE"
+             "PATHNAME-DIRECTORY" "PATHNAME-HOST" "PATHNAME-NAME"
+             "PATHNAME-TYPE" "PATHNAME-VERSION" "PATHNAMELIKE"
+             "PUNT-IF-TOO-LONG" "SCALE-DOUBLE-FLOAT" "SCALE-SINGLE-FLOAT"
+             "SEQUENCE-END" "SET-HEADER-DATA" "SHIFT-TOWARDS-END"
+             "SHIFT-TOWARDS-START" "SIGNAL-INIT" "SIGNED-BYTE-32-P"
+             "SIMPLE-ARRAY-DOUBLE-FLOAT-P" "SIMPLE-ARRAY-P"
+             "SIMPLE-ARRAY-SINGLE-FLOAT-P" "SIMPLE-ARRAY-UNSIGNED-BYTE-16-P"
+             "SIMPLE-ARRAY-UNSIGNED-BYTE-2-P" "SIMPLE-ARRAY-UNSIGNED-BYTE-32-P"
+             "SIMPLE-ARRAY-UNSIGNED-BYTE-4-P" "SIMPLE-ARRAY-UNSIGNED-BYTE-8-P"
+             "SIMPLE-UNBOXED-ARRAY" "SINGLE-FLOAT-BITS" "SINGLE-FLOAT-EXPONENT"
+             "SINGLE-FLOAT-P" "SINGLE-VALUE-TYPE" "SPECIFIER-TYPE" "STACK-REF"
+             "STREAMLIKE" "STRINGABLE" "STRINGLIKE" "STRUCTURE-INDEX"
+             "STRUCTURE-INDEX-REF" "STRUCTURE-INDEX-SET" "STRUCTURE-LENGTH"
+             "STRUCTURE-REF" "STRUCTURE-SET" "STRUCTURE-TYPE"
+             "STRUCTURE-TYPE-NAME" "STRUCTURE-TYPE-P" "SYSTEM-AREA-CLEAR"
+             "SYSTEM-AREA-COPY" "TRUTH" "TWO-ARG-*" "TWO-ARG-+" "TWO-ARG--"
+             "TWO-ARG-/" "TWO-ARG-/=" "TWO-ARG-<" "TWO-ARG-<=" "TWO-ARG-="
+             "TWO-ARG->" "TWO-ARG->=" "TWO-ARG-AND" "TWO-ARG-GCD" "TWO-ARG-IOR"
+             "TWO-ARG-LCM" "TWO-ARG-XOR" "TYPE-DIFFERENCE" "TYPE-EXPAND"
+             "TYPE-INIT" "TYPE-INTERSECT" "TYPE-INTERSECTION" "TYPE-SPECIFIER"
+             "TYPE-SPECIFIER-SYMBOLS" "TYPE-UNION" "TYPE/=" "TYPE="
+             "TYPES-INTERSECT" "UNBOUND-SYMBOL-ERROR" "UNBOXED-ARRAY"
+             "UNDEFINED-SYMBOL-ERROR" "UNION-TYPE" "UNION-TYPE-P"
+             "UNION-TYPE-TYPES" "UNKNOWN-ERROR"
+             "UNKNOWN-KEYWORD-ARGUMENT-ERROR" "UNKNOWN-TYPE" "UNKNOWN-TYPE-P"
+             "UNKNOWN-TYPE-SPECIFIER" "UNSEEN-THROW-TAG-ERROR"
+             "UNSIGNED-BYTE-32-P" "VALUES-SPECIFIER-TYPE"
+             "VALUES-SPECIFIER-TYPE-CACHE-CLEAR" "VALUES-SUBTYPEP"
+             "VALUES-TYPE" "VALUES-TYPE-ALLOWP" "VALUES-TYPE-INTERSECT"
+             "VALUES-TYPE-INTERSECTION" "VALUES-TYPE-KEYP"
+             "VALUES-TYPE-KEYWORDS" "VALUES-TYPE-OPTIONAL" "VALUES-TYPE-P"
+             "VALUES-TYPE-REQUIRED" "VALUES-TYPE-REST" "VALUES-TYPE-UNION"
+             "VALUES-TYPES" "VALUES-TYPES-INTERSECT"
+             "WITH-CIRCULARITY-DETECTION" "WRONG-NUMBER-OF-INDICES-ERROR"))
diff --git a/code/fd-stream.lisp b/code/fd-stream.lisp
index 8224130ad2978c014d193ccacd97981b52f73868..ab3f33b1db49faa3b8f7abb103cd699543ec18df 100644
--- a/code/fd-stream.lisp
+++ b/code/fd-stream.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/fd-stream.lisp,v 1.18 1991/12/16 12:48:45 wlott Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/fd-stream.lisp,v 1.19 1992/02/14 23:44:45 wlott Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -138,15 +138,15 @@
     (declare (type index start end length))
     (multiple-value-bind
 	(count errno)
-	(mach:unix-write (fd-stream-fd stream)
+	(unix:unix-write (fd-stream-fd stream)
 			 base
 			 start
 			 length)
       (cond ((not count)
-	     (if (= errno mach:ewouldblock)
+	     (if (= errno unix:ewouldblock)
 		 (error "Write would have blocked, but SERVER told us to go.")
 		 (error "While writing ~S: ~A"
-			stream (mach:get-unix-error-msg errno))))
+			stream (unix:get-unix-error-msg errno))))
 	    ((eql count length) ; Hot damn, it workded.
 	     (when reuse-sap
 	       (push base *available-buffers*)))
@@ -199,12 +199,12 @@
       (let ((length (- end start)))
 	(multiple-value-bind
 	    (count errno)
-	    (mach:unix-write (fd-stream-fd stream) base start length)
+	    (unix:unix-write (fd-stream-fd stream) base start length)
 	  (cond ((not count)
-		 (if (= errno mach:ewouldblock)
+		 (if (= errno unix:ewouldblock)
 		     (output-later stream base start end reuse-sap)
 		     (error "While writing ~S: ~A"
-			    stream (mach:get-unix-error-msg errno))))
+			    stream (unix:get-unix-error-msg errno))))
 		((not (eql count length))
 		 (output-later stream base (+ start count) end reuse-sap)))))))
 
@@ -450,7 +450,7 @@
     #+serve-event
     (multiple-value-bind
 	(count errno)
-	(mach:unix-select (1+ fd) (ash 1 fd) 0 0 0)
+	(unix:unix-select (1+ fd) (ash 1 fd) 0 0 0)
       (case count
 	(1)
 	(0
@@ -460,14 +460,14 @@
 	(t
 	 (error "Problem checking to see if ~S is readable: ~A"
 		stream
-		(mach:get-unix-error-msg errno)))))
+		(unix:get-unix-error-msg errno)))))
     (multiple-value-bind
 	(count errno)
-	(mach:unix-read fd
+	(unix:unix-read fd
 			(system:int-sap (+ (system:sap-int ibuf-sap) tail))
 			(- buflen tail))
       (cond ((null count)
-	     (if #+serve-event (eql errno mach:ewouldblock)
+	     (if #+serve-event (eql errno unix:ewouldblock)
 		 #-serve-event nil
 	       (progn
 		 (unless (system:wait-until-fd-usable
@@ -476,7 +476,7 @@
 		 (do-input stream))
 	       (error "Error reading ~S: ~A"
 		      stream
-		      (mach:get-unix-error-msg errno))))
+		      (unix:get-unix-error-msg errno))))
 	    ((zerop count)
 	     (setf (fd-stream-listen stream) :eof)
 	     (throw 'eof-input-catcher nil))
@@ -774,7 +774,7 @@ non-server method is also significantly more efficient for large reads.
 	    (loop
 	      (multiple-value-bind
 		  (count err)
-		  (mach:unix-read (fd-stream-fd stream)
+		  (unix:unix-read (fd-stream-fd stream)
 				  (sap+ (if (typep buffer 'system-area-pointer)
 					    buffer
 					    (vector-sap buffer))
@@ -783,7 +783,7 @@ non-server method is also significantly more efficient for large reads.
 		(declare (type (or index null) count))
 		(unless count
 		  (error "Error reading ~S: ~A" stream
-			 (mach:get-unix-error-msg err)))
+			 (unix:get-unix-error-msg err)))
 		(when (zerop count)
 		  (if eof-error-p
 		      (error "Unexpected eof on ~S." stream)
@@ -795,11 +795,11 @@ non-server method is also significantly more efficient for large reads.
 	  (loop
 	    (multiple-value-bind
 		(count err)
-		(mach:unix-read (fd-stream-fd stream) sap len)
+		(unix:unix-read (fd-stream-fd stream) sap len)
 	      (declare (type (or index null) count))
 	      (unless count
 		(error "Error reading ~S: ~A" stream
-		       (mach:get-unix-error-msg err)))
+		       (unix:get-unix-error-msg err)))
 	      (incf (fd-stream-ibuf-tail stream) count)
 	      (when (zerop count)
 		(if eof-error-p
@@ -933,7 +933,7 @@ non-server method is also significantly more efficient for large reads.
 		   (fd-stream-ibuf-tail stream)))
 	 (fd-stream-listen stream)
 	 (setf (fd-stream-listen stream)
-	       (eql (mach:unix-select (1+ (fd-stream-fd stream))
+	       (eql (unix:unix-select (1+ (fd-stream-fd stream))
 				      (ash 1 (fd-stream-fd stream))
 				      0
 				      0
@@ -954,38 +954,38 @@ non-server method is also significantly more efficient for large reads.
 		  ;; Have an handle on the original, just revert.
 		  (multiple-value-bind
 		      (okay err)
-		      (mach:unix-rename (fd-stream-original stream)
+		      (unix:unix-rename (fd-stream-original stream)
 					(fd-stream-file stream))
 		    (unless okay
 		      (cerror "Go on as if nothing bad happened."
 		        "Could not restore ~S to it's original contents: ~A"
 			      (fd-stream-file stream)
-			      (mach:get-unix-error-msg err))))
+			      (unix:get-unix-error-msg err))))
 		  ;; Can't restore the orignal, so nuke that puppy.
 		  (multiple-value-bind
 		      (okay err)
-		      (mach:unix-unlink (fd-stream-file stream))
+		      (unix:unix-unlink (fd-stream-file stream))
 		    (unless okay
 		      (cerror "Go on as if nothing bad happened."
 			      "Could not remove ~S: ~A"
 			      (fd-stream-file stream)
-			      (mach:get-unix-error-msg err)))))))
+			      (unix:get-unix-error-msg err)))))))
 	   (t
 	    (fd-stream-misc-routine stream :finish-output)
 	    (when (and (fd-stream-original stream)
 		       (fd-stream-delete-original stream))
 	      (multiple-value-bind
 		  (okay err)
-		  (mach:unix-unlink (fd-stream-original stream))
+		  (unix:unix-unlink (fd-stream-original stream))
 		(unless okay
 		  (cerror "Go on as if nothing bad happened."
 			  "Could not delete ~S during close of ~S: ~A"
 			  (fd-stream-original stream)
 			  stream
-			  (mach:get-unix-error-msg err)))))))
+			  (unix:get-unix-error-msg err)))))))
      (when (fboundp 'cancel-finalization)
        (cancel-finalization stream))
-     (mach:unix-close (fd-stream-fd stream))
+     (unix:unix-close (fd-stream-fd stream))
      (when (fd-stream-obuf-sap stream)
        (push (fd-stream-obuf-sap stream) *available-buffers*)
        (setf (fd-stream-obuf-sap stream) nil))
@@ -997,7 +997,7 @@ non-server method is also significantly more efficient for large reads.
      (setf (fd-stream-ibuf-head stream) 0)
      (setf (fd-stream-ibuf-tail stream) 0)
      (loop
-       (let ((count (mach:unix-select (1+ (fd-stream-fd stream))
+       (let ((count (unix:unix-select (1+ (fd-stream-fd stream))
 				      (ash 1 (fd-stream-fd stream))
 				      0 0 0)))
 	 (cond ((eql count 1)
@@ -1024,13 +1024,13 @@ non-server method is also significantly more efficient for large reads.
      (multiple-value-bind
 	 (okay dev ino mode nlink uid gid rdev size
 	       atime mtime ctime blksize blocks)
-	 (mach:unix-fstat (fd-stream-fd stream))
+	 (unix:unix-fstat (fd-stream-fd stream))
        (declare (ignore ino nlink uid gid rdev
 			atime mtime ctime blksize blocks))
        (unless okay
 	 (error "Error fstating ~S: ~A"
 		stream
-		(mach:get-unix-error-msg dev)))
+		(unix:get-unix-error-msg dev)))
        (if (zerop mode)
 	 nil
 	 (truncate size (fd-stream-element-size stream)))))
@@ -1050,7 +1050,7 @@ non-server method is also significantly more efficient for large reads.
 	;; file.
 	(multiple-value-bind
 	    (posn errno)
-	    (mach:unix-lseek (fd-stream-fd stream) 0 mach:l_incr)
+	    (unix:unix-lseek (fd-stream-fd stream) 0 unix:l_incr)
 	  (declare (type (or index null) posn))
 	  (cond ((fixnump posn)
 		 ;; Adjust for buffered output:
@@ -1073,13 +1073,13 @@ non-server method is also significantly more efficient for large reads.
 		   (decf posn))
 		 ;; Divide bytes by element size.
 		 (truncate posn (fd-stream-element-size stream)))
-		((eq errno mach:espipe)
+		((eq errno unix:espipe)
 		 nil)
 		(t
 		 (system:with-interrupts
 		   (error "Error lseek'ing ~S: ~A"
 			  stream
-			  (mach:get-unix-error-msg errno)))))))
+			  (unix:get-unix-error-msg errno)))))))
       (let (offset origin)
 	;; Make sure we don't have any output pending, because if we move the
 	;; file pointer before writing this stuff, it will be written in the
@@ -1097,25 +1097,25 @@ non-server method is also significantly more efficient for large reads.
 	(setf (fd-stream-listen stream) nil)
 	;; Now move it.
 	(cond ((eq newpos :start)
-	       (setf offset 0 origin mach:l_set))
+	       (setf offset 0 origin unix:l_set))
 	      ((eq newpos :end)
-	       (setf offset 0 origin mach:l_xtnd))
+	       (setf offset 0 origin unix:l_xtnd))
 	      ((typep newpos 'index)
 	       (setf offset (* newpos (fd-stream-element-size stream))
-		     origin mach:l_set))
+		     origin unix:l_set))
 	      (t
 	       (error "Invalid position given to file-position: ~S" newpos)))
 	(multiple-value-bind
 	    (posn errno)
-	    (mach:unix-lseek (fd-stream-fd stream) offset origin)
+	    (unix:unix-lseek (fd-stream-fd stream) offset origin)
 	  (cond ((typep posn 'fixnum)
 		 t)
-		((eq errno mach:espipe)
+		((eq errno unix:espipe)
 		 nil)
 		(t
 		 (error "Error lseek'ing ~S: ~A"
 			stream
-			(mach:get-unix-error-msg errno))))))))
+			(unix:get-unix-error-msg errno))))))))
 
 
 
@@ -1166,7 +1166,7 @@ non-server method is also significantly more efficient for large reads.
     (when (and auto-close (fboundp 'finalize))
       (finalize stream
 		#'(lambda ()
-		    (mach:unix-close fd)
+		    (unix:unix-close fd)
 		    (format *terminal-io* "** Closed file descriptor ~D~%"
 			    fd))))
     stream))
@@ -1215,18 +1215,18 @@ non-server method is also significantly more efficient for large reads.
 ;;; We return true if we suceed in renaming.
 ;;;
 (defun do-old-rename (namestring original)
-  (unless (mach:unix-access namestring mach:w_ok)
+  (unless (unix:unix-access namestring unix:w_ok)
     (cerror "Try to rename it anyway." "File ~S is not writable." namestring))
   (multiple-value-bind
       (okay err)
-      (mach:unix-rename namestring original)
+      (unix:unix-rename namestring original)
     (cond (okay t)
 	  (t
 	   (cerror "Use :SUPERSEDE instead."
 		   "Could not rename ~S to ~S: ~A."
 		   namestring
 		   original
-		   (mach:get-unix-error-msg err))
+		   (unix:get-unix-error-msg err))
 	   nil))))
 
 
@@ -1258,10 +1258,10 @@ non-server method is also significantly more efficient for large reads.
   (multiple-value-bind
       (input output mask)
       (case direction
-	(:input (values t nil mach:o_rdonly))
-	(:output (values nil t mach:o_wronly))
-	(:io (values t t mach:o_rdwr))
-	(:probe (values t nil mach:o_rdonly)))
+	(:input (values t nil unix:o_rdonly))
+	(:output (values nil t unix:o_wronly))
+	(:io (values t t unix:o_rdwr))
+	(:probe (values t nil unix:o_rdonly)))
     (declare (type index mask))
     (let* ((pathname (pathname filename))
 	   (namestring (unix-namestring pathname input)))
@@ -1280,13 +1280,13 @@ non-server method is also significantly more efficient for large reads.
 				  :if-exists))
 	     (case if-exists
 	       ((:error nil)
-		(setf mask (logior mask mach:o_excl)))
+		(setf mask (logior mask unix:o_excl)))
 	       ((:rename :rename-and-delete)
-		(setf mask (logior mask mach:o_creat)))
+		(setf mask (logior mask unix:o_creat)))
 	       ((:new-version :supersede)
-		(setf mask (logior mask mach:o_trunc)))
+		(setf mask (logior mask unix:o_trunc)))
 	       (:append
-		(setf mask (logior mask mach:o_append)))))
+		(setf mask (logior mask unix:o_append)))))
 	    (t
 	     (setf if-exists :ignore-this-arg)))
       
@@ -1305,7 +1305,7 @@ non-server method is also significantly more efficient for large reads.
 			   '(:error :create nil)
 			   :if-does-not-exist))
       (if (eq if-does-not-exist :create)
-	(setf mask (logior mask mach:o_creat)))
+	(setf mask (logior mask unix:o_creat)))
        
       (let ((original (if (member if-exists
 				  '(:rename :rename-and-delete))
@@ -1320,7 +1320,7 @@ non-server method is also significantly more efficient for large reads.
 		 (and namestring
 		      (multiple-value-bind
 			  (okay err/dev inode orig-mode)
-			  (mach:unix-stat namestring)
+			  (unix:unix-stat namestring)
 			(declare (ignore inode)
 				 (type (or index null) orig-mode))
 			(cond
@@ -1331,22 +1331,22 @@ non-server method is also significantly more efficient for large reads.
 				   namestring))
 			  (setf mode (logand orig-mode #o777))
 			  t)
-			 ((eql err/dev mach:enoent)
+			 ((eql err/dev unix:enoent)
 			  nil)
 			 (t
 			  (error "Cannot find ~S: ~A"
 				 namestring
-				 (mach:get-unix-error-msg err/dev))))))))
+				 (unix:get-unix-error-msg err/dev))))))))
 	    (unless (and exists
 			 (do-old-rename namestring original))
 	      (setf original nil)
 	      (setf delete-original nil)
 	      ;; In order to use SUPERSEDE instead, we have
-	      ;; to make sure mach:o_creat corresponds to
-	      ;; if-does-not-exist.  mach:o_creat was set
+	      ;; to make sure unix:o_creat corresponds to
+	      ;; if-does-not-exist.  unix:o_creat was set
 	      ;; before because of if-exists being :rename.
 	      (unless (eq if-does-not-exist :create)
-		(setf mask (logior (logandc2 mask mach:o_creat) mach:o_trunc)))
+		(setf mask (logior (logandc2 mask unix:o_creat) unix:o_trunc)))
 	      (setf if-exists :supersede))))
 	
 	;; Okay, now we can try the actual open.
@@ -1354,8 +1354,8 @@ non-server method is also significantly more efficient for large reads.
 	  (multiple-value-bind
 	      (fd errno)
 	      (if namestring
-		  (mach:unix-open namestring mask mode)
-		  (values nil mach:enoent))
+		  (unix:unix-open namestring mask mode)
+		  (values nil unix:enoent))
 	    (cond ((numberp fd)
 		   (return
 		    (case direction
@@ -1374,35 +1374,35 @@ non-server method is also significantly more efficient for large reads.
 					       :element-type element-type)))
 			 (close stream)
 			 stream)))))
-		  ((eql errno mach:enoent)
+		  ((eql errno unix:enoent)
 		   (case if-does-not-exist
 		     (:error
 		      (cerror "Return NIL."
 			      "Error opening ~S, ~A."
 			      pathname
-			      (mach:get-unix-error-msg errno)))
+			      (unix:get-unix-error-msg errno)))
 		     (:create
 		      (cerror "Return NIL."
 			      "Error creating ~S, path does not exist."
 			      pathname)))
 		   (return nil))
-		  ((eql errno mach:eexist)
+		  ((eql errno unix:eexist)
 		   (unless (eq nil if-exists)
 		     (cerror "Return NIL."
 			     "Error opening ~S, ~A."
 			     pathname
-			     (mach:get-unix-error-msg errno)))
+			     (unix:get-unix-error-msg errno)))
 		   (return nil))
-		  ((eql errno mach:eacces)
+		  ((eql errno unix:eacces)
 		   (cerror "Try again."
 			  "Error opening ~S, ~A."
 			  pathname
-			  (mach:get-unix-error-msg errno)))
+			  (unix:get-unix-error-msg errno)))
 		  (t
 		   (cerror "Return NIL."
 			   "Error opening ~S, ~A."
 			   pathname
-			   (mach:get-unix-error-msg errno))
+			   (unix:get-unix-error-msg errno))
 		   (return nil)))))))))
 
 ;;;; Initialization.
@@ -1445,7 +1445,7 @@ non-server method is also significantly more efficient for large reads.
 	(make-fd-stream 1 :name "Standard Output" :output t :buffering :line))
   (setf *stderr*
 	(make-fd-stream 2 :name "Standard Error" :output t :buffering :line))
-  (let ((tty (mach:unix-open "/dev/tty" mach:o_rdwr #o666)))
+  (let ((tty (unix:unix-open "/dev/tty" unix:o_rdwr #o666)))
     (if tty
 	(setf *tty*
 	      (make-fd-stream tty :name "the Terminal" :input t :output t
diff --git a/code/filesys.lisp b/code/filesys.lisp
index 57ae56e05a348f5275985ffe698f58ebf51298bd..2683118fcf7a47395e9850422f3ea92c804a120e 100644
--- a/code/filesys.lisp
+++ b/code/filesys.lisp
@@ -6,7 +6,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/filesys.lisp,v 1.25 1992/01/30 16:23:49 wlott Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/filesys.lisp,v 1.26 1992/02/14 23:44:50 wlott Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -519,11 +519,11 @@
 				   (cdr tail) pathname verify-existance
 				   function))
 	  (pattern
-	   (let ((dir (mach:open-dir head)))
+	   (let ((dir (unix:open-dir head)))
 	     (when dir
 	       (unwind-protect
 		   (loop
-		     (let ((name (mach:read-dir dir)))
+		     (let ((name (unix:read-dir dir)))
 		       (cond ((null name)
 			      (return))
 			     ((string= name "."))
@@ -531,12 +531,12 @@
 			     ((pattern-matches piece name)
 			      (let ((subdir (concatenate 'string
 							 head name "/")))
-				(when (eq (mach:unix-file-kind subdir)
+				(when (eq (unix:unix-file-kind subdir)
 					  :directory)
 				  (%enumerate-directories
 				   subdir (cdr tail) pathname verify-existance
 				   function)))))))
-		 (mach:close-dir dir)))))
+		 (unix:close-dir dir)))))
 	  ((member :up)
 	   (%enumerate-directories (concatenate 'string head "../")
 				   (cdr tail) pathname verify-existance
@@ -549,16 +549,16 @@
 	(version (pathname-version pathname)))
     (cond ((null name)
 	   (when (or (not verify-existance)
-		     (mach:unix-file-kind directory))
+		     (unix:unix-file-kind directory))
 	     (funcall function directory)))
 	  ((or (pattern-p name)
 	       (pattern-p type)
 	       (eq version :wild))
-	   (let ((dir (mach:open-dir directory)))
+	   (let ((dir (unix:open-dir directory)))
 	     (when dir
 	       (unwind-protect
 		   (loop
-		     (let ((file (mach:read-dir dir)))
+		     (let ((file (unix:read-dir dir)))
 		       (if file
 			   (unless (or (string= file ".")
 				       (string= file ".."))
@@ -576,7 +576,7 @@
 						       directory
 						       file)))))
 			   (return))))
-		 (mach:close-dir dir)))))
+		 (unix:close-dir dir)))))
 	  (t
 	   (let ((file (concatenate 'string directory name)))
 	     (unless (or (null type) (eq type :unspecific))
@@ -585,7 +585,7 @@
 	       (setf file (concatenate 'string file "."
 				       (quick-integer-to-string version))))
 	     (when (or (not verify-existance)
-		       (mach:unix-file-kind file))
+		       (unix:unix-file-kind file))
 	       (funcall function file)))))))
 
 (defun quick-integer-to-string (n)
@@ -650,13 +650,13 @@
   "Return a pathname which is the truename of the file if it exists, NIL
   otherwise."
   (let ((namestring (unix-namestring pathname t)))
-    (when (and namestring (mach:unix-file-kind namestring))
-      (let ((truename (mach:unix-resolve-links
-		       (mach:unix-maybe-prepend-current-directory
+    (when (and namestring (unix:unix-file-kind namestring))
+      (let ((truename (unix:unix-resolve-links
+		       (unix:unix-maybe-prepend-current-directory
 			namestring))))
 	(when truename
 	  (let ((*ignore-wildcards* t))
-	    (pathname (mach:unix-simplify-pathname truename))))))))
+	    (pathname (unix:unix-simplify-pathname truename))))))))
 
 
 ;;;; Other random operations.
@@ -676,11 +676,11 @@
     (unless new-namestring
       (error "~S can't be created." new-name))
     (multiple-value-bind (res error)
-			 (mach:unix-rename original-namestring
+			 (unix:unix-rename original-namestring
 					   new-namestring)
       (unless res
 	(error "Failed to rename ~A to ~A: ~A"
-	       original new-name (mach:get-unix-error-msg error)))
+	       original new-name (unix:get-unix-error-msg error)))
       (when (streamp file)
 	(file-name file new-namestring))
       (values new-name original (truename new-name)))))
@@ -697,11 +697,11 @@
     (unless namestring
       (error "~S doesn't exist." file))
 
-    (multiple-value-bind (res err) (mach:unix-unlink namestring)
+    (multiple-value-bind (res err) (unix:unix-unlink namestring)
       (unless res
 	(error "Could not delete ~A: ~A."
 	       namestring
-	       (mach:get-unix-error-msg err)))))
+	       (unix:get-unix-error-msg err)))))
   t)
 
 
@@ -723,7 +723,7 @@
     (when name
       (multiple-value-bind
 	  (res dev ino mode nlink uid gid rdev size atime mtime)
-	  (mach:unix-stat name)
+	  (unix:unix-stat name)
 	(declare (ignore dev ino mode nlink uid gid rdev size atime))
 	(when res
 	  (+ unix-to-universal-time mtime))))))
@@ -737,7 +737,7 @@
     (unless name
       (error "~S doesn't exist." file))
     (multiple-value-bind (winp dev ino mode nlink uid)
-			 (mach:unix-stat file)
+			 (unix:unix-stat file)
       (declare (ignore dev ino mode nlink))
       (if winp (lookup-login-name uid)))))
 
@@ -772,7 +772,7 @@
     (let ((*ignore-wildcards* t))
       (mapcar #'(lambda (name)
 		  (let ((name (if (and check-for-subdirs
-				       (eq (mach:unix-file-kind name)
+				       (eq (unix:unix-file-kind name)
 					   :directory))
 				  (concatenate 'string name "/")
 				  name)))
@@ -810,7 +810,7 @@
 				   -1)))))
 	(multiple-value-bind 
 	    (reslt dev-or-err ino mode nlink uid gid rdev size atime mtime)
-	    (mach:unix-stat namestring)
+	    (unix:unix-stat namestring)
 	  (declare (ignore ino gid rdev atime)
 		   (fixnum uid mode))
 	  (cond (reslt
@@ -847,12 +847,12 @@
 			   size
 			   (decode-universal-time-for-files mtime year)
 			   tail
-			   (= (logand mode mach::s_ifmt) mach::s_ifdir))))
+			   (= (logand mode unix::s_ifmt) unix::s_ifdir))))
 		(t (format t "Couldn't stat ~A -- ~A.~%"
 			   tail
-			   (mach:get-unix-error-msg dev-or-err))))
+			   (unix:get-unix-error-msg dev-or-err))))
 	  (when return-list
-	    (push (if (= (logand mode mach::s_ifmt) mach::s_ifdir)
+	    (push (if (= (logand mode unix::s_ifmt) unix::s_ifdir)
 		      (pathname (concatenate 'string namestring "/"))
 		      file)
 		  result)))))
@@ -1086,15 +1086,15 @@
   (let ((name (unix-namestring name nil)))
     (cond ((null name)
 	   nil)
-	  ((mach:unix-file-kind name)
-	   (values (mach:unix-access name mach:w_ok)))
+	  ((unix:unix-file-kind name)
+	   (values (unix:unix-access name unix:w_ok)))
 	  (t
 	   (values
-	    (mach:unix-access (subseq name
+	    (unix:unix-access (subseq name
 				      0
 				      (or (position #\/ name :from-end t)
 					  0))
-			      (logior mach:w_ok mach:x_ok)))))))
+			      (logior unix:w_ok unix:x_ok)))))))
 
 
 ;;; Pathname-Order  --  Internal
@@ -1120,7 +1120,7 @@
   a file will be written if no directory is specified.  This may be changed
   with setf."
   (multiple-value-bind (gr dir-or-error)
-		       (mach:unix-current-directory)
+		       (unix:unix-current-directory)
     (if gr
 	(let ((*ignore-wildcards* t))
 	  (pathname (concatenate 'simple-string dir-or-error "/")))
@@ -1133,10 +1133,10 @@
     (unless namestring
       (error "~S doesn't exist." new-val))
     (multiple-value-bind (gr error)
-			 (mach:unix-chdir namestring)
+			 (unix:unix-chdir namestring)
       (if gr
 	  (setf (search-list "default:") (default-directory))
-	  (error (mach:get-unix-error-msg error))))
+	  (error (unix:get-unix-error-msg error))))
     new-val))
 ;;;
 (defsetf default-directory %set-default-directory)
diff --git a/code/float-trap.lisp b/code/float-trap.lisp
index b0c89f91da70140378d5dcace80a3211b5f8a9fc..4e54dbe0537fe58236193b5609931cd9820bfb6d 100644
--- a/code/float-trap.lisp
+++ b/code/float-trap.lisp
@@ -7,12 +7,10 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/float-trap.lisp,v 1.5 1991/02/08 13:32:45 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/float-trap.lisp,v 1.6 1992/02/14 23:46:17 wlott Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
-;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/float-trap.lisp,v 1.5 1991/02/08 13:32:45 ram Exp $
-;;;
 ;;;    This file contains stuff for controlling floating point traps.  It is
 ;;; IEEE float specific, but should work for pretty much any FPU where the
 ;;; state fits in one word and exceptions are represented by bits being set.
@@ -157,8 +155,10 @@
 ;;;    Signal the appropriate condition when we get a floating-point error.
 ;;;
 (defun sigfpe-handler (signal code scp)
-  (declare (ignore signal code))
-  (let* ((modes (sigcontext-floating-point-modes scp))
+  (declare (ignore signal code)
+	   (type system-area-pointer scp))
+  (let* ((modes (sigcontext-floating-point-modes
+		 (alien:sap-alien scp (* unix:sigcontext))))
 	 (traps (logand (ldb float-exceptions-byte modes)
 			(ldb float-traps-byte modes))))
     (cond ((not (zerop (logand float-divide-by-zero-trap-bit traps)))
diff --git a/code/foreign.lisp b/code/foreign.lisp
index f64cf7b6da2ed7a25bcf257ca200b563acc5d94a..3fa21ef342d4e1dbaacf28a60dc87de0e13bf5cb 100644
--- a/code/foreign.lisp
+++ b/code/foreign.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/foreign.lisp,v 1.7 1991/08/30 17:23:40 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/foreign.lisp,v 1.8 1992/02/14 23:44:54 wlott Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -24,18 +24,18 @@
 (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))))
+      (let ((name (format nil base (unix:unix-getpid) (code-char code))))
 	(multiple-value-bind
 	    (fd errno)
-	    (mach:unix-open name
-			    (logior mach:o_wronly mach:o_creat mach:o_excl)
+	    (unix:unix-open name
+			    (logior unix:o_wronly unix:o_creat unix:o_excl)
 			    #o666)
 	  (cond ((not (null fd))
-		 (mach:unix-close fd)
+		 (unix:unix-close fd)
 		 (return name))
-		((not (= errno mach:eexist))
+		((not (= errno unix:eexist))
 		 (error "Could not create temporary file ~S: ~A"
-			name (mach:get-unix-error-msg errno)))
+			name (unix:get-unix-error-msg errno)))
 		
 		((= code (char-code #\Z))
 		 (setf code (char-code #\a)))
@@ -45,15 +45,16 @@
 		 (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))
+(alien:def-alien-type exec
+  (alien:struct nil
+    (magic c-call:unsigned-long)
+    (text c-call:unsigned-long)
+    (data c-call:unsigned-long)
+    (bss c-call:unsigned-long)
+    (syms c-call:unsigned-long)
+    (entry c-call:unsigned-long)
+    (trsize c-call:unsigned-long)
+    (drsize c-call:unsigned-long)))
 
 (defun allocate-space-in-foreign-segment (bytes)
   (let* ((pagesize-1 (1- (get-page-size)))
@@ -69,45 +70,44 @@
 #+sparc
 (defun load-object-file (name)
   (format t ";;; Loading object file...~%")
-  (multiple-value-bind (fd errno) (mach:unix-open name mach:o_rdonly 0)
+  (multiple-value-bind (fd errno) (unix:unix-open name unix:o_rdonly 0)
     (unless fd
-      (error "Could not open ~S: ~A" name (mach:get-unix-error-msg errno)))
+      (error "Could not open ~S: ~A" name (unix: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)))
+	(alien:with-alien ((header exec))
+	  (unix:unix-read fd
+			  (alien:alien-sap header)
+			  (alien:alien-size exec :bytes))
 	  (let* ((len-of-text-and-data
-		  (+ (alien-access (exec-text (alien-value header)))
-		     (alien-access (exec-data (alien-value header)))))
+		  (+ (alien:slot header 'text) (alien:slot header 'data)))
 		 (memory-needed
-		  (+ len-of-text-and-data
-		     (alien-access (exec-bss (alien-value header)))))
+		  (+ len-of-text-and-data (alien:slot header 'bss)))
 		 (addr (allocate-space-in-foreign-segment memory-needed)))
-	    (mach:unix-read fd addr len-of-text-and-data)))
-      (mach:unix-close fd))))
+	    (unix:unix-read fd addr len-of-text-and-data)))
+      (unix: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))
+(alien:def-alien-type filehdr
+  (alien:struct nil
+    (magic c-call:unsigned-short)
+    (nscns c-call:unsigned-short)
+    (timdat c-call:long)
+    (symptr c-call:long)
+    (nsyms c-call:long)
+    (opthdr c-call:unsigned-short)
+    (flags c-call: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))
+(alien:def-alien-type aouthdr
+  (alien:struct nil
+    (magic c-call:short)
+    (vstamp c-call:short)
+    (tsize c-call:long)
+    (dsize c-call:long)
+    (bsize c-call:long)
+    (entry c-call:long)
+    (text_start c-call:long)
+    (data_start c-call:long)))
 
 #+pmax
 (defconstant filhsz 20)
@@ -119,42 +119,33 @@
 #+pmax
 (defun load-object-file (name)
   (format t ";;; Loading object file...~%")
-  (multiple-value-bind (fd errno) (mach:unix-open name mach:o_rdonly 0)
+  (multiple-value-bind (fd errno) (unix:unix-open name unix:o_rdonly 0)
     (unless fd
-      (error "Could not open ~S: ~A" name (mach:get-unix-error-msg errno)))
+      (error "Could not open ~S: ~A" name (unix: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))))
+	(alien:with-alien ((filehdr filehdr)
+			   (aouthdr aouthdr))
+	  (unix:unix-read fd
+			  (alien:alien-sap filehdr)
+			  (alien:alien-size filehdr :bytes))
+	  (unix:unix-read fd
+			  (alien:alien-sap aouthdr)
+			  (alien:alien-size aouthdr :bytes))
+	  (let* ((len-of-text-and-data
+		  (+ (alien:slot aouthdr 'tsize) (alien:slot aouthdr 'dsize)))
+		 (memory-needed
+		  (+ len-of-text-and-data (alien:slot aouthdr 'bsize)))
+		 (addr (allocate-space-in-foreign-segment memory-needed))
+		 (pad-size-1 (if (< (alien:slot aouthdr 'vstamp) 23) 7 15)))
+	    (unix:unix-lseek fd
+			     (logandc2 (+ filhsz aouthsz
+					  (* scnhsz
+					     (alien:slot filehdr 'nscns))
+					  pad-size-1)
+				       pad-size-1)
+			     unix:l_set)
+	    (unix:unix-read fd addr len-of-text-and-data)))
+      (unix:unix-close fd))))
 
 (defun parse-symbol-table (name)
   (format t ";;; Parsing symbol table...~%")
@@ -219,9 +210,9 @@
 	       linker (get-output-stream-string error-output)))
       (load-object-file output-file)
       (parse-symbol-table symbol-table-file)
-      (mach:unix-unlink symbol-table-file)
+      (unix: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)))))
+	  (unix:unix-unlink old-file)))))
   (format t ";;; Done.~%"))
diff --git a/code/gc.lisp b/code/gc.lisp
index 75656612834ecce4b72e8c7bb4acbf9631a60036..d63d1b8332b6ea1186250f4ce6b016bff57cc8df 100644
--- a/code/gc.lisp
+++ b/code/gc.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/gc.lisp,v 1.9 1991/11/07 12:37:17 wlott Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/gc.lisp,v 1.10 1992/02/14 23:44:56 wlott Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -33,9 +33,9 @@
 
 (macrolet ((frob (lisp-fun c-var-name)
 	     `(progn
-		(def-c-variable ,c-var-name (unsigned-byte 32))
+		(declaim (inline ,lisp-fun))
 		(defun ,lisp-fun ()
-		  (system:alien-access ,(intern (string-upcase c-var-name)))))))
+		  (alien:extern-alien ,c-var-name (alien:unsigned 32))))))
   (frob read-only-space-start "read_only_space")
   (frob static-space-start "static_space")
   (frob dynamic-0-space-start "dynamic_0_space")
@@ -269,12 +269,11 @@
 
 ;;;; Internal GC
 
-(def-c-routine ("collect_garbage" collect-garbage) (int))
+(alien:def-alien-routine collect-garbage c-call:int)
 
 #-ibmrt
-(def-c-routine ("set_auto_gc_trigger" set-auto-gc-trigger)
-	       (void)
-  (dynamic-usage unsigned-long))
+(alien:def-alien-routine set-auto-gc-trigger c-call:void
+  (dynamic-usage c-call:unsigned-long))
 
 #+ibmrt
 (defun set-auto-gc-trigger (bytes)
@@ -285,8 +284,7 @@
     (setf rt::*internal-gc-trigger* words)))
 
 #-ibmrt
-(def-c-routine ("clear_auto_gc_trigger" clear-auto-gc-trigger)
-	       (void))
+(alien:def-alien-routine clear-auto-gc-trigger c-call:void)
 
 #+ibmrt
 (defun clear-auto-gc-trigger ()
diff --git a/code/internet.lisp b/code/internet.lisp
index 1f81ac7b51ee007e3fdefca1c487cf0feec804b1..946e4bf5db3e21b237fb6bf2022ba734e50a5709 100644
--- a/code/internet.lisp
+++ b/code/internet.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/internet.lisp,v 1.6 1991/11/09 02:47:15 wlott Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/internet.lisp,v 1.7 1992/02/14 23:45:00 wlott Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -18,6 +18,9 @@
 
 (in-package "EXTENSIONS")
 
+(use-package "ALIEN")
+(use-package "C-CALL")
+
 (export '(htonl ntohl htons ntohs lookup-host-entry host-entry host-entry-name
 	  host-entry-aliases host-entry-addr-list host-entry-addr
 	  create-inet-socket connect-to-inet-socket create-inet-listener
@@ -85,187 +88,118 @@
   (declare (type host-entry host))
   (car (host-entry-addr-list host)))
 
-
-(def-c-pointer *char (null-terminated-string 256))
-(def-c-pointer *int int)
-(def-c-pointer *ulong unsigned-long)
-
-(def-c-record inet-sockaddr
-  (family short)
-  (port unsigned-short)
-  (addr unsigned-long)
-  (zero (unsigned-byte 64)))
-
-(def-c-record hostent
-  (name *char)
-  (aliases system-area-pointer)
-  (addrtype int)
-  (length int)
-  (addr-list system-area-pointer))
-
-(def-c-routine "gethostbyname" (*hostent)
-  (name null-terminated-string))
-
-(def-c-routine "gethostbyaddr" (*hostent)
-  (addr *ulong :copy)
+(def-alien-type inet-sockaddr
+  (struct nil
+    (family short)
+    (port unsigned-short)
+    (addr unsigned-long)
+    (zero (array char 8))))
+
+(def-alien-type hostent
+  (struct nil
+    (name c-string)
+    (aliases (* c-string))
+    (addrtype int)
+    (length int)
+    (addr-list (* (unsigned 32)))))
+
+(def-alien-routine "gethostbyname" (* hostent)
+  (name c-string))
+
+(def-alien-routine "gethostbyaddr" (* hostent)
+  (addr unsigned-long :copy)
   (len int)
   (type int))
 
-(def-c-routine ("socket" unix-socket) (int)
-  (domain int)
-  (type int)
-  (protocol int))
-
-(def-c-routine ("connect" unix-connect) (int)
-  (socket int)
-  (sockaddr system-area-pointer)
-  (len int))
-
-(def-c-routine ("bind" unix-bind) (int)
-  (socket int)
-  (sockaddr system-area-pointer)
-  (len int))
-
-(def-c-routine ("listen" unix-listen) (int)
-  (socket int)
-  (backlog int))
-
-(def-c-routine ("accept" unix-accept) (int)
-  (socket int)
-  (sockaddr system-area-pointer)
-  (len *int :in-out))
-
-
-(defmacro listify-c-array (array alien-type)
-  `(do* ((array ,array)
-	 (results nil
-		  (alien-bind ((alien
-				(make-alien ',alien-type
-					    ,(c-sizeof alien-type)
-					    sap)
-				,alien-type
-				t))
-		    (cons (alien-access alien)
-			  results)))
-	 (index 0 (1+ index))
-	 (sap (sap-ref-sap array index) (sap-ref-sap array index)))
-	((zerop (sap-int sap)) (nreverse results))))
+(defmacro listify-c-array (array)
+  `(do ((results nil (cons (deref ,array index) results))
+	(index 0 (1+ index)))
+       ((zerop (deref (cast ,array (* (unsigned 32))) index))
+	(nreverse results))))
 
 (defun lookup-host-entry (host)
   (if (typep host 'host-entry)
-    host
-    (let ((hostent
-	   (typecase host
-	     (string
-	      (gethostbyname host))
-	     ((unsigned-byte 32)
-	      (gethostbyaddr host 4 af-inet))
-	     (t
-	      (error "Invalid host ~S for ~S -- must be either a string ~
-	              or (unsigned-byte 32)"
-		     host 'lookup-host-entry)))))
-      (when hostent
-	(alien-bind ((alien hostent hostent t))
+      host
+      (with-alien
+	  ((hostent (* hostent) 
+		    (etypecase host
+		      (string
+		       (gethostbyname host))
+		      ((unsigned-byte 32)
+		       (gethostbyaddr host 4 af-inet)))))
+	(unless (zerop (sap-int (alien-sap hostent)))
 	  (make-host-entry
-	   :name (alien-access
-		  (indirect-*char (hostent-name (alien-value alien))))
-	   :aliases (listify-c-array
-		     (alien-access (hostent-aliases (alien-value alien)))
-		     (null-terminated-string 256))
-	   :addr-type (alien-access (hostent-addrtype (alien-value alien)))
-	   :addr-list (listify-c-array
-		       (alien-access (hostent-addr-list (alien-value alien)))
-		       (unsigned-byte 32))))))))
+	   :name (slot hostent 'name)
+	   :aliases (listify-c-array (slot hostent 'aliases))
+	   :addr-type (slot hostent 'addrtype)
+	   :addr-list (listify-c-array (slot hostent 'addr-list)))))))
 
 (defun create-inet-socket (&optional (kind :stream))
   (multiple-value-bind (proto type)
 		       (internet-protocol kind)
-    (let ((socket (unix-socket af-inet type proto)))
+    (let ((socket (unix:unix-socket af-inet type proto)))
       (when (minusp socket)
-	(error "Error creating socket: ~A" (get-unix-error-msg)))
+	(error "Error creating socket: ~A" (unix:get-unix-error-msg)))
       socket)))
 
 (defun connect-to-inet-socket (host port &optional (kind :stream))
   (let ((socket (create-inet-socket kind))
 	(hostent (or (lookup-host-entry host)
 		     (error "Unknown host: ~S." host))))
-    (with-stack-alien (sockaddr inet-sockaddr (c-sizeof 'inet-sockaddr))
-      (setf (alien-access (inet-sockaddr-family (alien-value sockaddr)))
-	    af-inet)
-      (setf (alien-access (inet-sockaddr-port (alien-value sockaddr)))
-	    (htons port))
-      (setf (alien-access (inet-sockaddr-addr (alien-value sockaddr)))
-	    (host-entry-addr hostent))
-      (when (minusp (unix-connect socket
-				  (alien-sap (alien-value sockaddr))
-				  #.(truncate (c-sizeof 'inet-sockaddr)
-					      (c-sizeof 'char))))
-	(unix-close socket)
+    (with-alien ((sockaddr inet-sockaddr))
+      (setf (slot sockaddr 'family) af-inet)
+      (setf (slot sockaddr 'port) (htons port))
+      (setf (slot sockaddr 'addr) (host-entry-addr hostent))
+      (when (minusp (unix:unix-connect socket
+				       (alien-sap sockaddr)
+				       (alien-size inet-sockaddr :bytes)))
+	(unix:unix-close socket)
 	(error "Error connecting socket to [~A:~A]: ~A"
 	       (host-entry-name hostent)
 	       port
-	       (get-unix-error-msg)))
+	       (unix:get-unix-error-msg)))
       socket)))
 
 (defun create-inet-listener (port &optional (kind :stream))
   (let ((socket (create-inet-socket kind)))
-    (with-stack-alien (sockaddr inet-sockaddr (c-sizeof 'inet-sockaddr))
-      (setf (alien-access (inet-sockaddr-family (alien-value sockaddr)))
-	    af-inet)
-      (setf (alien-access (inet-sockaddr-port (alien-value sockaddr)))
-	    (htons port))
-      (setf (alien-access (inet-sockaddr-addr (alien-value sockaddr)))
-	    0)
-      (when (minusp (unix-bind socket
-			       (alien-sap (alien-value sockaddr))
-			       #.(truncate (c-sizeof 'inet-sockaddr)
-					   (c-sizeof 'char))))
-	(unix-close socket)
+    (with-alien ((sockaddr inet-sockaddr))
+      (setf (slot sockaddr 'family) af-inet)
+      (setf (slot sockaddr 'port) (htons port))
+      (setf (slot sockaddr 'addr) 0)
+      (when (minusp (unix:unix-bind socket
+				    (alien-sap sockaddr)
+				    (alien-size inet-sockaddr :bytes)))
+	(unix:unix-close socket)
 	(error "Error binding socket to port ~a: ~a"
 	       port
-	       (get-unix-error-msg))))
+	       (unix:get-unix-error-msg))))
     (when (eq kind :stream)
-      (when (minusp (unix-listen socket 5))
-	(unix-close socket)
-	(error "Error listening to socket: ~A" (get-unix-error-msg))))
+      (when (minusp (unix:unix-listen socket 5))
+	(unix:unix-close socket)
+	(error "Error listening to socket: ~A" (unix:get-unix-error-msg))))
     socket))
 
 (defun accept-tcp-connection (unconnected)
   (declare (fixnum unconnected))
-  (with-stack-alien (sockaddr inet-sockaddr (c-sizeof 'inet-sockaddr))
-    (let ((connected (unix-accept unconnected
-				  (alien-sap (alien-value sockaddr))
-				  #.(truncate (c-sizeof 'inet-sockaddr)
-					      (c-sizeof 'char)))))
+  (with-alien ((sockaddr inet-sockaddr))
+    (let ((connected (unix:unix-accept unconnected
+				       (alien-sap sockaddr)
+				       (alien-size inet-sockaddr :bytes))))
       (when (minusp connected)
-	(error "Error accepting a connection: ~A" (get-unix-error-msg)))
-      (values connected
-	      (alien-access (inet-sockaddr-addr (alien-value sockaddr)))))))
+	(error "Error accepting a connection: ~A" (unix:get-unix-error-msg)))
+      (values connected (slot sockaddr 'addr)))))
 
 (defun close-socket (socket)
   (multiple-value-bind (ok err)
-		       (unix-close socket)
+		       (unix:unix-close socket)
     (unless ok
-      (error "Error closing socket: ~A" (get-unix-error-msg err))))
+      (error "Error closing socket: ~A" (unix:get-unix-error-msg err))))
   (undefined-value))
 
 
 
 ;;;; Out of Band Data.
 
-(def-c-routine ("recv" unix-recv) (int)
-  (fd int)
-  (buffer null-terminated-string)
-  (length int)
-  (flags int))
-
-(def-c-routine ("send" unix-send) (int)
-  (fd int)
-  (buffer null-terminated-string)
-  (length int)
-  (flags int))
-
-
 ;;; Two level AList. First levels key is the file descriptor, second levels
 ;;; key is the character. The datum is the handler to call.
 
@@ -284,11 +218,11 @@
     (declare (simple-string buffer))
     (dolist (handlers *oob-handlers*)
       (declare (list handlers))
-      (cond ((minusp (mach:unix-recv (car handlers) buffer 1 msg-oob))
+      (cond ((minusp (unix:unix-recv (car handlers) buffer 1 msg-oob))
 	     (cerror "Ignore it"
 		     "Error recving oob data on ~A: ~A"
 		     (car handlers)
-		     (mach:get-unix-error-msg)))
+		     (unix:get-unix-error-msg)))
 	    (t
 	     (setf handled t)
 	     (let ((char (schar buffer 0))
@@ -332,7 +266,7 @@
 			     handler))
 		 *oob-handlers*)
 	   (system:enable-interrupt mach:sigurg #'sigurg-handler)
-	   (mach:unix-fcntl fd mach::f-setown (mach:unix-getpid)))))
+	   (unix:unix-fcntl fd unix:f-setown (unix:unix-getpid)))))
   (values))
 
 ;;; REMOVE-OOB-HANDLER -- public
@@ -382,8 +316,8 @@
 	   (base-char char))
   (let ((buffer (make-string 1 :initial-element char)))
     (declare (simple-string buffer))
-    (when (minusp (mach:unix-send fd buffer 1 msg-oob))
+    (when (minusp (unix:unix-send fd buffer 1 msg-oob))
       (error "Error sending ~S OOB to across ~A: ~A"
 	     char
 	     fd
-	     (mach:get-unix-error-msg)))))
+	     (unix:get-unix-error-msg)))))
diff --git a/code/interr.lisp b/code/interr.lisp
index c772437b4c3293bd1f62b5410b25d333a6e32f7e..a1fc24e0d3a450405f829e30ec45a754803a109c 100644
--- a/code/interr.lisp
+++ b/code/interr.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/interr.lisp,v 1.21 1992/01/21 23:41:15 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/interr.lisp,v 1.22 1992/02/14 23:45:02 wlott Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -110,7 +110,6 @@
     `(%deferr ',name
 	      ,(meta-error-number name)
 	      ,description
-	      #+new-compiler
 	      #'(lambda (name ,fp ,sigcontext ,sc-offsets)
 		  (declare (ignorable name ,fp ,sigcontext ,sc-offsets))
 		  (macrolet ((set-value (var value)
@@ -144,7 +143,7 @@
 
 ) ; Eval-When (Compile Eval)
 
-(defun %deferr (name number description #+new-compiler function)
+(defun %deferr (name number description function)
   (when (>= number (length *internal-errors*))
     (setf *internal-errors*
 	  (replace (make-array (+ number 10) :initial-element nil)
@@ -152,7 +151,7 @@
   (setf (svref *internal-errors* number)
 	(make-error-info :name name
 			 :description description
-			 #+new-compiler :function #+new-compiler function))
+			 :function function))
   name)
 
 
@@ -682,49 +681,40 @@
 ;;;; internal-error signal handler.
 
 (defun internal-error (scp continuable)
-  (declare (ignore continuable))
+  (declare (type system-area-pointer scp) (ignore continuable))
   (infinite-error-protect
-    (alien-bind ((sc (make-alien 'mach:sigcontext
-				 #.(c-sizeof 'mach:sigcontext)
-				 scp)
-		     mach:sigcontext
-		     t))
-      (multiple-value-bind
-	  (error-number arguments)
-	  (vm:internal-error-arguments (alien-value sc))
-	(let ((fp (int-sap (di::escape-register (alien-value sc)
-						vm::cfp-offset)))
-	      (name (find-interrupted-name))
-	      (info (and (< -1 error-number (length *internal-errors*))
-			 (svref *internal-errors* error-number))))
-	  (cond ((null info)
-		 (error 'simple-error
-			:function-name name
-			:format-string
-			"Unknown internal error, ~D?  args=~S"
-			:format-arguments
-			(list error-number
-			      (mapcar #'(lambda (sc-offset)
-					  (di::sub-access-debug-var-slot
-					   fp
-					   sc-offset
-					   (alien-value sc)))
-				      arguments))))
-		((null (error-info-function info))
-		 (error 'simple-error
-			:function-name name
-			:format-string
-			"Internal error ~D: ~A.  args=~S"
-			:format-arguments
-			(list error-number
-			      (error-info-description info)
-			      (mapcar #'(lambda (sc-offset)
-					  (di::sub-access-debug-var-slot
-					   fp
-					   sc-offset
-					   (alien-value sc)))
-				      arguments))))
+   (let ((scp (alien:sap-alien scp (* unix:sigcontext))))
+     (multiple-value-bind
+	 (error-number arguments)
+	 (vm:internal-error-arguments scp)
+       (let ((fp (int-sap (vm:sigcontext-register scp vm::cfp-offset)))
+	     (name (find-interrupted-name))
+	     (info (and (< -1 error-number (length *internal-errors*))
+			(svref *internal-errors* error-number))))
+	 (cond ((null info)
+		(error 'simple-error
+		       :function-name name
+		       :format-string
+		       "Unknown internal error, ~D?  args=~S"
+		       :format-arguments
+		       (list error-number
+			     (mapcar #'(lambda (sc-offset)
+					 (di::sub-access-debug-var-slot
+					  fp sc-offset scp))
+				     arguments))))
+	       ((null (error-info-function info))
+		(error 'simple-error
+		       :function-name name
+		       :format-string
+		       "Internal error ~D: ~A.  args=~S"
+		       :format-arguments
+		       (list error-number
+			     (error-info-description info)
+			     (mapcar #'(lambda (sc-offset)
+					 (di::sub-access-debug-var-slot
+					  fp sc-offset scp))
+				     arguments))))
 		(t
-		 (funcall (error-info-function info) name fp sc
+		 (funcall (error-info-function info) name fp scp
 			  arguments))))))))
 
diff --git a/code/irrat.lisp b/code/irrat.lisp
index e14553970270dd41bfaa47f3eb8633e4aed50b98..9cdf62582e6613e2fe89d7f30d5c879ceb00db9e 100644
--- a/code/irrat.lisp
+++ b/code/irrat.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/irrat.lisp,v 1.9 1991/10/25 20:02:07 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/irrat.lisp,v 1.10 1992/02/14 23:45:06 wlott Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -35,7 +35,7 @@
     `(progn
        (proclaim '(inline ,function))
        (export ',function)
-       (def-c-routine (,name ,function) (double-float)
+       (alien:def-alien-routine (,name ,function) double-float
 	 ,@(let ((results nil))
 	     (dotimes (i num-args (nreverse results))
 	       (push (list (intern (format nil "ARG-~D" i))
diff --git a/code/lispinit.lisp b/code/lispinit.lisp
index 6f4a3a7c396c4abf3feeec77e9659e35f8b2b746..008f04fe13a549fae5bec13aa3310d3062ad0cca 100644
--- a/code/lispinit.lisp
+++ b/code/lispinit.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/lispinit.lisp,v 1.27 1992/01/21 17:25:39 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/lispinit.lisp,v 1.28 1992/02/14 23:45:11 wlott Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -64,8 +64,8 @@
 (proclaim '(special *gc-inhibit* *already-maybe-gcing*
 		    *need-to-collect-garbage* *gc-verbose*
 		    *before-gc-hooks* *after-gc-hooks*
-		    mach::*interrupts-enabled*
-		    mach::*interrupt-pending*
+		    unix::*interrupts-enabled*
+		    unix::*interrupt-pending*
 		    c::*type-system-initialized*))
 
 
@@ -479,8 +479,6 @@
        (%primitive print ,(symbol-name name))
        (,name))))
 
-(def-c-variable "internal_errors_enabled" boolean)
-
 (defun %initial-function ()
   "Gives the world a shove and hopes it spins."
   (setf *already-maybe-gcing* t)
@@ -489,8 +487,8 @@
   (setf *gc-verbose* t)
   (setf *before-gc-hooks* nil)
   (setf *after-gc-hooks* nil)
-  (setf mach::*interrupts-enabled* t)
-  (setf mach::*interrupt-pending* nil)
+  (setf unix::*interrupts-enabled* t)
+  (setf unix::*interrupt-pending* nil)
   (setf c::*type-system-initialized* nil)
   (%primitive print "In initial-function, and running.")
 
@@ -544,7 +542,7 @@
   (print-and-call loader-init)
   (print-and-call package-init)
   (print-and-call kernel::signal-init)
-  (setf (alien-access (alien-value internal_errors_enabled)) t)
+  (setf (alien:extern-alien "internal_errors_enabled" alien:boolean) t)
   (set-floating-point-modes :traps '(:overflow :underflow :invalid
 					       :divide-by-zero))
 
@@ -562,7 +560,7 @@
     (loop
      (%top-level)
      (write-line "You're certainly a clever child.")))
-  (mach:unix-exit 0))
+  (unix:unix-exit 0))
 
 
 ;;;; Initialization functions:
@@ -577,7 +575,7 @@
    (os-init)
    (stream-reinit)
    (kernel::signal-init)
-   (setf (alien-access (alien-value internal_errors_enabled)) t)
+   (setf (alien:extern-alien "internal_errors_enabled" alien:boolean) t)
    (setf *already-maybe-gcing* nil))
   (set-floating-point-modes :traps '(:overflow :underflow :invalid
 					       :divide-by-zero))
@@ -604,7 +602,7 @@
   "Terminates the current Lisp.  Things are cleaned up unless Recklessly-P is
   non-Nil."
   (if recklessly-p
-      (mach:unix-exit 0)
+      (unix:unix-exit 0)
       (throw '%end-of-the-world nil)))
 
 
@@ -621,7 +619,7 @@
 			   (values n 0)
 			   (values (truncate n)
 				   (truncate (* n 1000000))))
-    (mach:unix-select 0 0 0 0 sec usec))
+    (unix:unix-select 0 0 0 0 sec usec))
   nil)
 
 
@@ -723,7 +721,7 @@
     (loop
       (with-simple-restart (abort "Return to Top-Level.")
 	(catch 'top-level-catcher
-	  (mach:unix-sigsetmask 0)
+	  (unix:unix-sigsetmask 0)
 	  (let ((*in-top-level-catcher* t))
 	    (loop
 	      (scrub-control-stack)
diff --git a/code/mach-os.lisp b/code/mach-os.lisp
index e3724839e9d555e96e169d24f9d38638f471762a..0464121d98743ec077c234a9dc7532227ee759f7 100644
--- a/code/mach-os.lisp
+++ b/code/mach-os.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/mach-os.lisp,v 1.2 1991/09/04 13:30:27 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/mach-os.lisp,v 1.3 1992/02/14 23:45:15 wlott Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -40,21 +40,20 @@
 ;;; interesting number than the total faults.
 ;;;
 (defun get-system-info ()
-  (let (run-utime run-stime page-faults)
-    (multiple-value-bind (err? utime stime maxrss ixrss idrss
-                               isrss minflt majflt)
-        (mach:unix-getrusage mach:rusage_self)
-      (declare (ignore maxrss ixrss idrss isrss minflt))
-      (unless err?
-	(error "Unix system call getrusage failed: ~A."
-	       (mach:get-unix-error-msg utime)))
-
-      (multiple-value-bind (gr ps fc ac ic wc zf ra in ot)
-			   (mach:vm_statistics *task-self*)
-	(declare (ignore ps fc ac ic wc zf ra))
-	(gr-error 'mach:vm_statistics gr)
-	
-	(values utime stime (+ in ot))))))
+  (multiple-value-bind (err? utime stime maxrss ixrss idrss
+			     isrss minflt majflt)
+		       (unix:unix-getrusage mach:rusage_self)
+    (declare (ignore maxrss ixrss idrss isrss minflt majflt))
+    (unless err?
+      (error "Unix system call getrusage failed: ~A."
+	     (unix:get-unix-error-msg utime)))
+    
+    (multiple-value-bind (gr ps fc ac ic wc zf ra in ot)
+			 (mach:vm_statistics *task-self*)
+      (declare (ignore ps fc ac ic wc zf ra))
+      (gr-error 'mach:vm_statistics gr)
+      
+      (values utime stime (+ in ot)))))
 
 
 ;;; GET-PAGE-SIZE  --  Interface
@@ -63,3 +62,4 @@
 ;;;
 (defun get-page-size ()
   (gr-call* mach:vm_statistics *task-self*))
+
diff --git a/code/misc.lisp b/code/misc.lisp
index 990206c0e7a6b9dc07d7941ebecdbe0fde10151d..67e2971713320207c7d083a0bd0a1868bd3e408f 100644
--- a/code/misc.lisp
+++ b/code/misc.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/misc.lisp,v 1.13 1992/01/17 16:11:49 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/misc.lisp,v 1.14 1992/02/14 23:45:17 wlott Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -62,7 +62,7 @@
 		 (info random-documentation stuff name))))))
   string)
 
-(defvar *features* '(:common :cmu :new-compiler :unix)
+(defvar *features* '(:common :cmu :new-compiler)
   "Holds a list of symbols that describe features provided by the
    implementation.")
 
@@ -91,7 +91,7 @@
 
 (defun machine-instance ()
   "Returns a string giving the name of the local machine."
-  (mach::unix-gethostname))
+  (unix:unix-gethostname))
 
 (defvar *software-type* "Unix"
   "The value of SOFTWARE-TYPE.  Set in FOO-os.lisp.")
diff --git a/code/pmax-vm.lisp b/code/pmax-vm.lisp
index cbf2c1de27b7230de901a0d36f6880e61094f75e..462122bc771a70b03e75f31c90d883d722bfccbc 100644
--- a/code/pmax-vm.lisp
+++ b/code/pmax-vm.lisp
@@ -7,18 +7,43 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/pmax-vm.lisp,v 1.7 1991/02/08 13:34:42 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/pmax-vm.lisp,v 1.8 1992/02/14 23:45:18 wlott Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
-;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/pmax-vm.lisp,v 1.7 1991/02/08 13:34:42 ram Exp $
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/pmax-vm.lisp,v 1.8 1992/02/14 23:45:18 wlott Exp $
 ;;;
 ;;; This file contains the PMAX specific runtime stuff.
 ;;;
 (in-package "MIPS")
 (use-package "SYSTEM")
+(use-package "ALIEN")
+(use-package "C-CALL")
+(use-package "UNIX")
+
+(export '(fixup-code-object internal-error-arguments
+	  sigcontext-register sigcontext-float-register
+	  sigcontext-floating-point-modes))
+
+
+;;;; The sigcontext structure.
+
+(def-alien-type sigcontext
+  (struct nil
+    (sc-onstack unsigned-long)
+    (sc-mask unsigned-long)
+    (sc-pc system-area-pointer)
+    (sc-regs (array unsigned-long 32))
+    (sc-mdlo unsigned-long)
+    (sc-mdhi unsigned-long)
+    (sc-ownedfp unsigned-long)
+    (sc-fpregs (array unsigned-long 32))
+    (sc-fpc-csr unsigned-long)
+    (sc-fpc-eir unsigned-long)
+    (sc-cause unsigned-long)
+    (sc-badvaddr system-area-pointer)
+    (sc-badpaddr system-area-pointer)))
 
-(export '(fixup-code-object internal-error-arguments))
 
 
 ;;;; Add machine specific features to *features*
@@ -63,8 +88,6 @@
 	  (setf (sap-ref-16 sap (* word-offset 2))
 		(ldb (byte 16 0) fixup))))))))
 
-
-
 
 ;;;; Internal-error-arguments.
 
@@ -73,12 +96,12 @@
 ;;; Given the sigcontext, extract the internal error arguments from the
 ;;; instruction stream.
 ;;; 
-(defun internal-error-arguments (sc)
-  (alien-bind ((sc sc mach:sigcontext t))
-    (let ((pc (alien-access (mach:sigcontext-pc (alien-value sc)))))
+(defun internal-error-arguments (scp)
+  (declare (type (alien (* sigcontext)) scp))
+  (with-alien ((scp (* sigcontext) scp))
+    (let ((pc (slot scp 'sc-pc)))
       (declare (type system-area-pointer pc))
-      (when (logbitp 31
-		     (alien-access (mach:sigcontext-cause (alien-value sc))))
+      (when (logbitp 31 (slot scp 'sc-cause))
 	(setf pc (sap+ pc 4)))
       (when (= (sap-ref-8 pc 4) 255)
 	(setf pc (sap+ pc 1)))
@@ -100,15 +123,59 @@
 	    (values error-number (sc-offsets))))))))
 
 
+;;;; Sigcontext access functions.
+
+;;; SIGCONTEXT-REGISTER -- Internal.
+;;;
+;;; An escape register saves the value of a register for a frame that someone
+;;; interrupts.  
+;;;
+(defun sigcontext-register (scp index)
+  (declare (type (alien (* sigcontext)) scp))
+  (with-alien ((scp (* sigcontext) scp))
+    (deref (slot scp 'sc-regs) index)))
+
+(defun %set-sigcontext-register (scp index new)
+  (declare (type (alien (* sigcontext)) scp))
+  (with-alien ((scp (* sigcontext) scp))
+    (setf (deref (slot scp 'sc-regs) index) new)
+    new))
+
+(defsetf sigcontext-register %set-sigcontext-register)
+
+
+;;; SIGCONTEXT-FLOAT-REGISTER  --  Internal
+;;;
+;;; Like SIGCONTEXT-REGISTER, but returns the value of a float register.
+;;; Format is the type of float to return.
+;;;
+(defun sigcontext-float-register (scp index format)
+  (declare (type (alien (* sigcontext)) scp))
+  (with-alien ((scp (* sigcontext) scp))
+    (let ((sap (alien-sap (slot scp 'sc-fpregs))))
+      (ecase format
+	(single-float (system:sap-ref-single sap index))
+	(double-float (system:sap-ref-double sap index))))))
+;;;
+(defun %set-sigcontext-float-register (scp index format new-value)
+  (declare (type (alien (* sigcontext)) scp))
+  (with-alien ((scp (* sigcontext) scp))
+    (let ((sap (alien-sap (slot scp 'sc-fpregs))))
+      (ecase format
+	(single-float
+	 (setf (sap-ref-single sap index) new-value))
+	(double-float
+	 (setf (sap-ref-double sap index) new-value))))))
+;;;
+(defsetf sigcontext-float-register %set-sigcontext-float-register)
+
+
 ;;; SIGCONTEXT-FLOATING-POINT-MODES  --  Interface
 ;;;
 ;;;    Given a sigcontext pointer, return the floating point modes word in the
 ;;; same format as returned by FLOATING-POINT-MODES.
 ;;;
 (defun sigcontext-floating-point-modes (scp)
-  (alien-bind ((sc (make-alien 'mach:sigcontext
-					     #.(ext:c-sizeof 'mach:sigcontext)
-					     scp)
-			  mach:sigcontext
-			  t))
-    (alien-access (mach:sigcontext-fpc_csr (alien-value sc)))))
+  (declare (type (alien (* sigcontext)) scp))
+   (with-alien ((scp (* sigcontext) scp))
+    (slot scp 'sc-fpc-csr)))
diff --git a/code/pred.lisp b/code/pred.lisp
index dd0c224a1b9b48a003433da8c1379494274430a4..eee39aeacc478a226629c27e60758dba60720844 100644
--- a/code/pred.lisp
+++ b/code/pred.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/pred.lisp,v 1.22 1992/02/07 12:36:55 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/pred.lisp,v 1.23 1992/02/14 23:45:20 wlott Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -320,6 +320,8 @@
 			 object)
 		t
 		nil))))))
+    (alien-type-type
+     (alien-internals:alien-typep object (alien-type-type-alien-type type)))
     (function-type
      (error "Function types are not a legal argument to TYPEP:~%  ~S"
 	    (type-specifier type)))))
diff --git a/code/purify.lisp b/code/purify.lisp
index 1f4d17a69aff87c98a1962b8d7206924cbf8b379..28a5daca8a4b990a14e0a57103c1b571f0edab0a 100644
--- a/code/purify.lisp
+++ b/code/purify.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/purify.lisp,v 1.11 1991/02/08 13:35:00 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/purify.lisp,v 1.12 1992/02/14 23:45:24 wlott Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -18,17 +18,17 @@
 ;;;
 (in-package 'lisp)
 
-(def-c-routine ("purify" %purify) (void)
-  (static-roots unsigned-long)
-  (read-only-roots unsigned-long))
+(alien:def-alien-routine ("purify" %purify) c-call:void
+  (static-roots c-call:unsigned-long)
+  (read-only-roots c-call:unsigned-long))
 
 (defun purify (&key root-structures constants)
   (write-string "[Doing purification: ")
   (force-output)
   (without-gcing
    (clear-auto-gc-trigger)
-   (%purify (di::get-lisp-obj-address root-structures)
-	    (di::get-lisp-obj-address constants))
+   (%purify (get-lisp-obj-address root-structures)
+	    (get-lisp-obj-address constants))
    (when *gc-trigger*
      (setf *gc-trigger* *bytes-consed-between-gcs*)
      (set-auto-gc-trigger *gc-trigger*)))
diff --git a/code/run-program.lisp b/code/run-program.lisp
index 6f8842b266b269678b3c891964e8c95efd03b4b4..e063647394ad06af81f3c06497fcc44f5c4d0b7e 100644
--- a/code/run-program.lisp
+++ b/code/run-program.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/run-program.lisp,v 1.7 1991/09/27 10:24:58 wlott Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/run-program.lisp,v 1.8 1992/02/14 23:45:25 wlott Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -30,13 +30,10 @@
 
 ;;;; Import WAIT3 from unix.
 
-(ext:def-c-pointer *wait (unsigned-byte 32))
-
-(ext:def-c-routine ("wait3" c-wait3)
-		   (int)
-    (status *wait :out)
-    (options int)
-    (rusage int))
+(alien:def-alien-routine ("wait3" c-wait3) c-call:int
+  (status c-call:int :out)
+  (options c-call:int)
+  (rusage c-call:int))
 
 (eval-when (load eval compile)
   (defconstant wait-wstopped #o177)
@@ -68,10 +65,10 @@
 	  (t
 	   (let ((signal (ldb (byte 7 0) status)))
 	     (values pid
-		     (if (or (eql signal mach:sigstop)
-			     (eql signal mach:sigtstp)
-			     (eql signal mach:sigttin)
-			     (eql signal mach:sigttou))
+		     (if (or (eql signal unix:sigstop)
+			     (eql signal unix:sigtstp)
+			     (eql signal unix:sigttin)
+			     (eql signal unix:sigttou))
 		       :stopped
 		       :signaled)
 		     signal
@@ -135,16 +132,16 @@
 ;;; Finds the current foreground process group id.
 ;;; 
 (defun find-current-foreground-process (proc)
-  (system:with-stack-alien (result (unsigned-byte 32) (long-words 1))
+  (alien:with-alien ((result c-call:int))
     (multiple-value-bind
 	(wonp error)
-	(mach:unix-ioctl (system:fd-stream-fd (ext:process-pty proc))
-			 mach:TIOCGPGRP
-			 (system:alien-sap (system:alien-value result)))
+	(unix:unix-ioctl (system:fd-stream-fd (ext:process-pty proc))
+			 unix:TIOCGPGRP
+			 (alien:alien-sap (alien:addr result)))
       (unless wonp
 	(error "TIOCPGRP ioctl failed: ~S"
-	       (mach:get-unix-error-msg error)))
-      (system:alien-access (system:alien-value result)))))
+	       (unix:get-unix-error-msg error)))
+      result)))
 
 ;;; PROCESS-KILL -- public
 ;;;
@@ -162,12 +159,12 @@
 		(find-current-foreground-process proc)))))
     (multiple-value-bind (okay errno)
 			 (if (eq whom :pty-process-group)
-			   (mach:unix-killpg pid signal)
-			   (mach:unix-kill pid signal))
+			   (unix:unix-killpg pid signal)
+			   (unix:unix-kill pid signal))
       (cond ((not okay)
 	     (values nil errno))
 	    ((and (eql pid (process-pid proc))
-		  (= (unix-signal-number signal) mach:sigcont))
+		  (= (unix-signal-number signal) unix:sigcont))
 	     (setf (process-%status proc) :running)
 	     (setf (process-exit-code proc) nil)
 	     (when (process-status-hook proc)
@@ -256,38 +253,31 @@
   (dolist (char '(#\p #\q))
     (dotimes (digit 16)
       (let* ((master-name (format nil "/dev/pty~C~X" char digit))
-	     (master-fd (mach:unix-open master-name
-					mach:o_rdwr
+	     (master-fd (unix:unix-open master-name
+					unix:o_rdwr
 					#o666)))
 	(when master-fd
 	  (let* ((slave-name (format nil "/dev/tty~C~X" char digit))
-		 (slave-fd (mach:unix-open slave-name
-					   mach:o_rdwr
+		 (slave-fd (unix:unix-open slave-name
+					   unix:o_rdwr
 					   #o666)))
 	    (when slave-fd
 	      ; Maybe put a vhangup here?
-	      (with-stack-alien (stuff mach:sgtty (record-size 'mach:sgtty))
-		(let ((sap (system:alien-sap (system:alien-value stuff))))
-		  (mach:unix-ioctl slave-fd mach:TIOCGETP sap)
-		  (setf (system:alien-access
-			 (mach::sgtty-flags
-			  (system:alien-value stuff)))
-			#o300) ; EVENP|ODDP
-		  (mach:unix-ioctl slave-fd mach:TIOCSETP sap)
-		  (mach:unix-ioctl master-fd mach:TIOCGETP sap)
-		  (setf (system:alien-access
-			 (mach::sgtty-flags
-			  (system:alien-value stuff)))
-			(logand (system:alien-access
-				 (mach::sgtty-flags
-				  (system:alien-value stuff)))
+	      (alien:with-alien ((stuff (alien:struct unix:sgttyb)))
+		(let ((sap (alien:alien-sap stuff)))
+		  (unix:unix-ioctl slave-fd unix:TIOCGETP sap)
+		  (setf (alien:slot stuff 'unix:sg-flags) #o300) ; EVENP|ODDP
+		  (unix:unix-ioctl slave-fd unix:TIOCSETP sap)
+		  (unix:unix-ioctl master-fd unix:TIOCGETP sap)
+		  (setf (alien:slot stuff 'unix:sg-flags)
+			(logand (alien:slot stuff 'unix:sg-flags)
 				(lognot 8))) ; ~ECHO
-		  (mach:unix-ioctl master-fd mach:TIOCSETP sap)))
+		  (unix:unix-ioctl master-fd unix:TIOCSETP sap)))
 	      (return-from find-a-pty
 			   (values master-fd
 				   slave-fd
 				   slave-name)))
-	  (mach:unix-close master-fd))))))
+	  (unix:unix-close master-fd))))))
   (error "Could not find a pty."))
 
 ;;; OPEN-PTY -- internal
@@ -300,10 +290,10 @@
       (push master *close-on-error*)
       (push slave *close-in-parent*)
       (when (streamp pty)
-	(multiple-value-bind (won new-fd) (mach:unix-dup master)
+	(multiple-value-bind (won new-fd) (unix:unix-dup master)
 	  (unless won
-	    (error "Could not MACH:UNIX-DUP ~D: ~A"
-		   master (mach:get-unix-error-msg new-fd)))
+	    (error "Could not UNIX:UNIX-DUP ~D: ~A"
+		   master (unix:get-unix-error-msg new-fd)))
 	  (push new-fd *close-on-error*)
 	  (copy-descriptor-to-stream new-fd pty cookie)))
       (values name
@@ -318,45 +308,45 @@
   (unwind-protect
       (handler-bind ((error #'(lambda (condition)
 				(declare (ignore condition))
-				(mach:unix-exit 2))))
+				(unix:unix-exit 2))))
 	;; Put us in our own pgrp.
-	(mach:unix-setpgrp 0 (mach:unix-getpid))
+	(unix:unix-setpgrp 0 (unix:unix-getpid))
 	;; If we want a pty, set it up.
 	(when pty-name
-	  (let ((old-tty (mach:unix-open "/dev/tty" mach:o_rdwr 0)))
+	  (let ((old-tty (unix:unix-open "/dev/tty" unix:o_rdwr 0)))
 	    (when old-tty
-	      (mach:unix-ioctl old-tty mach:TIOCNOTTY 0)
-	      (mach:unix-close old-tty)))
-	  (let ((new-tty (mach:unix-open pty-name mach:o_rdwr 0)))
+	      (unix:unix-ioctl old-tty unix:TIOCNOTTY 0)
+	      (unix:unix-close old-tty)))
+	  (let ((new-tty (unix:unix-open pty-name unix:o_rdwr 0)))
 	    (when new-tty
-	      (mach:unix-dup2 new-tty 0)
-	      (mach:unix-dup2 new-tty 1)
-	      (mach:unix-dup2 new-tty 2))))
+	      (unix:unix-dup2 new-tty 0)
+	      (unix:unix-dup2 new-tty 1)
+	      (unix:unix-dup2 new-tty 2))))
 	;; Setup the three standard descriptors.
 	(when stdin
-	  (mach:unix-dup2 stdin 0))
+	  (unix:unix-dup2 stdin 0))
 	(when stdout
-	  (mach:unix-dup2 stdout 1))
+	  (unix:unix-dup2 stdout 1))
 	(when stderr
-	  (mach:unix-dup2 stderr 2))
+	  (unix:unix-dup2 stderr 2))
 	;; Arange for all the unused FD's to be closed.
-	(do ((fd (1- (mach:unix-getdtablesize))
+	(do ((fd (1- (unix:unix-getdtablesize))
 		 (1- fd)))
 	    ((= fd 3))
-	  (mach:unix-fcntl fd mach:f-setfd 1))
+	  (unix:unix-fcntl fd unix:f-setfd 1))
 	;; Do the before-execve
 	(when before-execve
 	  (funcall before-execve))
 	;; Exec the program
 	(multiple-value-bind
 	    (okay errno)
-	    (mach:unix-execve pfile args env)
+	    (unix:unix-execve pfile args env)
 	  (declare (ignore okay))
 	  ;; If the magic number if bogus, try just a shell script.
-	  (when (eql errno mach:ENOEXEC)
-	    (mach:unix-execve "/bin/sh" (cons pfile args) env))))
+	  (when (eql errno unix:ENOEXEC)
+	    (unix:unix-execve "/bin/sh" (cons pfile args) env))))
     ;; If exec returns, we lose.
-    (mach:unix-exit 1)))
+    (unix:unix-exit 1)))
 
 ;;; RUN-PROGRAM -- public
 ;;;
@@ -456,7 +446,7 @@
         process just before turning it into the specified program."
 
   ;; Make sure the interrupt handler is installed.
-  (system:enable-interrupt mach:sigchld #'sigchld-handler)
+  (system:enable-interrupt unix:sigchld #'sigchld-handler)
   ;; Make sure all the args are okay.
   (unless (every #'simple-string-p args)
     (error "All args to program must be simple strings -- ~S." args))
@@ -489,7 +479,7 @@
 		  (system:without-interrupts
 		    (multiple-value-bind
 			(child-pid errno)
-			(mach:unix-fork)
+			(unix:unix-fork)
 		      (cond ((zerop child-pid)
 			     ;; We are the child. Note: setup-child NEVER returns
 			     (setup-child pfile args env stdin stdout stderr
@@ -498,7 +488,7 @@
 			     ;; This should only happen if the bozo has too
 			     ;; many running procs.
 			     (error "Could not fork child process: ~A"
-				    (mach:get-unix-error-msg errno)))
+				    (unix:get-unix-error-msg errno)))
 			    (t
 			     ;; We are the parent.
 			     (setf proc (make-process :pid child-pid
@@ -511,10 +501,10 @@
 						      :cookie cookie))
 			     (push proc *active-processes*))))))))))
       (dolist (fd *close-in-parent*)
-	(mach:unix-close fd))
+	(unix:unix-close fd))
       (unless proc
 	(dolist (fd *close-on-error*)
-	  (mach:unix-close fd))
+	  (unix:unix-close fd))
 	(dolist (handler *handlers-installed*)
 	  (system:remove-fd-handler handler))))
     (when (and wait proc)
@@ -539,32 +529,32 @@
 		    (return))
 		  (multiple-value-bind
 		      (result readable/errno)
-		      (mach:unix-select (1+ descriptor) (ash 1 descriptor)
+		      (unix:unix-select (1+ descriptor) (ash 1 descriptor)
 					0 0 0)
 		    (cond ((null result)
 			   (error "Could not select on sub-process: ~A"
-				  (mach:get-unix-error-msg readable/errno)))
+				  (unix:get-unix-error-msg readable/errno)))
 			  ((zerop result)
 			   (return))))
 		  (multiple-value-bind
 		      (count errno)
-		      (mach:unix-read descriptor
+		      (unix:unix-read descriptor
 				      string
 				      (length string))
 		    (cond ((or (and (null count)
-				    (eql errno mach:eio))
+				    (eql errno unix:eio))
 			       (eql count 0))
 			   (system:remove-fd-handler handler)
 			   (setf handler nil)
 			   (decf (car cookie))
-			   (mach:unix-close descriptor)
+			   (unix:unix-close descriptor)
 			   (return))
 			  ((null count)
 			   (system:remove-fd-handler handler)
 			   (setf handler nil)
 			   (decf (car cookie))
 			   (error "Could not read input from sub-process: ~A"
-				  (mach:get-unix-error-msg errno)))
+				  (unix:get-unix-error-msg errno)))
 			  (t
 			   (write-string string stream
 					 :end count))))))))))
@@ -584,24 +574,24 @@
 	 ;; Use /dev/null.
 	 (multiple-value-bind
 	     (fd errno)
-	     (mach:unix-open "/dev/null"
+	     (unix:unix-open "/dev/null"
 			     (case direction
-			       (:input mach:o_rdonly)
-			       (:output mach:o_wronly)
-			       (t mach:o_rdwr))
+			       (:input unix:o_rdonly)
+			       (:output unix:o_wronly)
+			       (t unix:o_rdwr))
 			     #o666)
 	   (unless fd
 	     (error "Could not open \"/dev/null\": ~A"
-		    (mach:get-unix-error-msg errno)))
+		    (unix:get-unix-error-msg errno)))
 	   (push fd *close-in-parent*)
 	   (values fd nil)))
 	((eq object :stream)
 	 (multiple-value-bind
 	     (read-fd write-fd)
-	     (mach:unix-pipe)
+	     (unix:unix-pipe)
 	   (unless read-fd
 	     (error "Could not create pipe: ~A"
-		    (mach:get-unix-error-msg write-fd)))
+		    (unix:get-unix-error-msg write-fd)))
 	   (case direction
 	     (:input
 	      (push read-fd *close-in-parent*)
@@ -614,20 +604,20 @@
 	      (let ((stream (system:make-fd-stream read-fd :input t)))
 		(values write-fd stream)))
 	     (t
-	      (mach:unix-close read-fd)
-	      (mach:unix-close write-fd)
+	      (unix:unix-close read-fd)
+	      (unix:unix-close write-fd)
 	      (error "Direction must be either :INPUT or :OUTPUT, not ~S"
 		     direction)))))
 	((or (pathnamep object) (stringp object))
 	 (with-open-stream (file (apply #'open object keys))
 	   (multiple-value-bind (won fd)
-				(mach:unix-dup (system:fd-stream-fd file))
+				(unix:unix-dup (system:fd-stream-fd file))
 	     (cond (won
 		    (push fd *close-in-parent*)
 		    (values fd nil))
 		   (t
 		    (error "Could not duplicate file descriptor: ~A"
-			   (mach:get-unix-error-msg fd)))))))
+			   (unix:get-unix-error-msg fd)))))))
 	((system:fd-stream-p object)
 	 (values (system:fd-stream-fd object) nil))
 	((streamp object)
@@ -637,12 +627,12 @@
 		      256
 		      (error "Could not open a temporary file in /tmp"))
 	      (let* ((name (format nil "/tmp/.run-program-~D" count))
-		     (fd (mach:unix-open name
-					 (logior mach:o_rdwr
-						 mach:o_creat
-						 mach:o_excl)
+		     (fd (unix:unix-open name
+					 (logior unix:o_rdwr
+						 unix:o_creat
+						 unix:o_excl)
 					 #o666)))
-		(mach:unix-unlink name)
+		(unix:unix-unlink name)
 		(when fd
 		  (let ((newline (string #\Newline)))
 		    (loop
@@ -651,19 +641,19 @@
 			  (read-line object nil nil)
 			(unless line
 			  (return))
-			(mach:unix-write fd line 0 (length line))
+			(unix:unix-write fd line 0 (length line))
 			(if no-cr
 			  (return)
-			  (mach:unix-write fd newline 0 1)))))
-		  (mach:unix-lseek fd 0 mach:l_set)
+			  (unix:unix-write fd newline 0 1)))))
+		  (unix:unix-lseek fd 0 unix:l_set)
 		  (push fd *close-in-parent*)
 		  (return (values fd nil))))))
 	   (:output
 	    (multiple-value-bind (read-fd write-fd)
-				 (mach:unix-pipe)
+				 (unix:unix-pipe)
 	      (unless read-fd
 		(error "Cound not create pipe: ~A"
-		       (mach:get-unix-error-msg write-fd)))
+		       (unix:get-unix-error-msg write-fd)))
 	      (copy-descriptor-to-stream read-fd object cookie)
 	      (push read-fd *close-on-error*)
 	      (push write-fd *close-in-parent*)
diff --git a/code/save.lisp b/code/save.lisp
index 792b9d69757fc4827512f8b178e0015fb8a28a3f..a459255005ad89c69e520e43919a0988763fe936 100644
--- a/code/save.lisp
+++ b/code/save.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/save.lisp,v 1.11 1992/02/06 01:09:12 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/save.lisp,v 1.12 1992/02/14 23:45:28 wlott Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -47,8 +47,8 @@
 (defvar lisp-environment-list)
 
 
-(def-c-routine "save" (boolean)
-  (file null-terminated-string))
+(alien:def-alien-routine "save" (alien:boolean)
+  (file c-call:c-string))
 
 
 ;;; PARSE-UNIX-SEARCH-LIST  --  Internal
@@ -215,5 +215,4 @@
     (error "Change *PACKAGE* to the USER package and try again.")))
 
 (defun initial-init-function ()
-  (gc-on)
   (throw 'top-level-catcher nil))
diff --git a/code/serve-event.lisp b/code/serve-event.lisp
index b7789ea732bfd9b0ee50db02763e0737adc76f33..aa26296ec2a1226eb6206f6fc3d80516c94636ad 100644
--- a/code/serve-event.lisp
+++ b/code/serve-event.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/serve-event.lisp,v 1.13 1992/01/21 12:56:48 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/serve-event.lisp,v 1.14 1992/02/14 23:45:32 wlott Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -36,55 +36,6 @@
   "*In-server* is set to T when the SIGMSG interrupt has been enabled
   in Server.")
 
-#|
-
-(defvar server-unique-object (cons 1 2)
-  "Object thrown by the message interrupt handler.")
-
-(defconstant server-message-size 4096)
-(defalien server-message server-message (bytes server-message-size) 0)
-
-(define-alien-stack server-message server-message (bytes server-message-size))
-
-(defrecord server-message
-  (msg mach:msg #.(record-size 'mach:msg)))
-  
-;;; Grab-message-loop calls the appropiate handler for an IPC message.
-(defun grab-message-loop ()
-  (let ((done-any nil))
-    (loop
-      (if (eql (server-grab-message)
-	       mach:rcv-timed-out)
-	(return done-any)
-	(setf done-any t)))))
-
-
-(defun server-grab-message ()
-  (with-stack-alien (sm server-message)
-    (alien-bind ((msg (server-message-msg (alien-value sm))))
-      (setf (alien-access (mach:msg-msgsize (alien-value msg)))
-	    server-message-size)
-      (setf (alien-access (mach:msg-localport (alien-value msg)))
-	    mach::port-enabled)
-      (let ((gr (mach:msg-receive (alien-value sm) mach::rcv-timeout 0)))
-	(when (eql gr mach:rcv-timed-out)
-	  (return-from server-grab-message gr))
-	(unless (eql gr mach:rcv-success)
-	  (gr-error 'mach:msg-receive gr))
-	(let* ((server-message (alien-value sm))
-	       (port (alien-access (mach:msg-localport (alien-value msg))))
-	       (id (alien-access (mach:msg-id (alien-value msg))))
-	       (x (gethash port *port-table*))
-	       (set (cdr x)))
-	  (unless x
-	    (error "~D is not known to server (operation: ~D)." port id))
-	  (let ((gr (funcall (gethash id (object-set-table set)
-				      (object-set-default-handler set))
-			     (car x))))
-	    (unless (eql gr mach:kern-success)
-	      (gr-error 'server gr)))))))
-  mach:kern-success)
-|#
 
 
 ;;;; File descriptor IO noise.
@@ -181,7 +132,7 @@
 	(stop-sec stop-usec)
 	(if timeout
 	    (multiple-value-bind (okay sec usec)
-				 (mach:unix-gettimeofday)
+				 (unix:unix-gettimeofday)
 	      (declare (ignore okay))
 	      (values (the (unsigned-byte 32) (+ sec timeout))
 		      usec))
@@ -198,7 +149,7 @@
 	  
 	  (when timeout
 	    (multiple-value-bind (okay sec usec)
-				 (mach:unix-gettimeofday)
+				 (unix:unix-gettimeofday)
 	      (declare (ignore okay))
 	      (when (or (> sec stop-sec)
 			(and (= sec stop-sec) (>= usec stop-usec)))
@@ -215,7 +166,7 @@
   (let ((bogus-handlers nil))
     (dolist (handler *descriptor-handlers*)
       (unless (or (handler-bogus handler)
-		  (mach:unix-fstat (handler-descriptor handler)))
+		  (unix:unix-fstat (handler-descriptor handler)))
 	(setf (handler-bogus handler) t)
 	(push handler bogus-handlers)))
     (restart-case (error "~S ~[have~;has a~:;have~] bad file descriptor~:P."
@@ -322,7 +273,7 @@
 		       (:output (frob writeable))))
 		   (setf result t)))
 	       result)))
-	  ((eql readable mach:eintr)
+	  ((eql readable unix:eintr)
 	   ;; We did an interrupt.
 	   t)
 	  (t
@@ -386,5 +337,5 @@
     (multiple-value-bind (count read-mask write-mask except-mask)
 			 (calc-masks)
       ;; Do the select.
-      (mach:unix-select count read-mask write-mask except-mask
+      (unix:unix-select count read-mask write-mask except-mask
 			timeout-sec timeout-usec))))
diff --git a/code/signal.lisp b/code/signal.lisp
index 55ff24ce8e7acdd2c3376811b5bd6fa17f4dc813..88d3ef57c62f0b22d8a9e536ec70e036deff81ff 100644
--- a/code/signal.lisp
+++ b/code/signal.lisp
@@ -1,4 +1,4 @@
-;;; -*- Log: code.log; Package: MACH -*-
+;;; -*- Package: UNIX -*-
 ;;;
 ;;; **********************************************************************
 ;;; This code was written as part of the CMU Common Lisp project at
@@ -7,22 +7,23 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/signal.lisp,v 1.12 1991/02/08 13:35:43 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/signal.lisp,v 1.13 1992/02/14 23:45:34 wlott Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
-;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/signal.lisp,v 1.12 1991/02/08 13:35:43 ram Exp $
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/signal.lisp,v 1.13 1992/02/14 23:45:34 wlott Exp $
 ;;;
 ;;; Code for handling UNIX signals.
 ;;; 
 ;;; Written by William Lott.
 ;;;
 
-(in-package "MACH")
+(in-package "UNIX")
+(use-package "KERNEL")
 
 (export '(unix-signal-name unix-signal-description unix-signal-number
-	  sigcontext sigmask unix-sigblock unix-sigpause
-	  unix-sigsetmask unix-kill unix-getpid))
+	  sigmask unix-sigblock unix-sigpause unix-sigsetmask unix-kill
+	  unix-killpg))
 
 (export 'kernel::signal-init (find-package "KERNEL"))
 
@@ -48,7 +49,7 @@
 
 (eval-when (compile eval)
 (defmacro def-unix-signal (name number description)
-  (let ((mach-symbol (intern (symbol-name name))))
+  (let ((symbol (intern (symbol-name name))))
     `(progn
        (push (make-unix-signal ,name ,number ,description) *unix-signals*)
        ;; 
@@ -56,8 +57,8 @@
        ;; old code which expects the symbol with the same print name as
        ;; our keywords to be a constant with a value equal to the signal
        ;; number.
-       (defconstant ,mach-symbol ,number ,description)
-       (export ',mach-symbol))))
+       (defconstant ,symbol ,number ,description)
+       (export ',symbol))))
 ) ;eval-when
 
 (defun unix-signal-or-lose (arg)
@@ -136,9 +137,9 @@
 
 (proclaim '(inline real-unix-kill))
 
-(def-c-routine ("kill" real-unix-kill) (int)
-  (pid int)
-  (signal int))
+(alien:def-alien-routine ("kill" real-unix-kill) c-call:int
+  (pid c-call:int)
+  (signal c-call:int))
 
 (defun unix-kill (pid signal)
   "Unix-kill sends the signal signal to the process with process 
@@ -149,9 +150,9 @@
 
 (proclaim '(inline real-unix-killpg))
 
-(def-c-routine ("killpg" real-unix-killpg) (int)
-  (pgrp int)
-  (signal int))
+(alien:def-alien-routine ("killpg" real-unix-killpg) c-call:int
+  (pgrp c-call:int)
+  (signal c-call:int))
 
 (defun unix-killpg (pgrp signal)
   "Unix-killpg sends the signal signal to the all the process in process
@@ -160,36 +161,35 @@
   (real-unix-killpg pgrp (unix-signal-number signal)))
 
 
-(def-c-routine ("sigblock" unix-sigblock) (unsigned-long)
+(alien:def-alien-routine ("sigblock" unix-sigblock) c-call:unsigned-long
   "Unix-sigblock cause the signals specified in mask to be
    added to the set of signals currently being blocked from
    delivery.  The macro sigmask is provided to create masks."
-  (mask unsigned-long))
+  (mask c-call:unsigned-long))
 
 
-(def-c-routine ("sigpause" unix-sigpause) (void)
+(alien:def-alien-routine ("sigpause" unix-sigpause) c-call:void
   "Unix-sigpause sets the set of masked signals to its argument
    and then waits for a signal to arrive, restoring the previous
    mask upon its return."
-  (mask unsigned-long))
+  (mask c-call:unsigned-long))
 
 
-(def-c-routine ("sigsetmask" unix-sigsetmask) (unsigned-long)
+(alien:def-alien-routine ("sigsetmask" unix-sigsetmask) c-call:unsigned-long
   "Unix-sigsetmask sets the current set of masked signals (those
    begin blocked from delivery) to the argument.  The macro sigmask
    can be used to create the mask.  The previous value of the signal
    mask is returned."
-  (mask unsigned-long))
+  (mask c-call:unsigned-long))
 
 
 
 ;;;; C routines that actually do all the work of establishing signal handlers.
 
-(def-c-routine ("install_handler" install-handler)
-	       (unsigned-long)
-  (signal int)
-  (handler unsigned-long))
-
+(alien:def-alien-routine ("install_handler" install-handler)
+			 c-call:unsigned-long
+  (signal c-call:int)
+  (handler c-call:unsigned-long))
 
 
 
@@ -202,10 +202,11 @@
 				  (case handler
 				    (:default sig_dfl)
 				    (:ignore sig_ign)
-				    (t (di::get-lisp-obj-address handler))))))
+				    (t
+				     (kernel:get-lisp-obj-address handler))))))
      (cond ((= result sig_dfl) :default)
 	   ((= result sig_ign) :ignore)
-	   (t (the function (di::make-lisp-obj result)))))))
+	   (t (the function (kernel:make-lisp-obj result)))))))
 
 (defun default-interrupt (signal)
   (enable-interrupt signal :default))
@@ -221,17 +222,12 @@
 
 (defmacro define-signal-handler (name what &optional (function 'error))
   `(defun ,name (signal code scp)
-     (declare (ignore signal code))
-     (alien-bind ((sc
-		   (make-alien 'mach:sigcontext
-			       #.(c-sizeof 'mach:sigcontext)
-			       scp)
-		   mach:sigcontext
-		   t))
-       (system:without-hemlock
-	(,function ,(concatenate 'simple-string what " at #x~x.")
-		   (sap-int
-		    (alien-access (mach:sigcontext-pc (alien-value sc)))))))))
+     (declare (ignore signal code)
+	      (type system-area-pointer scp))
+     (system:without-hemlock
+      (,function ,(concatenate 'simple-string what " at #x~x.")
+		 (with-alien ((scp (* sigcontext) scp))
+		   (sap-int (slot scp 'sc-pc)))))))
 
 (define-signal-handler sigint-handler "Interrupted" break)
 (define-signal-handler sigill-handler "Illegal Instruction")
diff --git a/code/struct.lisp b/code/struct.lisp
index 8a1ce524becdf0fcc7fba6bba95bb76ab017ece7..fa06342dc82d8eae52d11191b3cdac1d719fad20 100644
--- a/code/struct.lisp
+++ b/code/struct.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/struct.lisp,v 1.12 1991/12/14 08:55:21 wlott Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/struct.lisp,v 1.13 1992/02/14 23:45:36 wlott Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -76,57 +76,6 @@
   (misc #'do-nothing :type function))		; Less used methods
 
 
-;;;; Alien structures:
- 
-(defstruct (alien-value
-	    (:constructor make-alien-value (sap offset size type))
-	    (:print-function %print-alien-value))
-  "This structure represents an Alien value."
-  sap
-  offset
-  size
-  type)
-
-(defstruct (ct-a-val
-	    (:print-function
-	     (lambda (s stream d)
-	       (declare (ignore s d))
-	       (write-string "#<Alien compiler info>" stream))))
-  type		; Type of expression, NIL if unknown.
-  size		; Expression for the size of the alien.
-  sap		; Expression for SAP.
-  offset	; Expression for bit offset.
-  alien)	; Expression for alien-value or NIL.
-
-
-(defstruct (alien-info
-	    (:print-function %print-alien-info)
-	    (:constructor
-	     make-alien-info (function num-args arg-types result-type)))
-  function	; The function the definition was made into.
-  num-args	; The total number of arguments.
-  arg-types	; Alist of arg numbers to types of Alien args.
-  result-type)	; The type of the resulting Alien.
-
-
-(defstruct (stack-info
-	    (:print-function
-	     (lambda (s stream d)
-	       (declare (ignore s d))
-	       (format stream "#<Alien stack info>"))))
-  type
-  size)
-
-
-(defstruct enumeration-info
-  signed	; True if minimum value negative.
-  size		; Minimum number of bits needed to hold value.
-  from		; Symbol holding alist from keywords to integers.
-  to		; Symbol holding alist or vector from integers to keywords.
-  kind		; Kind of from mapping, :vector or :alist.
-  offset)	; Offset to add to value for :vector from mapping.
-
-
 ;;; Condition structures:
 
 (in-package "CONDITIONS")
diff --git a/code/time.lisp b/code/time.lisp
index d2b0876d74a7f06c80aa361ff6bfcf37f40ea96e..81004346a91b45dd629f83ac5660abd58cda17f4 100644
--- a/code/time.lisp
+++ b/code/time.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/time.lisp,v 1.8 1991/08/30 17:41:25 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/time.lisp,v 1.9 1992/02/14 23:45:37 wlott Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -52,7 +52,7 @@
   "Return the real time in the internal time format.  This is useful for
   finding elapsed time.  See Internal-Time-Units-Per-Second."
   (locally (declare (optimize (speed 3) (safety 0)))
-    (multiple-value-bind (ignore seconds useconds) (mach:unix-gettimeofday)
+    (multiple-value-bind (ignore seconds useconds) (unix:unix-gettimeofday)
       (declare (ignore ignore))
       (let ((base *internal-real-time-base-seconds*)
 	    (uint (truncate useconds
@@ -74,7 +74,7 @@
   finding CPU usage."
   (locally (declare (optimize (speed 3) (safety 0)))
     (multiple-value-bind (ignore utime stime)
-			 (mach:unix-getrusage mach:rusage_self)
+			 (unix:unix-getrusage unix:rusage_self)
       (declare (ignore ignore))
       (values (truncate (the (unsigned-byte 32) (+ utime stime))
 			micro-seconds-per-internal-time-unit)))))
@@ -109,7 +109,7 @@
 (defun get-universal-time ()
   "Returns a single integer for the current time of
    day in universal time format."
-  (multiple-value-bind (res secs) (mach:unix-gettimeofday)
+  (multiple-value-bind (res secs) (unix:unix-gettimeofday)
     (declare (ignore res))
     (+ secs unix-to-universal-time)))
 
@@ -139,7 +139,7 @@
 	  (daylight NIL)
 	  (timezone (if (null time-zone)
 			(multiple-value-bind (res s us tz)
-					     (mach:unix-gettimeofday)
+					     (unix:unix-gettimeofday)
 			  (declare (ignore s us))
 			  (if res tz 0))
 			(* time-zone 60))))
@@ -199,7 +199,7 @@
 			 ((<= (abs (- y now-year)) 50) y)))
 		   year))
 	 (zone (if time-zone (* time-zone 60)
-		   (multiple-value-bind (res s us tz) (mach:unix-gettimeofday)
+		   (multiple-value-bind (res s us tz) (unix:unix-gettimeofday)
 		     (declare (ignore s us))
 		     (if res tz))))
 	 (tmonth (- month 3)))
diff --git a/code/wire.lisp b/code/wire.lisp
index 7e5d401cfeb2253e7e00568bf321fedd76ea5434..b600a8a66c21197d56a0b60b3f695204a2187b86 100644
--- a/code/wire.lisp
+++ b/code/wire.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/wire.lisp,v 1.6 1991/10/05 17:11:42 chiles Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/wire.lisp,v 1.7 1992/02/14 23:45:40 wlott Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -136,8 +136,8 @@
   "Returns T iff the given remote object is defined locally."
   (declare (type remote-object remote))
   (unless *this-host*
-    (setf *this-host* (mach:unix-gethostid))
-    (setf *this-pid* (mach:unix-getpid)))
+    (setf *this-host* (unix:unix-gethostid))
+    (setf *this-pid* (unix:unix-getpid)))
   (and (eql (remote-object-host remote) *this-host*)
        (eql (remote-object-pid remote) *this-pid*)))
 
@@ -193,8 +193,8 @@
 (defun make-remote-object (local)
   "Convert the given local object to a remote object."
   (unless *this-host*
-    (setf *this-host* (mach:unix-gethostid))
-    (setf *this-pid* (mach:unix-getpid)))
+    (setf *this-host* (unix:unix-gethostid))
+    (setf *this-pid* (unix:unix-getpid)))
   (let ((id (gethash local *object-to-id*)))
     (unless id
       (setf id *next-id*)
@@ -232,7 +232,7 @@ object. Passing that remote object to remote-object-value will new return NIL."
 	 (wire-ibuf-end wire))
       (multiple-value-bind
 	  (number error)
-	  (mach:unix-select (1+ (wire-fd wire))
+	  (unix:unix-select (1+ (wire-fd wire))
 			    (ash 1 (wire-fd wire))
 			    0
 			    0
@@ -241,7 +241,7 @@ object. Passing that remote object to remote-object-value will new return NIL."
 	  (error 'wire-io-error
 		 :wire wire
 		 :when "listening to"
-		 :msg (mach:get-unix-error-msg error)))
+		 :msg (unix:get-unix-error-msg error)))
 	(not (zerop number)))))
 
 
@@ -264,12 +264,12 @@ is signaled."
       (error 'wire-eof :wire wire))
 
     (multiple-value-bind (bytes error)
-			 (mach:unix-read fd ibuf buffer-size)
+			 (unix:unix-read fd ibuf buffer-size)
       (cond ((null bytes)
 	     (error 'wire-io-error
 		    :wire wire
 		    :when "reading"
-		    :msg (mach:get-unix-error-msg error)))
+		    :msg (unix:get-unix-error-msg error)))
 	    ((zerop bytes)
 	     (setf (wire-ibuf wire) nil)
 	     (error 'wire-eof :wire wire))
@@ -471,7 +471,7 @@ signed (defaults to T)."
 
 ;;; WRITE-STUFF -- internal
 ;;;
-;;;   Slightly better interface to mach:unix-write. Choaks on errors.
+;;;   Slightly better interface to unix:unix-write. Choaks on errors.
 
 (defmacro write-stuff (fd string-form &optional end)
   (let ((string (gensym))
@@ -483,12 +483,12 @@ signed (defaults to T)."
 		`((,length (length ,string)))))
        (multiple-value-bind
 	   (,result ,error)
-	   (mach:unix-write ,fd ,string 0 ,(or end length))
+	   (unix:unix-write ,fd ,string 0 ,(or end length))
 	 (cond ((null ,result)
 		(error 'wire-io-error
 		       :wire wire
 		       :when "writing"
-		       :msg (mach:get-unix-error-msg ,error)))
+		       :msg (unix:get-unix-error-msg ,error)))
 	       ((eql ,result ,(or end length))
 		)
 	       (t
diff --git a/compiler/aliencomp.lisp b/compiler/aliencomp.lisp
index 77ff494066109cb2db799b217b7f5ab2455f4246..185e64bd69a249ff891b9fae19ae77b2fc5c86fb 100644
--- a/compiler/aliencomp.lisp
+++ b/compiler/aliencomp.lisp
@@ -7,979 +7,671 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/aliencomp.lisp,v 1.14 1991/04/22 19:30:43 wlott Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/aliencomp.lisp,v 1.15 1992/02/14 23:47:03 wlott Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
-;;;    This file contains transforms and other stuff used to compile Alien
-;;; definitions.  There are two main parts: A fairly general numeric
-;;; constant-folding facility, and the transforms that implement the
-;;; the Alien primitives.
+;;; This file contains transforms and other stuff used to compile Alien
+;;; operations.
 ;;;
+;;; Rewritten once again, this time by William Lott and Rob MacLachlan.
 ;;;
-(in-package 'c)
-
-(in-package 'lisp)
-(import '(
-	  ct-a-val-sap ct-a-val-type ct-a-val-offset ct-a-val-size
-	  ct-a-val-p ct-a-val make-ct-a-val ct-a-val-alien
-	  check<= check= %alien-indirect %aligned-sap
-	  naturalize-integer deport-integer naturalize-boolean deport-boolean
-	  sap-ref-8 sap-ref-16 sap-ref-32 sap-ref-sap
-	  signed-sap-ref-8 signed-sap-ref-16 signed-sap-ref-32
-	  %set-sap-ref-8 %set-sap-ref-16 %set-sap-ref-32 %set-sap-ref-sap
-	  sap+ %set-alien-access %set-sap-ref-single %set-sap-ref-double
-	  %set-sap-ref-descriptor
-	  
-	  *alien-eval-when* make-alien alien-type alien-size alien-address
-	  copy-alien dispose-alien defalien alien-value
-	  alien-bind defoperator alien-index alien-indirect
-	  bits bytes words long-words port perq-string
-	  boolean defenumeration enumeration
-	  system-area-pointer pointer alien alien-access
-	  alien-assign alien-sap define-alien-stack
-	  with-stack-alien null-terminated-string c-procedure
-	  record-size
-	  )
-	(find-package "C"))
-
-(in-package 'c)
+(in-package "C")
+(use-package "ALIEN")
+(use-package "SYSTEM")
 
-
-;;;; Pre-pass:
-;;;
-;;;    We do a pre-pass over Alien expressions at source-transformation time.
-;;; This pass does compile-time Alien type checking, and also composes the
-;;; Alien operators, producing separate expressions that compute the address,
-;;; type and total offset and size of the expression.
-
- 
-;;; Analyze-Alien-Expression  --  Internal
-;;;
-;;;    This function grovels an alien expression and return a bunch of values
-;;; that tell how to evaluate the thing.  Result-Type is the alien-type that
-;;; the expression must evaluate to.  The values returned are:
-;;;  0] A list of let*-bindings that need to be made.
-;;;  1] Some stuff that should be evaluated within the bindings.  This
-;;;      stuff is error-checks and stuff like that.  This is in reverse
-;;;      order.
-;;;  2] A ct-a-val structure describing the size, sap and offset.
-;;;
-;;; If the expression is not of the correct type or is somehow malformed, then
-;;; we call Compiler-Error, which aborts out.  If the expression cannot be
-;;; shown to be of the correct type then a runtime check is generated.  When
-;;; Result-Type is Nil we don't pay any attention to the type.
-;;;
-(defun analyze-alien-expression (result-type exp)
-  (if (atom exp)
-      (if (and (symbolp exp)
-	       (or (ct-a-val-p (lexenv-find exp variables))
-		   (info variable alien-value exp)))
-	  (grovel-alien-var result-type exp)
-	  (grovel-random-alien result-type exp))
-      (let* ((fun (car exp))
-	     (info (info function alien-operator fun)))
-	(cond
-	 ((eq fun 'alien-value)
-	  (grovel-alien-var result-type (cadr exp)))
-	 ((eq fun 'alien-index)
-	  (when result-type
-	    (compiler-error "Alien-Index used where a type is required:~% ~S"
-			    exp))
-	  (grovel-alien-index exp))
-	 ((eq fun 'alien-indirect)
-	  (when result-type
-	    (compiler-error "Alien-Indirect used where a type is required:~% ~S"
-			    exp))
-	  (grovel-alien-indirect exp))
-	 (info
-	  (grovel-alien-operator result-type exp info))
-	 (t
-	  (grovel-random-alien result-type exp))))))
-
-
-;;; Ignore-Unreferenced-Vars  --  Internal
-;;;
-;;;    Return an Ignorable declaration for all of the vars in the let-binding
-;;; list Binds.
-;;;
-(defun ignore-unreferenced-vars (binds)
-  (declare (list binds))
-  `(declare (ignorable ,@(mapcar #'car binds))))
-
-
-;;; Grovel-Alien-Index  --  Internal
-;;;
-;;;    Analyze a call to Alien-Index, a la Analyze-Alien-Expression.  We
-;;; throw a call to Check-Alien-Bounds into the Stuff to do the bounds
-;;; checking.
-;;;
-(defun grovel-alien-index (exp)
-  (unless (= (length exp) 4)
-    (compiler-error "Wrong number of arguments to Alien-Index:~% ~S" exp))
-  
-  (multiple-value-bind (binds stuff res)
-		       (analyze-alien-expression nil (second exp))
-    (let* ((offset (ct-a-val-offset res))
-	   (noffset `(+ ,offset ,(third exp)))
-	   (size (ct-a-val-size res))
-	   (nsize (fourth exp)))
-      (values
-       binds
-       `((check<= (+ ,noffset ,nsize) (+ ,offset ,size))
-	 ,@stuff)
-       (make-ct-a-val
-	:sap (ct-a-val-sap res)
-	:offset noffset
-	:size nsize)))))
-
-
-;;; Grovel-Alien-Indirect  --  Internal
-;;;
-;;;    Handle an Alien-Indirect.  We transform to a %Alien-Indirect that looks
-;;; at the offset and size.  If the offset is long-word aligned and the size is
-;;; 32, then we transform to a SAP-System-Ref, otherwise we give up and allow
-;;; the error check to be done at run-time.
-;;;
-(defun grovel-alien-indirect (exp)
-  (unless (= (length exp) 3)
-    (compiler-error "Wrong number of arguments to Alien-Indirect:~% ~S" exp))
-
-  (multiple-value-bind (binds stuff res)
-		       (analyze-alien-expression nil (second exp))
-    (values
-     binds
-     stuff
-     (make-ct-a-val
-      :sap `(%alien-indirect ,(ct-a-val-size res)
-			     ,(ct-a-val-sap res)
-			     ,(ct-a-val-offset res)
-			     ',exp)
-      :offset 0
-      :size (third exp)))))
-
-(defknown %alien-indirect (index t index t) t (flushable))
-
-(deftransform %alien-indirect ((size sap offset exp))
-  (unless (>= (find-alignment offset) 5)
-    (give-up "Offset may not be long-word aligned:~% ~S"
-	     (continuation-value exp)))
-
-  (unless (and (constant-continuation-p size)
-	       (eql (continuation-value size) 32))
-    (give-up "Size may not be 32:~% ~S" (continuation-value exp)))
-
-  '(sap-ref-sap sap (ash offset -5)))
-
-
-;;; Grovel-Alien-Var  --  Internal
-;;;
-;;;    Look the var up in the LEXENV-VARIABLES, and then check if it is a
-;;; global alien-variable.  If it ain't there or is the the wrong type then
-;;; flame out.
-;;;
-(defun grovel-alien-var (type var)
-  (let* ((local-def (lexenv-find var variables))
-	 (res (cond ((ct-a-val-p local-def) local-def)
-		    ((or (not local-def)
-			 (and (global-var-p local-def)
-			      (eq (global-var-kind local-def) :special)))
-		     (info variable alien-value var))
-		    (t
-		     (compiler-error "Not an Alien variable: ~S." var)))))
-    (unless res
-      (compiler-error "Undefined Alien variable: ~S" var))
-    (when (and type (not (equal (ct-a-val-type res) type)))
-      (compiler-error "Alien type of ~S is ~S, not ~S."
-		      var (ct-a-val-type res) type))
-
-    (values () () res)))
-
-
-;;; Grovel-Alien-Operator  --  Internal
-;;;
-;;;    Handle a call to an alien operator.  Analyze each Alien valued argument,
-;;; throwing the result on *aenv* during the processing of the body.  We always
-;;; bind lisp arguments, letting the optimizer do any cleverness.  All we do to
-;;; the body is strip off any stuff if there is a progn, and then call
-;;; Analyze-Alien-Expression on the body with Nil as the result-type.
-;;;
-(defun grovel-alien-operator (type exp info)
-  (unless (or (not type)
-	      (equal (lisp::alien-info-result-type info) type))
-    (compiler-error "Results in a ~S alien value, not a ~S:~% ~S"
-		    (lisp::alien-info-result-type info) type exp))
-  
-  (unless (= (lisp::alien-info-num-args info) (length (cdr exp)))
-    (compiler-error "Alien operator not called with ~D args:~% ~S"
-		    (lisp::alien-info-num-args info) exp))
-  
-  (do* ((args (cdr exp) (cdr args))
-	(dums ())
-	(*lexical-environment* *lexical-environment*)
-	(num 0 (1+ num))
-	(types (lisp::alien-info-arg-types info))
-	(atype (cdr (assoc num types)) (cdr (assoc num types)))
-	(stuff ())
-	(binds ()))
-       ((null args)
-	(let ((body (apply (lisp::alien-info-function info)
-			   (nreverse dums))))
-	  (when (and (consp body)
-		     (eq (car body) 'progn))
-	    (push (butlast body) stuff)
-	    (setq body (car (last body))))
-	  (multiple-value-bind (b s r)
-			       (analyze-alien-expression nil body)
-	    (when r
-	      (setq r (make-ct-a-val
-		       :type (lisp::alien-info-result-type info)
-		       :sap (ct-a-val-sap r)
-		       :offset (ct-a-val-offset r)
-		       :size (ct-a-val-size r))))
-	    (values
-	     (nconc b binds)
-	     (nconc s stuff)
-	     r))))
-    (declare (list dums))
-    (cond (atype
-	   (multiple-value-bind (b s val)
-				(analyze-alien-expression atype (car args))
-	     (setq binds (nconc binds b)  stuff (nconc stuff s))
-	     (unless val (return nil))
-	     (let ((var (gensym)))
-	       (setq *lexical-environment*
-		     (make-lexenv :variables (list (cons var val))))
-	       (push var dums))))
-	  (t
-	   (let ((var (gensym)))
-	     (push var dums)
-	     (setq binds (nconc binds `((,var ,(car args))))))))))
-
-
-;;; Grovel-Random-Alien  --  Internal
-;;;
-;;;    Flame out if the form is some random atom, otherwise bind a var
-;;; to Check-Alien-Type of it, and return forms to access the fields
-;;; of the Alien-Value.
-;;;
-(defun grovel-random-alien (type exp)
-  (when (and (atom exp) (not (symbolp exp)))
-    (compiler-error "~S is a bad thing to be an Alien-Value." exp))
-  (cond ((and (symbolp exp) (info variable alien-value exp))
-	 (values () () (info variable alien-value exp)))
-	(t
-	 (when (policy nil (> speed brevity))
-	   (compiler-note "Not a known Alien expression:~% ~S." exp))
-
-	 (let ((var (gensym))
-	       (sap (gensym))
-	       (size (gensym))
-	       (offset (gensym)))
-	   (values
-	    `((,sap (lisp::alien-value-sap ,var))
-	      (,offset (lisp::alien-value-offset ,var))
-	      (,size (lisp::alien-value-size ,var))
-	      (,var ,(if type
-			 `(lisp::check-alien-type ,exp ',type)
-			 exp)))
-	    ()
-	    (make-ct-a-val
-	     :type type
-	     :sap sap
-	     :offset offset
-	     :size size
-	     :alien var))))))
+(export '(%alien-funcall))
 
 
-;;;; Miscellaneous internal frobs:
-
-(defknown sap+ (system-area-pointer integer) system-area-pointer
-  (movable flushable))
-(deftransform sap+ ((sap offset))
-  (unless (and (constant-continuation-p offset)
-	       (eql (continuation-value offset) 0))
-    (give-up))
-  'sap)
+;;;; defknowns
 
-(defknown sap- (system-area-pointer system-area-pointer) (signed-byte 32)
-  (movable flushable))
-
-(defknown sap-int (system-area-pointer) (unsigned-byte 32) (movable flushable))
-(defknown int-sap ((unsigned-byte 32)) system-area-pointer (movable))
-
-(defknown %aligned-sap (system-area-pointer unsigned-byte t) system-area-pointer
-  (movable flushable))
-(deftransform %aligned-sap ((sap offset form))
-  (unless (> (find-alignment offset) 3)
-    (give-up))
-  '(sap+ sap (ash offset -3)))
+(defknown %sap-alien (system-area-pointer alien-type) alien-value
+  (flushable movable))
+(defknown alien-sap (alien-value) system-area-pointer
+  (flushable movable))
 
-(defknown (check<= check=) (index index) void (movable))
+(defknown slot (alien-value symbol) t
+  (flushable recursive))
+(defknown %set-slot (alien-value symbol t) t
+  (recursive))
+(defknown %slot-addr (alien-value symbol) (alien (* t))
+  (flushable movable recursive))
 
-;;; Compile-Time-Check  --  Internal
-;;;
-;;;    If the operands are constant, then test them using OP.  If it succeeds,
-;;; transform to NIL, otherwise warn and give-up.
-;;;
-(defun compile-time-check (x y op)
-  (unless (and (constant-continuation-p x)
-	       (constant-continuation-p y))
-    (give-up))
-  (let ((x (continuation-value x))
-	(y (continuation-value y)))
-    (unless (funcall (symbol-function op) x y)
-      (compiler-warning "~S not ~S to ~S at compile time." x op y)
-      (give-up)))
-  'nil)
-
-(deftransform check<= ((x y)) (compile-time-check x y '<=))
-(deftransform check= ((x y)) (compile-time-check x y '=))
-
-(defknown record-size (symbol) index (movable foldable flushable))
-
-(defknown sap-ref-8 (system-area-pointer index) (unsigned-byte 8)
-  (flushable))
-(defknown sap-ref-16 (system-area-pointer index) (unsigned-byte 16)
-  (flushable))
-(defknown sap-ref-32 (system-area-pointer index) (unsigned-byte 32)
-  (flushable))
-
-(defknown signed-sap-ref-8 (system-area-pointer index) (signed-byte 8)
-  (flushable))
-(defknown signed-sap-ref-16 (system-area-pointer index) (signed-byte 16)
-  (flushable))
-(defknown signed-sap-ref-32 (system-area-pointer index) (signed-byte 32)
+(defknown deref (alien-value &rest index) t
   (flushable))
+(defknown %set-deref (alien-value t &rest index) t
+  ())
+(defknown %deref-addr (alien-value &rest index) (alien (* t))
+  (flushable movable))
 
-(defknown %set-sap-ref-8
-	  (system-area-pointer index (or (unsigned-byte 8) (signed-byte 8)))
-  (or (unsigned-byte 8) (signed-byte 8)) ()
-  :derive-type #'result-type-last-arg)
-(defknown %set-sap-ref-16
-	  (system-area-pointer index (or (unsigned-byte 16) (signed-byte 16)))
-  (or (unsigned-byte 16) (signed-byte 16)) ()
-  :derive-type #'result-type-last-arg)
-(defknown %set-sap-ref-32
-	  (system-area-pointer index (or (unsigned-byte 32) (signed-byte 32)))
-  (or (unsigned-byte 32) (signed-byte 32)) ()
-  :derive-type #'result-type-last-arg)
-
-(defknown sap-ref-sap (system-area-pointer index) system-area-pointer
+(defknown %heap-alien (heap-alien-info) t
   (flushable))
-(defknown %set-sap-ref-sap (system-area-pointer index system-area-pointer)
-  system-area-pointer
+(defknown %set-heap-alien (heap-alien-info t) t
   ())
+(defknown %heap-alien-addr (heap-alien-info) (alien (* t))
+  (flushable movable))
 
-(defknown sap-ref-single (system-area-pointer index) single-float
-  (flushable))
-(defknown sap-ref-double (system-area-pointer index) double-float
+(defknown make-local-alien (local-alien-info) t
+  ())
+(defknown note-local-alien-type (local-alien-info t) null
+  ())
+(defknown local-alien (local-alien-info t) t
   (flushable))
-
-(defknown %set-sap-ref-single
-	  (system-area-pointer index single-float) single-float
+(defknown %local-alien-forced-to-memory-p (local-alien-info) (member t nil)
+  (movable))
+(defknown %set-local-alien (local-alien-info t t) t
   ())
-(defknown %set-sap-ref-double
-	  (system-area-pointer index double-float) double-float
+(defknown %local-alien-addr (local-alien-info t) (alien (* t))
+  (flushable movable))
+(defknown dispose-local-alien (local-alien-info t) t
   ())
 
-
-;;;; Alien variable special forms:
-
-;;; Alien-Bind IR1 convert  --  Internal
-;;;
-(def-ir1-translator alien-bind ((&whole source binds &body body) start cont)
-  (if binds
-      (let ((bind (first binds)))
-	(unless (<= 2 (length bind) 4)
-	  (compiler-error "Malformed Alien-Bind specifier:~% ~S" bind))
-	(let ((var (first bind))
-	      (val (second bind))
-	      (typ (third bind))
-	      (aligned (fourth bind)))
-	  
-	  (multiple-value-bind (init-lets stuff res)
-			       (analyze-alien-expression typ val)
-	    (unless (ct-a-val-type res)
-	      (compiler-error "Must specify type, since it is not apparent ~
-                     	       from the value:~% ~S"
-			      bind))
-	    (let* ((offset (ct-a-val-offset res))
-		   (sap (ct-a-val-sap  res))
-		   (size (ct-a-val-size res))
-		   (n-size (gensym))
-		   (n-sap (gensym))
-		   (n-offset (gensym))
-		   (a-val (make-ct-a-val :type (ct-a-val-type res)
-					 :offset (if aligned 0 n-offset)
-					 :size n-size
-					 :sap n-sap
-					 :alien (ct-a-val-alien res)))
-		   (lets `(,@(reverse init-lets)
-			   (,n-sap ,(if aligned
-					`(%aligned-sap ,sap ,offset ',source)
-					sap))
-			   (,n-size ,size)
-			   (,n-offset ,(if aligned 0 offset)))))
-	      (ir1-convert
-	       start cont
-	       `(let* ,lets
-		  ,(ignore-unreferenced-vars lets)
-		  (compiler-let ((*lexical-environment*
-				  (make-lexenv :variables
-					       ',(acons var a-val nil))))
-		    ,@(reverse stuff)
-		    (alien-bind ,(rest binds)
-		      ,@body))))))))
-      (ir1-convert-progn-body start cont body)))
-
-
-;;; With-Stack-Alien-Transform  --  Internal
-;;;
-;;;
-(def-ir1-translator with-stack-alien (((var type &optional size)
-				       &body forms) start cont)
-  (unless size
-    (let ((info (info alien-stack info type)))
-      (unless info
-	(compiler-error "~S is not the name of a declared alien stack." type))
-      (setf type (lisp::stack-info-type info))
-      (setf size (lisp::stack-info-size info))))
-  (let* ((sap-var (gensym))
-	 (*lexical-environment*
-	  (make-lexenv :variables
-		       (list (cons var
-				   (make-ct-a-val :type type
-						  :size size
-						  :sap sap-var
-						  :offset 0))))))
-    (ir1-convert start cont
-      `(let ((,sap-var
-	      (truly-the system-area-pointer
-			 (%primitive alloc-number-stack-space
-				     (ceiling ,size vm:byte-bits)))))
-	 (declare (ignorable ,sap-var))
-	 (multiple-value-prog1
-	     (progn ,@forms)
-	   (%primitive dealloc-number-stack-space
-		       (ceiling ,size vm:byte-bits)))))))
+(defknown %cast (alien-value alien-type) alien
+  (flushable movable))
 
-
-;;;; CALL-FOREIGN-FUNCTION stuff.
-
-(defknown ext::call-foreign-function (simple-base-string t t &rest t) t)
-
-(defun alien-type-type (type)
-  (let ((name (if (listp type) (car type) type)))
-    (case name
-      ((unsigned-byte signed-byte system-area-pointer
-		      double-float single-float)
-       (specifier-type type))
-      (port
-       (specifier-type '(unsigned-byte 32)))
-      (values
-       (values-specifier-type
-	`(values ,@(mapcar #'type-specifier
-			   (mapcar #'alien-type-type
-				   (cdr type))))))
-      (t
-       (error "Alien type ~S has no corresponding Lisp type." type)))))
-
-(defoptimizer (ext::call-foreign-function derive-type)
-	      ((name return-type arg-types &rest args))
-  (assert (constant-continuation-p return-type))
-  (assert (constant-continuation-p arg-types))
-  (let ((return-type (continuation-value return-type))
-	(arg-types (continuation-value arg-types)))
-    (unless (= (length arg-types) (length args))
-      (error "Different number of argument types (~D) from arguments (~D)."
-	     (length arg-types)
-	     (length args)))
-    (dolist (type arg-types)
-      (let ((arg (pop args)))
-	(assert-continuation-type arg (alien-type-type type))))
-    (if return-type
-	(alien-type-type return-type)
-	*universal-type*)))
-
-(defoptimizer (ext::call-foreign-function ltn-annotate)
-	      ((name return-type arg-types &rest args) node policy)
-  (setf (basic-combination-info node) :funny)
-  (setf (node-tail-p node) nil)
-  (dolist (arg args)
-    (annotate-ordinary-continuation arg policy)))
+(defknown naturalize (t alien-type) alien
+  (flushable movable))
+(defknown deport (alien alien-type) t
+  (flushable movable))
+(defknown extract-alien-value (system-area-pointer index alien-type) t
+  (flushable))
+(defknown deposit-alien-value (system-area-pointer index alien-type t) t
+  ())
 
-(defoptimizer (ext::call-foreign-function ir2-convert)
-	      ((name return-type arg-types &rest args) call block)
-  (assert (constant-continuation-p name))
-  (assert (constant-continuation-p return-type))
-  (assert (constant-continuation-p arg-types))
-  (let* ((name (continuation-value name))
-	 (return-type (continuation-value return-type))
-	 (arg-types (continuation-value arg-types))
-	 (cont (node-cont call)))
-    (multiple-value-bind (arg-tns stack-frame-size)
-			 (make-call-out-argument-tns arg-types)
-      (let ((nsp (make-call-out-nsp-tn))
-	    (args args))
-	(vop alloc-number-stack-space call block stack-frame-size nsp)
-	(dolist (tn arg-tns)
-	  (let* ((arg (pop args))
-		 (sc (tn-sc tn))
-		 (scn (sc-number sc))
-		 (temp-tn (make-representation-tn (tn-primitive-type tn)
-						  scn))
-		 (move-arg-vops (svref (sc-move-arg-vops sc) scn)))
-	    (assert arg)
-	    (assert (= (length move-arg-vops) 1) ()
-		    "No unique move-arg-vop for moves in SC ~S."
-		    (sc-name sc))
-	    (emit-move call block (continuation-tn call block arg) temp-tn)
-	    (emit-move-arg-template call block (first move-arg-vops)
-				    temp-tn nsp tn)))
-	(assert (null args)))
-
-      (let ((results (and return-type (make-call-out-result-tn return-type))))
-	(unless (listp results)
-	  (setf results (list results)))
-	(vop* call-out call block
-	      ((reference-tn-list arg-tns nil))
-	      ((reference-tn-list results t))
-	      name)
-	(vop dealloc-number-stack-space call block stack-frame-size)
-	(move-continuation-result call block results cont)))))
+(defknown alien-funcall (alien-value &rest *) *
+  (any recursive))
+(defknown %alien-funcall (system-area-pointer alien-type &rest *) *)
 
 
-;;;; Transforms for basic Alien accessors.
-;;;
-;;;    Open-coding these guys is probably worthwhile, since they are used
-;;; for real things.
-
-;;; Alien-Address source transform  --  Internal
-;;;
-;;;    Divide out the out the offset, producing a ratio if the alien
-;;; isn't byte aligned.
-;;;
-(def-source-transform alien-address (alien)
-  (multiple-value-bind (binds stuff res)
-		       (analyze-alien-expression nil alien)
-    `(let* ,(reverse binds)
-       ,(ignore-unreferenced-vars binds)
-       ,@(nreverse stuff)
-       (+ (sap-int ,(ct-a-val-sap res))
-	  (/ ,(ct-a-val-offset res) vm:byte-bits)))))
+;;;; Cosmetic transforms.
 
+(deftransform slot ((object slot)
+		    ((alien (* t)) symbol))
+  '(slot (deref object) slot))
 
-;;; Alien-SAP soruce transform  --  Internal
-;;;
-;;;
-(def-source-transform alien-sap (&whole source alien)
-  (multiple-value-bind (binds stuff res)
-		       (analyze-alien-expression nil alien)
-    `(let* ,(reverse binds)
-       ,(ignore-unreferenced-vars binds)
-       ,@(nreverse stuff)
-       (%aligned-sap ,(ct-a-val-sap res) ,(ct-a-val-offset res)
-		     ',source))))
-
-
-;;; Alien=>Lisp transform is defined in proclaim.lisp, since it is referenced
-;;; by top-level code in cold load.
-;;;
-(dolist (x '(alien-index alien-indirect))
-  (setf (info function source-transform x) #'alien=>lisp-transform))
+(deftransform %set-slot ((object slot value)
+			 ((alien (* t)) symbol t))
+  '(%set-slot (deref object) slot value))
 
+
+;;;; SLOT support
+
+(defun find-slot-offset-and-type (alien slot)
+  (unless (constant-continuation-p slot)
+    (give-up "Slot is not constant, so cannot open code access."))
+  (let ((type (continuation-type alien)))
+    (unless (alien-type-type-p type)
+      (give-up))
+    (let ((alien-type (alien-type-type-alien-type type)))
+      (unless (alien-record-type-p alien-type)
+	(give-up))
+      (let* ((slot-name (continuation-value slot))
+	     (field (find slot-name (alien-record-type-fields alien-type)
+			  :key #'alien-record-field-name)))
+	(unless field
+	  (abort-transform "~S doesn't have a slot named ~S" alien slot-name))
+	(values (alien-record-field-offset field)
+		(alien-record-field-type field))))))
+
+#+nil ;; Shouldn't be necessary.
+(defoptimizer (slot derive-type) ((alien slot))
+  (block nil
+    (catch 'give-up
+      (multiple-value-bind (slot-offset slot-type)
+			   (find-slot-offset-and-type alien slot)
+	(declare (ignore slot-offset))
+	(return (make-alien-type-type slot-type))))
+    *wild-type*))
+
+(deftransform slot ((alien slot))
+  (multiple-value-bind (slot-offset slot-type)
+		       (find-slot-offset-and-type alien slot)
+    `(extract-alien-value (alien-sap alien)
+			  ,slot-offset
+			  ',slot-type)))
+
+#+nil ;; ### But what about coersions?
+(defoptimizer (%set-slot derive-type) ((alien slot value))
+  (block nil
+    (catch 'give-up
+      (multiple-value-bind (slot-offset slot-type)
+			   (find-slot-offset-and-type alien slot)
+	(declare (ignore slot-offset))
+	(let ((type (make-alien-type-type slot-type)))
+	  (assert-continuation-type value type)
+	  (return type))))
+    *wild-type*))
+
+(deftransform %set-slot ((alien slot value))
+  (multiple-value-bind (slot-offset slot-type)
+		       (find-slot-offset-and-type alien slot)
+    `(deposit-alien-value (alien-sap alien)
+			  ,slot-offset
+			  ',slot-type
+			  value)))
+
+(defoptimizer (%slot-addr derive-type) ((alien slot))
+  (block nil
+    (catch 'give-up
+      (multiple-value-bind (slot-offset slot-type)
+			   (find-slot-offset-and-type alien slot)
+	(declare (ignore slot-offset))
+	(return (make-alien-type-type
+		 (make-alien-pointer-type :to slot-type)))))
+    *wild-type*))
+
+(deftransform %slot-addr ((alien slot))
+  (multiple-value-bind (slot-offset slot-type)
+		       (find-slot-offset-and-type alien slot)
+    `(%sap-alien (sap+ (alien-sap alien) (/ ,slot-offset vm:byte-bits))
+		 ',(make-alien-pointer-type :to slot-type))))
 
-;;; Alien-Value IR1 convert  --  Internal
-;;;
-;;;    Although all we do is call Alien=>Lisp-Transform, this must be a special
-;;; form, since the transformation must be done even when functions wouldn't be
-;;; transformed.
-;;;
-(def-ir1-translator alien-value ((&whole form x) start cont)
-  x ; Ignore
-  (ir1-convert start cont (alien=>lisp-transform form)))
 
 
-;;;; Alien-Access:
-
-;;; Alien-Access source transform  --  Internal
-;;;
-;;;    We analyze the alien expression, converting to a call to %Alien-Access
-;;; with the alien parts as separate arguments.
-;;;
-(def-source-transform alien-access (&whole form alien &optional lisp-type)
-  (multiple-value-bind (binds stuff res)
-		       (analyze-alien-expression nil alien)
-    `(let* ,(reverse binds)
-       ,(ignore-unreferenced-vars binds)
-       ,@(nreverse stuff)
-       (%alien-access ,(ct-a-val-sap res) ,(ct-a-val-offset res)
-		      ,(ct-a-val-size res) ',(ct-a-val-type res)
-		      ,lisp-type ',form))))
-
-(defknown %alien-access
-	  (system-area-pointer unsigned-byte unsigned-byte t t t) t
-  (movable flushable))
-
-;;; %Alien-Access transform  --  Internal
-;;;
-;;;    If we can figure out the alien and lisp types at compile time, then
-;;; expand into the appropriate access form.
-;;;
-(deftransform %alien-access ((sap offset size type lisp-type form))
-  (unless (constant-continuation-p lisp-type)
-    (give-up "Lisp-Type not constant, so cannot open-code."))
-
-  (let ((type (continuation-value type))
-	(lisp-type (continuation-value lisp-type))
-	(form (continuation-value form)))
-    (unless type
-      (give-up "Alien type unknown, so cannot open-code."))
+;;;; DEREF support.
+
+(defun find-deref-alien-type (alien)
+  (let ((alien-type (continuation-type alien)))
+    (unless (alien-type-type-p alien-type)
+      (give-up))
+    (let ((alien-type (alien-type-type-alien-type alien-type)))
+      (if (alien-type-p alien-type)
+	  alien-type
+	  (give-up)))))
+
+(defun find-deref-element-type (alien)
+  (let ((alien-type (find-deref-alien-type alien)))
+    (typecase alien-type
+      (alien-pointer-type
+       (alien-pointer-type-to alien-type))
+      (alien-array-type
+       (alien-array-type-element-type alien-type))
+      (t
+       (give-up)))))
+
+(defun compute-deref-guts (alien indices)
+  (let ((alien-type (find-deref-alien-type alien)))
+    (typecase alien-type
+      (alien-pointer-type
+       (when (cdr indices)
+	 (abort-transform "Too many indices for pointer deref: ~D"
+			  (length indices)))
+       (let ((element-type (alien-pointer-type-to alien-type)))
+	 (if indices
+	     (let ((bits (alien-type-bits element-type))
+		   (alignment (alien-type-alignment element-type)))
+	       (unless bits
+		 (abort-transform "Unknown element size."))
+	       (unless alignment
+		 (abort-transform "Unknown element alignment."))
+	       (values '(offset)
+		       `(* offset
+			   ,(align-offset bits alignment))
+		       element-type))
+	     (values nil 0 element-type))))
+      (alien-array-type
+       (let* ((element-type (alien-array-type-element-type alien-type))
+	      (bits (alien-type-bits element-type))
+	      (alignment (alien-type-alignment element-type))
+	      (dims (alien-array-type-dimensions alien-type)))
+	 (unless (= (length indices) (length dims))
+	   (give-up "Incorrect number of indices."))
+	 (unless bits
+	   (give-up "Element size unknown."))
+	 (unless alignment
+	   (give-up "Element alignment unknown."))
+	 (if (null dims)
+	     (values nil 0 element-type)
+	     (let* ((arg (gensym))
+		    (args (list arg))
+		    (offsetexpr arg))
+	       (dolist (dim (cdr dims))
+		 (let ((arg (gensym)))
+		   (push arg args)
+		   (setf offsetexpr `(+ (* ,offsetexpr ,dim) ,arg))))
+	       (values (reverse args)
+		       `(* ,offsetexpr
+			   ,(align-offset bits alignment))
+		       element-type)))))
+      (t
+       (abort-transform "~S not either a pointer or array type."
+			alien-type)))))
+
+
+#+nil ;; Shouldn't be necessary.
+(defoptimizer (deref derive-type) ((alien &rest noise))
+  (declare (ignore noise))
+  (block nil
+    (catch 'give-up
+      (return (make-alien-type-type (find-deref-element-type alien))))
+    *wild-type*))
+
+(deftransform deref ((alien &rest indices))
+  (multiple-value-bind
+      (indices-args offset-expr element-type)
+      (compute-deref-guts alien indices)
+    `(lambda (alien ,@indices-args)
+       (extract-alien-value (alien-sap alien)
+			    ,offset-expr
+			    ',element-type))))
+
+#+nil ;; ### Again, the value might be coerced.
+(defoptimizer (%set-deref derive-type) ((alien value &rest noise))
+  (declare (ignore noise))
+  (block nil
+    (catch 'give-up
+      (let ((type (make-alien-type-type
+		   (make-alien-pointer-type
+		    :to (find-deref-element-type alien)))))
+	(assert-continuation-type value type)
+	(return type)))
+    *wild-type*))
+
+(deftransform %set-deref ((alien value &rest indices))
+  (multiple-value-bind
+      (indices-args offset-expr element-type)
+      (compute-deref-guts alien indices)
+    `(lambda (alien value ,@indices-args)
+       (deposit-alien-value (alien-sap alien)
+			    ,offset-expr
+			    ',element-type
+			    value))))
   
-    (let ((access (lisp::get-alien-access-method type lisp-type)))
-      (funcall access 'sap 'offset 'size type :read nil form))))
+(defoptimizer (%deref-addr derive-type) ((alien &rest noise))
+  (declare (ignore noise))
+  (block nil
+    (catch 'give-up
+      (return (make-alien-type-type
+	       (make-alien-pointer-type
+		:to (find-deref-element-type alien)))))
+    *wild-type*))
+
+(deftransform %deref-addr ((alien &rest indices))
+  (multiple-value-bind
+      (indices-args offset-expr element-type)
+      (compute-deref-guts alien indices)
+    `(lambda (alien ,@indices-args)
+       (%sap-alien (sap+ (alien-sap alien) (/ ,offset-expr vm:byte-bits))
+		   ',(make-alien-pointer-type :to element-type)))))
 
 
-;;; %Set-Alien-Access source transform  --  Internal
-;;;
-;;;    Like the source transform for Alien-Access, only different.
-;;;
-(def-source-transform %set-alien-access (&whole form alien lisp-type
-					 &optional (new-value nil nv-p))
-  (multiple-value-bind (binds stuff res)
-		       (analyze-alien-expression nil alien)
-    `(let* ,(reverse binds)
-       ,(ignore-unreferenced-vars binds)
-       ,@(nreverse stuff)
-       (%%set-alien-access ,(ct-a-val-sap res) ,(ct-a-val-offset res)
-			   ,(ct-a-val-size res) ',(ct-a-val-type res)
-			   ,(if nv-p lisp-type nil)
-			   ,(if nv-p new-value lisp-type)
-			   ',form))))
-
-(defknown %%set-alien-access
-	  (system-area-pointer unsigned-byte unsigned-byte t t t t) t)
-
-;;; %%Set-Alien-Access transform  --  Internal
-;;;
-;;;    Like %Alien-Access transform.  The alien-access experts don't return the
-;;; right value, cause it's a pain in the ass.  Since this is a Setf method, we
-;;; gotta return the right value.
-;;;
-(deftransform %%set-alien-access ((sap offset size type lisp-type new-value
-				       form))
-  (unless (constant-continuation-p lisp-type)
-    (give-up "Lisp-Type not constant, so cannot open-code."))
-
-  (let ((type (continuation-value type))
-	(lisp-type (continuation-value lisp-type))
-	(form (continuation-value form)))
-    (unless type
-      (give-up "Alien type unknown, so cannot open-code."))
-  
-    (let ((access (lisp::get-alien-access-method type lisp-type)))
-      `(progn
-	 ,(funcall access 'sap 'offset 'size type :write 'new-value
-		   form)
-	 new-value))))
-
 
-;;;; Alignment determination:
+;;;; Heap Alien Support.
+
+(defun heap-alien-sap-and-type (info)
+  (unless (constant-continuation-p info)
+    (give-up "Info not constant; can't open code."))
+  (let ((info (continuation-value info)))
+    (values (heap-alien-info-sap-form info)
+	    (heap-alien-info-type info))))
+
+#+nil ;; Shouldn't be necessary.
+(defoptimizer (%heap-alien derive-type) ((info))
+  (block nil
+    (catch 'give-up
+      (multiple-value-bind (sap type)
+			   (heap-alien-sap-and-type info)
+	(declare (ignore sap))
+	(return (make-alien-type-type type))))
+    *wild-type*))
+
+(deftransform %heap-alien ((info))
+  (multiple-value-bind (sap type)
+		       (heap-alien-sap-and-type info)
+    `(extract-alien-value ,sap 0 ',type)))
+
+#+nil ;; ### Again, deposit value might change the type.
+(defoptimizer (%set-heap-alien derive-type) ((info value))
+  (block nil
+    (catch 'give-up
+      (multiple-value-bind (sap type)
+			   (heap-alien-sap-and-type info)
+	(declare (ignore sap))
+	(let ((type (make-alien-type-type type)))
+	  (assert-continuation-type value type)
+	  (return type))))
+    *wild-type*))
+
+(deftransform %set-heap-alien ((info value) (heap-alien-info *))
+  (multiple-value-bind (sap type)
+		       (heap-alien-sap-and-type info)
+    `(deposit-alien-value ,sap 0 ',type value)))
+
+(defoptimizer (%heap-alien-addr derive-type) ((info))
+  (block nil
+    (catch 'give-up
+      (multiple-value-bind (sap type)
+			   (heap-alien-sap-and-type info)
+	(declare (ignore sap))
+	(return (make-alien-type-type (make-alien-pointer-type :to type)))))
+    *wild-type*))
+
+(deftransform %heap-alien-addr ((info))
+  (multiple-value-bind (sap type)
+		       (heap-alien-sap-and-type info)
+    `(%sap-alien ,sap ',type)))
 
-;;; Integer-Alignment  --  Internal
-;;;
-;;;    Returns the largest power of two which evenly divides its argument.
-;;; If N is not an integer 0 is returned. 
-;;;
-(defun integer-alignment (n)
-  (if (integerp n)
-      (if (zerop n)
-	  most-positive-fixnum
-	  (do ((i 0 (1+ i))
-	       (n (abs n) (ash n -1)))
-	      ((not (zerop (logand n 1))) i)))
-      0))
+
+;;;; Local (stack or register) alien support.
+
+(deftransform make-local-alien ((info))
+  (unless (constant-continuation-p info)
+    (abort-transform "Local Alien Info isn't constant?"))
+  (let* ((info (continuation-value info))
+	 (alien-type (local-alien-info-type info)))
+    (if (local-alien-info-force-to-memory-p info)
+	`(truly-the system-area-pointer
+		    (%primitive alloc-number-stack-space
+				,(ceiling (alien-type-bits alien-type)
+					  vm:byte-bits)))
+	(let* ((alien-rep-type-spec (compute-alien-rep-type alien-type))
+	       (alien-rep-type (specifier-type alien-rep-type-spec)))
+	  (cond ((csubtypep (specifier-type 'system-area-pointer)
+			    alien-rep-type)
+		 '(int-sap 0))
+		((ctypep 0 alien-rep-type) 0)
+		((ctypep 0.0f0 alien-rep-type) 0.0f0)
+		((ctypep 0.0d0 alien-rep-type) 0.0d0)
+		(t
+		 (compiler-error
+		  "Aliens of type ~S cannot be represented immediately."
+		  (unparse-alien-type alien-type))))))))
+
+(deftransform note-local-alien-type ((info var))
+  (unless (constant-continuation-p info)
+    (abort-transform "Local Alien Info isn't constant?"))
+  (let ((info (continuation-value info)))
+    (unless (local-alien-info-force-to-memory-p info)
+      (let ((var-node (continuation-use var)))
+	(when (ref-p var-node)
+	  (propagate-to-refs (ref-leaf var-node)
+			     (specifier-type
+			      (compute-alien-rep-type
+			       (local-alien-info-type info))))))))
+  'nil)
 
+(deftransform local-alien ((info var))
+  (unless (constant-continuation-p info)
+    (abort-transform "Local Alien Info isn't constant?"))
+  (let* ((info (continuation-value info))
+	 (alien-type (local-alien-info-type info)))
+    (if (local-alien-info-force-to-memory-p info)
+	`(extract-alien-value var 0 ',alien-type)
+	`(naturalize var ',alien-type))))
+
+(deftransform %local-alien-forced-to-memory-p ((info))
+  (unless (constant-continuation-p info)
+    (abort-transform "Local Alien Info isn't constant?"))
+  (let ((info (continuation-value info)))
+    (local-alien-info-force-to-memory-p info)))
+
+(deftransform %set-local-alien ((info var value))
+  (unless (constant-continuation-p info)
+    (abort-transform "Local Alien Info isn't constant?"))
+  (let* ((info (continuation-value info))
+	 (alien-type (local-alien-info-type info)))
+    (if (local-alien-info-force-to-memory-p info)
+	`(deposit-alien-value var 0 ',alien-type value)
+	'(error "This should be dead-code eleminated."))))
+
+(defoptimizer (%local-alien-addr derive-type) ((info var))
+  (if (constant-continuation-p info)
+      (let* ((info (continuation-value info))
+	     (alien-type (local-alien-info-type info)))
+	(make-alien-type-type (make-alien-pointer-type :to alien-type)))
+      *wild-type*))
+
+(deftransform %local-alien-addr ((info var))
+  (unless (constant-continuation-p info)
+    (abort-transform "Local Alien Info isn't constant?"))
+  (let* ((info (continuation-value info))
+	 (alien-type (local-alien-info-type info)))
+    (if (local-alien-info-force-to-memory-p info)
+	`(%sap-alien var ',(make-alien-pointer-type :to alien-type))
+	(error "This shouldn't happen."))))
+
+(deftransform dispose-local-alien ((info var))
+  (unless (constant-continuation-p info)
+    (abort-transform "Local Alien Info isn't constant?"))
+  (let* ((info (continuation-value info))
+	 (alien-type (local-alien-info-type info)))
+    (if (local-alien-info-force-to-memory-p info)
+	`(%primitive dealloc-number-stack-space
+		     ,(ceiling (alien-type-bits alien-type)
+			       vm:byte-bits))
+	nil)))
 
-;;; Find-Alignment  --  Internal
-;;;
-;;;    This function is used to find out if offsets are some multiple of a
-;;; power of two.  The largest exponent of two which evenly the value of Cont
-;;; is returned.  0 is returned if we can't figure out anything, or the result
-;;; isn't an integer.  If the value is known to be 0, then we return
-;;; most-positive-fixnum.
-;;;
-(defun find-alignment (cont)
-  (declare (type continuation cont))
-  (let ((use (continuation-use cont)))
-    (cond ((and (combination-p use)
-		(= (length (combination-args use)) 2))
-	   (let* ((name (continuation-function-name (combination-fun use)))
-		  (args (combination-args use))
-		  (x (first args))
-		  (y (second args)))
-	     (case name
-	       ((+ -)
-		(min (find-alignment x) (find-alignment y)))
-	       (*
-		(let ((itype (specifier-type 'integer)))
-		  (if (and (csubtypep (continuation-type x) itype)
-			   (csubtypep (continuation-type y) itype))
-		      (+ (find-alignment x) (find-alignment y))
-		      0)))
-	       (ash
-		(if (constant-continuation-p y)
-		    (let ((val (continuation-value y)))
-		      (if (integerp val)
-			  (+ (find-alignment x) val)
-			  0))
-		    0))
-	       (t
-		0))))
-	  ((constant-continuation-p cont)
-	   (integer-alignment (continuation-value cont)))
-	  (t
-	   0))))
-
-;;; Find-Bit-Offset  --  Internal
-;;;
-;;;    Returns the value of (rem Exp From) if this can be determined at
-;;; compile-time, or Nil otherwise.  From must be a power of two.
-;;;
-(defun find-bit-offset (exp &optional (from 16))
-  (declare (type continuation exp) (type unsigned-byte from))
-  (let ((use (continuation-use exp)))
-    (cond ((constant-continuation-p exp)
-	   (rem (continuation-value exp) from))
-	  ((>= (find-alignment exp) (1- (integer-length from)))
-	   0)
-	  ((and (combination-p use)
-		(= (length (combination-args use)) 2))
-	   (let* ((name (continuation-function-name (combination-fun use)))
-		  (args (combination-args use))
-		  (x (find-bit-offset (first args) from))
-		  (y (find-bit-offset (second args) from)))
-	     (when (and x y)
-	       (case name
-		 (+ (rem (+ x y) from))
-		 (t nil)))))
+
+;;;; %CAST
+
+(defoptimizer (%cast derive-type) ((alien type))
+  (or (when (constant-continuation-p type)
+	(let ((alien-type (continuation-value type)))
+	  (when (alien-type-p alien-type)
+	    (make-alien-type-type alien-type))))
+      *wild-type*))
+
+(deftransform %cast ((alien target-type))
+  (unless (constant-continuation-p target-type)
+    (give-up "Alien type not constant; cannot open code."))
+  (let ((target-type (continuation-value target-type)))
+    (cond ((or (alien-pointer-type-p target-type)
+	       (alien-array-type-p target-type)
+	       (alien-function-type-p target-type))
+	   `(naturalize (alien-sap alien) ',target-type))
 	  (t
-	   nil))))
+	   (abort-transform "Cannot cast to alien type ~S" target-type)))))
 
 
-;;;; Reading and writing integers.
-;;;
-;;;    This code is used by many of the Alien-Access experts, since many
-;;; operations reduce to reading and writing integers.
-
-;;; Sign-Extend  --  Internal
-;;;
-;;;    Wrap code around Form to sign-extend a Size-bit integer if Signed,
-;;; otherwise just return arg.
-;;;
-(defun sign-extend (form size &optional (signed t))
-  (if signed
-      `(let ((res ,form))
-	 (if (zerop (logand res ,(ash 1 (1- size))))
-	     res
-	     (logior res ,(ash -1 size))))
-      form))
-
+;;;; alien-sap, %sap-alien, %addr, etc
+
+(deftransform alien-sap ((alien))
+  (let ((alien-node (continuation-use alien)))
+    (typecase alien-node
+      (combination
+       (extract-function-args alien '%sap-alien 2)
+       '(lambda (sap type)
+	  (declare (ignore type))
+	  sap))
+      (t
+       (give-up)))))
 
-(defknown naturalize-integer
-	  (t system-area-pointer unsigned-byte unsigned-byte t) integer
-  (flushable))
+(defoptimizer (%sap-alien derive-type) ((sap type))
+  (declare (ignore sap))
+  (if (constant-continuation-p type)
+      (make-alien-type-type (continuation-value type))
+      *wild-type*))
 
-;;; Naturalize-Integer Transform  --  Internal
-;;;
-;;;    Compile a call to Naturalize-Integer in some tense fashion.
-;;; The number may be signed or unsigned.  The integer may be any size and
-;;; alignment, as long as it fits within a word, otherwise it must be
-;;; exactly 16 or 32 bits and be word-aligned.  The size must be a
-;;; compile-time constant and is assumed to have been checked for
-;;; correctness.
-;;;
-;;; ### Note that the alignment check will fail if the SAP isn't 32 bit
-;;; aligned.  Now that we don't generally squeeze offsets into the sap, this is
-;;; probably usually true.  Eventually, we should guarantee that the SAP is
-;;; 32 bit aligned.
-;;; 
-(deftransform naturalize-integer ((signed sap offset size form))
-  (unless (constant-continuation-p size)
-    (give-up "Size not constant, so cannot open-code integer access:~%~S"
-	     (continuation-value form)))
-  
-  (let ((align (find-alignment offset))
-	(size (continuation-value size))
-	(signed (continuation-value signed))
-	(bits (find-bit-offset offset)))
-    (cond
-     ((and (= size 32) (> align 4))
-      (if signed
-	  '(signed-sap-ref-32 sap (ash offset -5))
-	  '(sap-ref-32 sap (ash offset -5))))
-     ((and (= size 16) (> align 3))
-      (if signed
-	  '(signed-sap-ref-16 sap (ash offset -4))
-	  '(sap-ref-16 sap (ash offset -4))))
-     ((and (= size 8) (> align 2))
-      (if signed
-	  '(signed-sap-ref-8 sap (ash offset -3))
-	  '(sap-ref-8 sap (ash offset -3))))
-     ((not bits)
-      (give-up "Can't determine offset within word, so cannot open-code:~%~S"
-	       (continuation-value form)))
-     ((<= (+ bits size) 32)
-      (sign-extend `(ldb (byte ,size ,bits)
-			 (sap-ref-32 sap (ash offset -5)))
-		   size signed))
-     ((> size 32)
-      (give-up "Accesses of ~D bits unsupported:~%~S"
-	       size (continuation-value form)))
-     (t
-      ;; If the integer spans a boundry, how we combine the two partial results
-      ;; depends on the target byte order.
-      ;;
-      ;; little-endian:
-      ;;   0   1   2   3   4   5   6   7
-      ;; 7      07      07      07      0
-      ;; [  ][  ][  ][  ][  ][  ][  ][  ]
-      ;; 210                          543
-      ;;  We get the low bits from the high part of the first word and
-      ;; the high bits from the low part of the second word.
-      ;; 
-      ;; big-endian: 
-      ;;   0   1   2   3   4   5   6   7
-      ;; 7      07      07      07      0
-      ;; [  ][  ][  ][  ][  ][  ][  ][  ]
-      ;;              543210
-      ;;  We get the low bits from the high part of the second word
-      ;; and the high bits from the low part of the first.
-      ;;
-      ;; Therefore, the only difference is which byte to use for what.
-      ;; What bits to use from each byte is constant.
-      ;; 
-      ;; We sign extend the high bits instead of the entire value because
-      ;; it has a higher probability of being a fixnum.
-      ;; 
-      (let* ((high-bits (- 32 bits))
-	     (low-bits (- size high-bits)))
-	(multiple-value-bind (low-byte high-byte)
-			     (ecase (backend-byte-order *backend*)
-			       (:little-endian
-				(values 'offset '(1+ offset)))
-			       (:big-endian
-				(values '(1+ offset) 'offset)))
-	  `(let ((offset (ash offset -5)))
-	     (logior (ash ,(sign-extend `(ldb (byte ,high-bits 0)
-					      (sap-ref-32 sap ,high-byte))
-					size signed)
-			  ,low-bits)
-		     (ash (sap-ref-32 sap ,low-byte)
-			  ,(- (- 32 low-bits)))))))))))
-
-
-(defknown deport-integer
-	  (t system-area-pointer unsigned-byte unsigned-byte integer t) void
-  ())
+
+;;;; Extract/deposit magic
+
+(eval-when (compile eval)
+  (defmacro compiler-error-if-loses (form)
+    `(handler-case
+	 ,form
+       (error (condition)
+	 (compiler-error "~A" condition)))))
+
+(deftransform naturalize ((object type))
+  (unless (constant-continuation-p type)
+    (give-up "Type not constant at compile time; can't open code."))
+  (compiler-error-if-loses
+   (compute-naturalize-lambda (continuation-value type))))
+
+(deftransform deport ((alien type))
+  (unless (constant-continuation-p type)
+    (give-up "Type not constant at compile time; can't open code."))
+  (compiler-error-if-loses
+   (compute-deport-lambda (continuation-value type))))
+
+(deftransform extract-alien-value ((sap offset type))
+  (unless (constant-continuation-p type)
+    (give-up "Type not constant at compile time; can't open code."))
+  (compiler-error-if-loses
+   (compute-extract-lambda (continuation-value type))))
+
+(deftransform deposit-alien-value ((sap offset type value))
+  (unless (constant-continuation-p type)
+    (give-up "Type not constant at compile time; can't open code."))
+  (compiler-error-if-loses
+   (compute-deposit-lambda (continuation-value type))))
 
-;;; Deport-Integer transform  --  Internal
-;;;
-;;;    Similar to Naturalize-Integer transform.
-;;;
-(deftransform deport-integer ((signed sap offset size value form))
-  (unless (constant-continuation-p size)
-    (give-up "Size not constant, so cannot open-code integer access:~%~S"
-	     (continuation-value form)))
-
-  (let ((align (find-alignment offset))
-	(size (continuation-value size))
-	(bits (find-bit-offset offset)))
-    (cond
-     ((and (= size 32) (> align 4))
-      '(setf (sap-ref-32 sap (ash offset -5)) value))
-     ((and (= size 16) (> align 3))
-      '(setf (sap-ref-16 sap (ash offset -4)) value))
-     ((and (= size 8) (> align 2))
-      '(setf (sap-ref-8 sap (ash offset -3)) value))
-     ((not bits)
-      (give-up "Can't determine offset within word, so cannot open-code:~%~S"
-	       (continuation-value form)))
-     ((<= (+ bits size) 32)
-      `(setf (ldb (byte ,size ,bits) (sap-ref-32 sap (ash offset -5)))
-	     value))
-     ((> size 32)
-      (give-up "Accesses of ~D bits unsupported:~%~S"
-	       size (continuation-value form)))
-     (t
-      ;;
-      ;; If the integer spans a 32 bit boundry, what we do depends on
-      ;; the byte order.  See the comments in naturalize-integer.
-      ;; 
-      (let* ((high-bits (- 32 bits))
-	     (low-bits (- size high-bits)))
-	(multiple-value-bind (low-byte high-byte)
-			     (ecase (backend-byte-order *backend*)
-			       (:little-endian
-				(values 'offset '(1+ offset)))
-			       (:big-endian
-				(values '(1+ offset) 'offset)))
-	  `(let ((offset (ash offset -5)))
-	     (setf (ldb (byte ,high-bits 0)
-			(sap-ref-32 sap ,high-byte))
-		   (ash value ,(- low-bits)))
-	     (setf (ldb (byte ,low-bits ,(- 32 low-bits))
-			(sap-ref-32 sap ,low-byte))
-		   value))))))))
+
+;;;; Hack to clean up divisions.
+
+(defun count-low-order-zeros (thing)
+  (typecase thing
+    (continuation
+     (if (constant-continuation-p thing)
+	 (count-low-order-zeros (continuation-value thing))
+	 (count-low-order-zeros (continuation-use thing))))
+    (combination
+     (case (continuation-function-name (combination-fun thing))
+       ((+ -)
+	(let ((min most-positive-fixnum)
+	      (itype (specifier-type 'integer)))
+	  (dolist (arg (combination-args thing) min)
+	    (if (csubtypep (continuation-type arg) itype)
+		(setf min (min min (count-low-order-zeros arg)))
+		(return 0)))))
+       (*
+	(let ((result 0)
+	      (itype (specifier-type 'integer)))
+	  (dolist (arg (combination-args thing) result)
+	    (if (csubtypep (continuation-type arg) itype)
+		(setf result (+ result (count-low-order-zeros arg)))
+		(return 0)))))
+       (ash
+	(let ((args (combination-args thing)))
+	  (if (= (length args) 2)
+	      (let ((amount (second args)))
+		(if (constant-continuation-p amount)
+		    (max (+ (count-low-order-zeros (first args))
+			    (continuation-value amount))
+			 0)
+		    0))
+	      0)))
+       (t
+	0)))
+    (integer
+     (if (zerop thing)
+	 most-positive-fixnum
+	 (do ((result 0 (1+ result))
+	      (num thing (ash num -1)))
+	     ((logbitp 0 num) result))))
+    (t
+     0)))
+
+(deftransform / ((numerator denominator) (integer integer))
+  (unless (constant-continuation-p denominator)
+    (give-up))
+  (let* ((denominator (continuation-value denominator))
+	 (bits (1- (integer-length denominator))))
+    (unless (= (ash 1 bits) denominator)
+      (give-up))
+    (let ((alignment (count-low-order-zeros numerator)))
+      (unless (>= alignment bits)
+	(give-up))
+      `(ash numerator ,(- bits)))))
+
+(deftransform ash ((value amount))
+  (let ((value-node (continuation-use value)))
+    (unless (and (combination-p value-node)
+		 (eq (continuation-function-name (combination-fun value-node))
+		     'ash))
+      (give-up))
+    (let ((inside-args (combination-args value-node)))
+      (unless (= (length inside-args) 2)
+	(give-up))
+      (let ((inside-amount (second inside-args)))
+	(unless (and (constant-continuation-p inside-amount)
+		     (not (minusp (continuation-value inside-amount))))
+	  (give-up)))))
+  (extract-function-args value 'ash 2)
+  '(lambda (value amount1 amount2)
+     (ash value (+ amount1 amount2))))
 
 
-;;;; Boolean stuff:
+;;;; ALIEN-FUNCALL support.
+
+(deftransform alien-funcall ((function &rest args)
+			     ((alien (* t)) &rest *))
+  (let ((names (loop repeat (length args) collect (gensym))))
+    `(lambda (function ,@names)
+       (alien-funcall (deref function) ,@names))))
+
+(deftransform alien-funcall ((function &rest args))
+  (let ((type (continuation-type function)))
+    (unless (alien-type-type-p type)
+      (give-up "Can't tell function type at compile time."))
+    (let ((alien-type (alien-type-type-alien-type type)))
+      (unless (alien-function-type-p alien-type)
+	(give-up))
+      (let ((arg-types (alien-function-type-arg-types alien-type)))
+	(unless (= (length args) (length arg-types))
+	  (abort-transform "Wrong number of arguments.  Expected ~D, got ~D."
+			   (length arg-types) (length args)))
+	(collect ((params) (deports))
+	  (dolist (arg-type arg-types)
+	    (let ((param (gensym)))
+	      (params param)
+	      (deports `(deport ,param ',arg-type))))
+	  (let ((return-type (alien-function-type-result-type alien-type))
+		(body `(%alien-funcall (deport function ',alien-type)
+				       ',alien-type
+				       ,@(deports))))
+	    (if (alien-values-type-p return-type)
+		(collect ((temps) (results))
+		  (dolist (type (alien-values-type-values return-type))
+		    (let ((temp (gensym)))
+		      (temps temp)
+		      (results `(naturalize ,temp ',type))))
+		  (setf body
+			`(multiple-value-bind
+			     ,(temps)
+			     ,body
+			   (values ,@(results)))))
+		(setf body `(naturalize ,body ',return-type)))
+	    `(lambda (function ,@(params))
+	       ,body)))))))
+
+(defoptimizer (%alien-funcall ltn-annotate)
+	      ((function type &rest args) node policy)
+  (setf (basic-combination-info node) :funny)
+  (setf (node-tail-p node) nil)
+  (annotate-ordinary-continuation function policy)
+  (dolist (arg args)
+    (annotate-ordinary-continuation arg policy)))
 
-(defknown naturalize-boolean (system-area-pointer index index t) boolean
-  (flushable))
-(defknown deport-boolean (system-area-pointer index index t t) void ())
-
-;;; Naturalize and Deport Boolean transforms  --  Internal
-;;; 
-;;;     If the bit falls at a known position within a byte, then we can
-;;; test and set it using a single logical operation instead of extracting the
-;;; whole field.  If the value occupies a full byte/short/word, then then we
-;;; just do the access, rather than messing around with masks.
-;;;
-;;; When setting, we must always set the entire field, so we can only be clever
-;;; when the field is a single bit.
-;;;
-(deftransform naturalize-boolean ((sap offset size form))
-  (unless (constant-continuation-p size)
-    (give-up "Size not constant, so cannot open-code integer access:~% ~S"
-	     (continuation-value form)))
-
-  (let ((off (find-bit-offset offset 8))
-	(size (continuation-value size)))
-    (unless off
-      (give-up "Can't determine offset within word, so cannot open-code:~% ~S"
-	       (continuation-value form)))
-    (if (and (>= (find-alignment offset) 3)
-	     (member size '(8 16 32)))
-	`(not (zerop (naturalize-integer nil sap offset ,size
-					 ',(continuation-value form))))
-	`(not (zerop (logand (sap-ref-8 sap (ash (+ offset ,(1- size)) -3))
-			     ,(ash 1 (- 7 off))))))))
-;;;
-(deftransform deport-boolean ((sap offset size value form))
-  (unless (constant-continuation-p size)
-    (give-up "Size not constant, so cannot open-code integer access:~% ~S"
-	     (continuation-value form)))
-
-  (let ((off (find-bit-offset offset 8))
-	(size (continuation-value size)))
-    (unless off
-      (give-up "Can't determine offset within word, so cannot open-code:~% ~S"
-	       (continuation-value form)))
-    (if (= size 1)
-	`(let ((offset (ash offset -3)))
-	   (setf (ldb (byte 1 ,off) (sap-ref-8 sap offset))
-		 (if value 1 0)))
-	`(deport-integer nil sap offset ,size (if value 1 0)
-			 ',(continuation-value form)))))
+(defoptimizer (%alien-funcall ir2-convert)
+	      ((function type &rest args) call block)
+  (let ((type (if (constant-continuation-p type)
+		  (continuation-value type)
+		  (error "Something is broken.")))
+	(cont (node-cont call))
+	(args args))
+    (multiple-value-bind (nsp stack-frame-size arg-tns result-tns)
+			 (make-call-out-argument-tns type)
+      (vop alloc-number-stack-space call block stack-frame-size nsp)
+      (dolist (tn arg-tns)
+	(let* ((arg (pop args))
+	       (sc (tn-sc tn))
+	       (scn (sc-number sc))
+	       (temp-tn (make-representation-tn (tn-primitive-type tn) scn))
+	       (move-arg-vops (svref (sc-move-arg-vops sc) scn)))
+	  (assert arg)
+	  (assert (= (length move-arg-vops) 1) ()
+		  "No unique move-arg-vop for moves in SC ~S."
+		  (sc-name sc))
+	  (emit-move call block (continuation-tn call block arg) temp-tn)
+	  (emit-move-arg-template call block (first move-arg-vops)
+				  temp-tn nsp tn)))
+      (assert (null args))
+      (unless (listp result-tns)
+	(setf result-tns (list result-tns)))
+      (vop* call-out call block
+	    ((continuation-tn call block function)
+	     (reference-tn-list arg-tns nil))
+	    ((reference-tn-list result-tns t)))
+      (vop dealloc-number-stack-space call block stack-frame-size)
+      (move-continuation-result call block result-tns cont))))
diff --git a/compiler/generic/core.lisp b/compiler/generic/core.lisp
index a27e45afe11de124ca7b471448fa0e7e252096a6..ddd175f743a3e6f14145bc33c0118f8d3eca42df 100644
--- a/compiler/generic/core.lisp
+++ b/compiler/generic/core.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/generic/core.lisp,v 1.10 1991/04/28 03:11:06 wlott Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/core.lisp,v 1.11 1992/02/14 23:50:14 wlott Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -230,7 +230,7 @@
 	 (length (- end start))
 	 (current (code-instruction-stream-current stream))
 	 (new (sap+ current length)))
-    (when (pointer> new (code-instruction-stream-end stream))
+    (when (sap> new (code-instruction-stream-end stream))
       (error "Writing ~D bytes to ~S would cause it to overflow."
 	     length stream))
     (copy-to-system-area string (+ (* start vm:byte-bits)
diff --git a/compiler/globaldb.lisp b/compiler/globaldb.lisp
index d05d7f6c606560f4c9595b738d501efa916a80ec..5d184dad1dbf2c6787e68c258c7edb3b855d8e45 100644
--- a/compiler/globaldb.lisp
+++ b/compiler/globaldb.lisp
@@ -7,12 +7,10 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/globaldb.lisp,v 1.19 1991/12/14 09:09:24 wlott Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/globaldb.lisp,v 1.20 1992/02/14 23:47:07 wlott Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
-;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/globaldb.lisp,v 1.19 1991/12/14 09:09:24 wlott Exp $
-;;;
 ;;;    This file provides a functional interface to global information about
 ;;; named things in the system.  Information is considered to be global if it
 ;;; must persist between invocations of the compiler.  The use of a functional
@@ -35,16 +33,6 @@
 (use-package "EXTENSIONS")
 (use-package "SYSTEM")
 
-(deftype index () `(integer 0 ,most-positive-fixnum))
-
-;;; Undefined-Value  --  Public
-;;;
-;;;    This is here until we figure out what to do with it.
-;;;
-(proclaim '(inline undefined-value))
-(defun undefined-value ()
-  '%undefined%)
-
 (in-package "EXTENSIONS")
 (export '(info clear-info define-info-class define-info-type
 	       make-info-environment do-info *info-environment*
@@ -303,9 +291,6 @@
 (defun info-hash (x)
   (cond
    ((symbolp x)
-    #-new-compiler
-    (the fixnum (%primitive sxhash-simple-string (symbol-name x)))
-    #+new-compiler
     (%sxhash-simple-string (symbol-name x)))
    ((and (listp x)
 	 (eq (car x) 'setf))
@@ -314,12 +299,7 @@
 	(let ((name (car next)))
 	  (when (and (symbolp name) (null (cdr next)))
 	    (return-from info-hash
-			 (logxor #-new-compiler
-				 (the fixnum
-				      (%primitive sxhash-simple-string
-						  (symbol-name name)))
-				 #+new-compiler
-				 (%sxhash-simple-string (symbol-name name))
+			 (logxor (%sxhash-simple-string (symbol-name name))
 				 110680597))))))
     (sxhash x))
    (t
@@ -344,9 +324,8 @@
   (let* ((class (symbol-name class))
 	 (type (symbol-name type))
 	 (info (type-info-or-lose class type)))
-    `(#+new-compiler truly-the #-new-compiler the
-		     ,(type-info-type info)
-		     (get-info-value ,name ,(type-info-number info)))))
+    `(truly-the ,(type-info-type info)
+		(get-info-value ,name ,(type-info-number info)))))
 ;;;
 (define-setf-method info (class type name)
   "Set the global information for Name."
@@ -413,7 +392,6 @@
 				 (,class-var (class-info-name
 					      (type-info-class ,n-type-info)))
 				 (,value-var (svref ,n-entries ,n-type)))
-			     #+new-compiler
 			     (declare (ignorable ,type-var ,class-var
 						 ,value-var))
 			     ,@body
@@ -434,7 +412,6 @@
 				  (cdr ,n-names)))
 		       ((null ,n-names))
 	   (let ((,name-var (caar ,n-names)))
-	     #+new-compiler
 	     (declare (ignorable ,name-var))
 	     (do-anonymous ((,n-types (cdar ,n-names) (cdr ,n-types)))
 			   ((null ,n-types))
@@ -445,7 +422,6 @@
 			   (,class-var (class-info-name
 					(type-info-class ,n-type)))
 			   (,value-var (cdar ,n-types)))
-		       #+new-compiler
 		       (declare (ignorable ,type-var ,class-var ,value-var))
 		       ,@body))))))))))
 
@@ -999,23 +975,17 @@
 ;;; The kind of functional object being described.  If null, Name isn't a known
 ;;; functional object.
 (define-info-type function kind (member nil :function :macro :special-form)
-  #+new-compiler
-  (if (fboundp name) :function nil)
-  #-new-compiler
-  nil)
+  (if (fboundp name) :function nil))
 
 ;;; The type specifier for this function.
 (define-info-type function type ctype
-  #+new-compiler
   (if (fboundp name)
       (let ((def (fdefinition name)))
 	(if (eval:interpreted-function-p def)
 	    (eval:interpreted-function-type def)
 	    (specifier-type (%primitive function-type
 					(%primitive closure-function def)))))
-      (specifier-type 'function))
-  #-new-compiler
-  (specifier-type 'function))
+      (specifier-type 'function)))
 
 ;;; The Assumed-Type for this function, if we have to infer the type due to not
 ;;; having a declaration or definition.
@@ -1026,10 +996,7 @@
 ;;;  :assumed, from uses of the object.
 ;;;  :defined, from examination of the definition.
 (define-info-type function where-from (member :declared :assumed :defined)
-  #+new-compiler
-  (if (fboundp name) :defined :assumed)
-  #-new-compiler
-  :assumed)
+  (if (fboundp name) :defined :assumed))
 
 ;;; Lambda used for inline expansion of this function.
 (define-info-type function inline-expansion list)
@@ -1054,9 +1021,6 @@
 ;;; function.
 (define-info-type function ir1-transform (or function null list))
 
-;;; If a function is an alien-operator, then this is the Alien-Info.
-(define-info-type function alien-operator (or lisp::alien-info null) nil)
-
 ;;; If a function is a defstruct slot accessor or setter, then this is the
 ;;; defstruct-definition for the structure that it belongs to.
 (define-info-type function accessor-for (or defstruct-description null)
@@ -1082,15 +1046,10 @@
 (define-info-class variable)
 
 ;;; The kind of variable-like thing described.
-(define-info-type variable kind (member :special :constant :global)
-  #+new-compiler
+(define-info-type variable kind (member :special :constant :global :alien)
   (if (or (eq (symbol-package name) (symbol-package :end))
 	  (member name '(t nil)))
       :constant
-      :global)
-  #-new-compiler
-  (if (constantp name)
-      :constant
       :global))
 
 ;;; The declared type for this variable.
@@ -1102,16 +1061,11 @@
 
 ;;; The the lisp object which is the value of this constant, if known.
 (define-info-type variable constant-value t
-  #+new-compiler
   (if (boundp name)
-      (values (symbol-value name) t)
-      (values nil nil))
-  #-new-compiler
-  (if (constantp name)
       (values (symbol-value name) t)
       (values nil nil)))
 
-(define-info-type variable alien-value (or lisp::ct-a-val null) nil)
+(define-info-type variable alien-info (or extern-alien-info null) nil)
 
 (define-info-type variable documentation (or string null) nil)
 
@@ -1162,11 +1116,14 @@
 (define-info-class declaration)
 (define-info-type declaration recognized boolean)
 
-(define-info-class alien-stack)
-(define-info-type alien-stack info (or lisp::stack-info null) nil)
-
-(define-info-class enumeration)
-(define-info-type enumeration info (or lisp::enumeration-info null) nil)
+(define-info-class alien-type)
+(define-info-type alien-type kind (member :primitive :defined :unknown)
+  :unknown)
+(define-info-type alien-type translator (or function null) nil)
+(define-info-type alien-type definition (or alien-type null) nil)
+(define-info-type alien-type struct (or alien-type null) nil)
+(define-info-type alien-type union (or alien-type null) nil)
+(define-info-type alien-type enum (or alien-type null) nil)
 
 (define-info-class setf)
 
diff --git a/compiler/ir1tran.lisp b/compiler/ir1tran.lisp
index 1d9abe5b189fe6377e523887b02a1b7223d3f566..f544ec56334f01473edb1a4e3c736e568416cb3e 100644
--- a/compiler/ir1tran.lisp
+++ b/compiler/ir1tran.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/ir1tran.lisp,v 1.64 1992/02/07 14:42:57 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir1tran.lisp,v 1.65 1992/02/14 23:47:11 wlott Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -753,7 +753,7 @@
 	     (assert (eq (car var) 'MACRO))
 	     (new-vars `(,var-name . (MACRO . (the ,(first decl)
 						   ,(cdr var))))))
-	    (lisp::ct-a-val
+	    (heap-alien-info
 	     (compiler-error "Can't declare type of Alien variable: ~S."
 			     var-name)))))
 
@@ -989,6 +989,9 @@
   
   (cond ((not (eq (info variable where-from name) :assumed))
 	 (let ((found (find-free-variable name)))
+	   (when (heap-alien-info-p found)
+	     (compiler-error "Declaring an alien variable to be special: ~S"
+			     name))
 	   (when (or (not (global-var-p found))
 		     (eq (global-var-kind found) :constant))
 	     (compiler-error "Declaring a constant to be special: ~S." name))
@@ -1684,15 +1687,15 @@
   (declare (type continuation start cont) (symbol name))
   (let ((var (or (lexenv-find name variables) (find-free-variable name))))
     (etypecase var
-      (lisp::ct-a-val
-       (ir1-convert start cont `(alien-value ,name)))
-      (cons
-       (assert (eq (car var) 'MACRO))
-       (ir1-convert start cont (cdr var)))
       (leaf
        (when (and (lambda-var-p var) (lambda-var-ignorep var))
 	 (compiler-warning "Reading an ignored variable: ~S." name))
-       (reference-leaf start cont var nil))))
+       (reference-leaf start cont var nil))
+      (cons
+       (assert (eq (car var) 'MACRO))
+       (ir1-convert start cont (cdr var)))
+      (heap-alien-info
+       (ir1-convert start cont `(%heap-alien ',var)))))
   (undefined-value))
 
 
@@ -1705,7 +1708,7 @@
 ;;; is unknown, then we emit a warning.
 ;;;
 (defun find-free-variable (name)
-  (declare (values leaf))
+  (declare (values (or leaf heap-alien-info)))
   (unless (symbolp name)
     (compiler-error "Variable name is not a symbol: ~S." name))
   (or (gethash name *free-variables*)
@@ -1715,15 +1718,18 @@
 	(when (and (eq where-from :assumed) (eq kind :global))
 	  (note-undefined-reference name :variable))
 
-	(multiple-value-bind (val valp)
-			     (info variable constant-value name)
-	  (setf (gethash name *free-variables*)
-		(if (and (eq kind :constant) valp)
-		    (make-constant :value val  :name name
-				   :type (ctype-of val)
-				   :where-from where-from)
-		    (make-global-var :kind kind  :name name  :type type
-				     :where-from where-from)))))))
+	(setf (gethash name *free-variables*)
+	      (if (eq kind :alien)
+		  (info variable alien-info name)
+		  (multiple-value-bind
+		      (val valp)
+		      (info variable constant-value name)
+		    (if (and (eq kind :constant) valp)
+			(make-constant :value val  :name name
+				       :type (ctype-of val)
+				       :where-from where-from)
+			(make-global-var :kind kind  :name name  :type type
+					 :where-from where-from))))))))
 
 
 ;;; Reference-Constant  --  Internal
@@ -2948,8 +2954,9 @@
 	    (cons
 	     (assert (eq (car leaf) 'MACRO))
 	     (ir1-convert start cont `(setf ,(cdr leaf) ,(second things))))
-	    (lisp::ct-a-val
-	     (compiler-error "Can't set Alien variable: ~S." name))))
+	    (heap-alien-info
+	     (ir1-convert start cont
+			  `(%set-heap-alien ',leaf ,(second things))))))
 	(collect ((sets))
 	  (do ((thing things (cddr thing)))
 	      ((endp thing)
diff --git a/compiler/loadcom.lisp b/compiler/loadcom.lisp
index deb3d0a7e44923cbc8a6696b7070a028e7c5ac02..0e9e9bd3004594db8b6d3f66c31db9334036593e 100644
--- a/compiler/loadcom.lisp
+++ b/compiler/loadcom.lisp
@@ -28,6 +28,7 @@
 (load "c:typetran")
 (load "vm:vm-typetran")
 (load "c:float-tran")
+(load "c:saptran")
 (load "c:locall")
 (load "c:dfo")
 (load "c:ir1opt")
diff --git a/compiler/main.lisp b/compiler/main.lisp
index 8bfaa87c0b88598b60b3d0346be7d7f0f2d21abb..4a3c068f918f402f752016ea208a75ae5e4aeb5a 100644
--- a/compiler/main.lisp
+++ b/compiler/main.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/main.lisp,v 1.51 1992/02/12 17:39:51 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/main.lisp,v 1.52 1992/02/14 23:47:26 wlott Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -360,11 +360,12 @@
   (labels ((blast (x)
 	     (maphash #'(lambda (k v)
 			  (declare (ignore k))
-			  (setf (leaf-refs v)
-				(delete-if #'here-p (leaf-refs v)))
-			  (when (basic-var-p v)
-			    (setf (basic-var-sets v)
-				  (delete-if #'here-p (basic-var-sets v)))))
+			  (when (leaf-p v)
+			    (setf (leaf-refs v)
+				  (delete-if #'here-p (leaf-refs v)))
+			    (when (basic-var-p v)
+			      (setf (basic-var-sets v)
+				    (delete-if #'here-p (basic-var-sets v))))))
 		      x))
 	   (here-p (x)
 	     (eq (block-component (node-block x)) component)))
@@ -458,6 +459,7 @@
 	     (cdr summary) kind summary))))))
   
   (unless (or *converting-for-interpreter*
+	      (not *compile-verbose*)
 	      (and (not abort-p) (zerop abort-count)
 		   (zerop *compiler-error-count*)
 		   (zerop *compiler-warning-count*)
diff --git a/compiler/mips/c-call.lisp b/compiler/mips/c-call.lisp
index 54ed4e601eff3590a76f5712c7c8a65637dff25a..d0a125681bbef65de4006866fa22163e04b6f809 100644
--- a/compiler/mips/c-call.lisp
+++ b/compiler/mips/c-call.lisp
@@ -7,11 +7,11 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/c-call.lisp,v 1.7 1991/07/14 03:59:34 wlott Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/c-call.lisp,v 1.8 1992/02/14 23:50:27 wlott Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
-;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/c-call.lisp,v 1.7 1991/07/14 03:59:34 wlott Exp $
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/c-call.lisp,v 1.8 1992/02/14 23:50:27 wlott Exp $
 ;;;
 ;;; This file contains the VOPs and other necessary machine specific support
 ;;; routines for call-out to C.
@@ -19,114 +19,152 @@
 ;;; Written by William Lott.
 ;;;
 (in-package "MIPS")
+(use-package "ALIEN")
+(use-package "ALIEN-INTERNALS")
 
 (defun my-make-wired-tn (prim-type-name sc-name offset)
   (make-wired-tn (primitive-type-or-lose prim-type-name *backend*)
 		 (sc-number-or-lose sc-name *backend*)
 		 offset))
 
-(def-vm-support-routine make-call-out-nsp-tn ()
-  (my-make-wired-tn 'positive-fixnum 'any-reg nsp-offset))
-
-(def-vm-support-routine make-call-out-argument-tns (arg-types)
-  (let ((stack-frame-size 0)
-	(did-int-arg nil)
-	(float-args 0))
-    (collect ((tns))
-      (dolist (type arg-types)
-	(let ((name (if (consp type) (car type) type)))
-	  (ecase name
-	    ((unsigned-byte port)
-	     (if (< stack-frame-size 4)
-		 (tns (my-make-wired-tn 'unsigned-byte-32
-					'unsigned-reg
-					(+ stack-frame-size 4)))
-		 (tns (my-make-wired-tn 'unsigned-byte-32
-					'unsigned-stack
-					stack-frame-size)))
-	     (incf stack-frame-size)
-	     (setf did-int-arg t))
-	    (signed-byte
-	     (if (< stack-frame-size 4)
-		 (tns (my-make-wired-tn 'signed-byte-32
-					'signed-reg
-					(+ stack-frame-size 4)))
-		 (tns (my-make-wired-tn 'signed-byte-32
-					'signed-stack
-					stack-frame-size)))
-	     (incf stack-frame-size)
-	     (setf did-int-arg t))
-	    (system-area-pointer
-	     (if (< stack-frame-size 4)
-		 (tns (my-make-wired-tn 'system-area-pointer
-					'sap-reg
-					(+ stack-frame-size 4)))
-		 (tns (my-make-wired-tn 'system-area-pointer
-					'sap-stack
-					stack-frame-size)))
-	     (incf stack-frame-size)
-	     (setf did-int-arg t))
-	    (double-float
-	     ;; Round to a dual-word.
-	     (setf stack-frame-size (logandc2 (1+ stack-frame-size) 1))
-	     (cond ((>= stack-frame-size 4)
-		    (tns (my-make-wired-tn 'double-float
-					   'double-stack
-					   stack-frame-size)))
-		   ((and (not did-int-arg) (< float-args 2))
-		    (tns (my-make-wired-tn 'double-float
-					   'double-reg
-					   (+ (* float-args 2) 12))))
-		   (t
-		    (error "Can't put floats in int regs yet.")))
-	     (incf stack-frame-size 2)
-	     (incf float-args))
-	    (single-float
-	     (cond ((>= stack-frame-size 4)
-		    (tns (my-make-wired-tn 'single-float
-					   'single-stack
-					   stack-frame-size)))
-		   ((and (not did-int-arg) (< float-args 2))
-		    (tns (my-make-wired-tn 'single-float
-					   'single-reg
-					   (+ (* float-args 2) 12))))
-		   (t
-		    (error "Can't put floats in int regs yet.")))
-	     (incf stack-frame-size)
-	     (incf float-args)))))
-      (values (tns)
-	      (* stack-frame-size word-bytes)))))
-
-(def-vm-support-routine make-call-out-result-tn (type)
-  (let ((name (if (consp type) (car type) type)))
-    (ecase name
-      ((unsigned-byte port)
-       (my-make-wired-tn 'unsigned-byte-32 'unsigned-reg 2))
-      (signed-byte
-       (my-make-wired-tn 'signed-byte-32 'signed-reg 2))
-      (system-area-pointer
-       (my-make-wired-tn 'system-area-pointer 'sap-reg 2))
-      (double-float
-       (my-make-wired-tn 'double-float 'double-reg 0))
-      (single-float
-       (my-make-wired-tn 'single-float 'single-reg 0)))))
+(defstruct arg-state
+  (stack-frame-size 0)
+  (did-int-arg nil)
+  (float-args 0))
+
+(def-alien-type-method (integer :arg-tn) (type state)
+  (let ((stack-frame-size (arg-state-stack-frame-size state)))
+    (setf (arg-state-stack-frame-size state) (1+ stack-frame-size))
+    (setf (arg-state-did-int-arg state) t)
+    (multiple-value-bind
+	(ptype reg-sc stack-sc)
+	(if (alien-integer-type-signed type)
+	    (values 'signed-byte-32 'signed-reg 'signed-stack)
+	    (values 'unsigned-byte-32 'unsigned-reg 'unsigned-stack))
+      (if (< stack-frame-size 4)
+	  (my-make-wired-tn ptype reg-sc (+ stack-frame-size 4))
+	  (my-make-wired-tn ptype stack-sc stack-frame-size)))))
+
+(def-alien-type-method (alien::sap :arg-tn) (type state)
+  (declare (ignore type))
+  (let ((stack-frame-size (arg-state-stack-frame-size state)))
+    (setf (arg-state-stack-frame-size state) (1+ stack-frame-size))
+    (setf (arg-state-did-int-arg state) t)
+    (if (< stack-frame-size 4)
+	(my-make-wired-tn 'system-area-pointer
+			  'sap-reg
+			  (+ stack-frame-size 4))
+	(my-make-wired-tn 'system-area-pointer
+			  'sap-stack
+			  stack-frame-size))))
+
+(def-alien-type-method (double-float :arg-tn) (type state)
+  (declare (ignore type))
+  (let ((stack-frame-size (logandc2 (1+ (arg-state-stack-frame-size state)) 1))
+	(float-args (arg-state-float-args state)))
+    (setf (arg-state-stack-frame-size state) (+ stack-frame-size 2))
+    (setf (arg-state-float-args state) (1+ float-args))
+    (cond ((>= stack-frame-size 4)
+	   (my-make-wired-tn 'double-float
+			     'double-stack
+			     stack-frame-size))
+	  ((and (not (arg-state-did-int-arg state))
+		(< float-args 2))
+	   (my-make-wired-tn 'double-float
+			     'double-reg
+			     (+ (* float-args 2) 12)))
+	  (t
+	   (error "Can't put floats in int regs yet.")))))
+
+(def-alien-type-method (single-float :arg-tn) (type state)
+  (declare (ignore type))
+  (let ((stack-frame-size (arg-state-stack-frame-size state))
+	(float-args (arg-state-float-args state)))
+    (setf (arg-state-stack-frame-size state) (1+ stack-frame-size))
+    (setf (arg-state-float-args state) (1+ float-args))
+    (cond ((>= stack-frame-size 4)
+	   (my-make-wired-tn 'single-float
+			     'single-stack
+			     stack-frame-size))
+	  ((and (not (arg-state-did-int-arg state))
+		(< float-args 2))
+	   (my-make-wired-tn 'single-float
+			     'single-reg
+			     (+ (* float-args 2) 12)))
+	  (t
+	   (error "Can't put floats in int regs yet.")))))
+
+
+(defstruct result-state
+  (num-results 0))
+
+(def-alien-type-method (integer :result-tn) (type state)
+  (let ((num-results (result-state-num-results state)))
+    (setf (result-state-num-results state) (1+ num-results))
+    (multiple-value-bind
+	(ptype reg-sc)
+	(if (alien-integer-type-signed type)
+	    (values 'signed-byte-32 'signed-reg)
+	    (values 'unsigned-byte-32 'unsigned-reg))
+      (my-make-wired-tn ptype reg-sc (+ num-results 2)))))
+
+(def-alien-type-method (alien::sap :result-tn) (type state)
+  (declare (ignore type))
+  (let ((num-results (result-state-num-results state)))
+    (setf (result-state-num-results state) (1+ num-results))
+    (my-make-wired-tn 'system-area-pointer 'sap-reg (+ num-results 2))))
+    
+(def-alien-type-method (double-float :result-tn) (type state)
+  (declare (ignore type))
+  (let ((num-results (result-state-num-results state)))
+    (setf (result-state-num-results state) (1+ num-results))
+    (my-make-wired-tn 'double-float 'double-reg (* num-results 2))))
+
+(def-alien-type-method (single-float :result-tn) (type state)
+  (declare (ignore type))
+  (let ((num-results (result-state-num-results state)))
+    (setf (result-state-num-results state) (1+ num-results))
+    (my-make-wired-tn 'single-float 'single-reg (* num-results 2))))
+
+(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)
+  (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 (my-make-wired-tn 'positive-fixnum 'any-reg nsp-offset)
+	      (* (max (arg-state-stack-frame-size arg-state) 4) word-bytes)
+	      (arg-tns)
+	      (invoke-alien-type-method :result-tn
+					(alien-function-type-result-type type)
+					(make-result-state))))))
 
 
 (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 li res (make-fixup foreign-symbol :foreign))))
 
 (define-vop (call-out)
-  (:args (args :more t))
+  (:args (function :scs (sap-reg) :target v0)
+	 (args :more t))
   (:results (results :more t))
   (:ignore args results)
   (:save-p t)
-  (:info function)
-  (:temporary (:sc any-reg :offset 2 :to (:result 0)) v0)
+  (:temporary (:sc any-reg :offset 2 :from (:argument 0) :to (:result 0)) v0)
   (:temporary (:sc any-reg :offset lra-offset) lra)
   (:temporary (:sc any-reg :offset code-offset) code)
+  (:temporary (:sc non-descriptor-reg :to (:result 0)) ndescr)
   (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)
   (:vop-var vop)
   (:generator 0
@@ -134,8 +172,8 @@
 	  (cur-nfp (current-nfp-tn vop)))
       (when cur-nfp
 	(store-stack-tn nfp-save cur-nfp))
-      (inst compute-lra-from-code lra code lra-label v0)
-      (inst li v0 (make-fixup function :foreign))
+      (move v0 function)
+      (inst compute-lra-from-code lra code lra-label ndescr)
       (inst j (make-fixup "call_into_c" :foreign))
       (inst nop)
 
diff --git a/compiler/mips/parms.lisp b/compiler/mips/parms.lisp
index 0c46a7b6939f7ea5e12faa90d514a4f36a26c2f7..d547b4cd5136b642b39295376d50d7a23fc20279 100644
--- a/compiler/mips/parms.lisp
+++ b/compiler/mips/parms.lisp
@@ -7,11 +7,11 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/parms.lisp,v 1.98 1991/09/18 06:38:47 wlott Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/parms.lisp,v 1.99 1992/02/14 23:50:29 wlott Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
-;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/parms.lisp,v 1.98 1991/09/18 06:38:47 wlott Exp $
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/parms.lisp,v 1.99 1992/02/14 23:50:29 wlott Exp $
 ;;;
 ;;;    This file contains some parameterizations of various VM
 ;;; attributes for the MIPS.  This file is separate from other stuff so 
@@ -186,8 +186,8 @@
 
     ;; Interrupt Handling
     lisp::*free-interrupt-context-index*
-    mach::*interrupts-enabled*
-    mach::*interrupt-pending*
+    unix::*interrupts-enabled*
+    unix::*interrupt-pending*
 
     ;; Static functions.
     two-arg-+ two-arg-- two-arg-* two-arg-/ two-arg-< two-arg-> two-arg-=
diff --git a/compiler/mips/system.lisp b/compiler/mips/system.lisp
index 7f2e1b56f07dbd100e8fe852bc9fd00e4891fe06..ccd1444ff8fb935f2b5eb8eb13522c64c1a78f63 100644
--- a/compiler/mips/system.lisp
+++ b/compiler/mips/system.lisp
@@ -7,11 +7,11 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/system.lisp,v 1.42 1991/03/23 12:30:42 wlott Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/system.lisp,v 1.43 1992/02/14 23:50:32 wlott Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
-;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/system.lisp,v 1.42 1991/03/23 12:30:42 wlott Exp $
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/system.lisp,v 1.43 1992/02/14 23:50:32 wlott Exp $
 ;;;
 ;;;    MIPS VM definitions of various system hacking operations.
 ;;;
@@ -48,30 +48,6 @@
   (frob pointer> :gt))
 
 
-
-;;;; Random assertions VOPS.
-
-(define-vop (check-op)
-  (:args (x :scs (any-reg descriptor-reg))
-	 (y :scs (any-reg descriptor-reg)))
-  (:temporary (:type random  :scs (non-descriptor-reg)) temp)
-  (:vop-var vop)
-  (:save-p :compute-only)
-  (:policy :fast-safe))
-
-(define-vop (check<= check-op)
-  (:translate check<=)
-  (:generator 3
-    (let ((target (generate-error-code vop not-<=-error x y)))
-      (three-way-comparison x y :gt :signed nil target temp))))
-
-(define-vop (check= check-op)
-  (:translate check=)
-  (:generator 3
-    (let ((target (generate-error-code vop not-=-error x y)))
-      (three-way-comparison x y :eq :signed t target temp))))
-
-
 
 ;;;; Type frobbing VOPs
 
@@ -259,10 +235,10 @@
 ;;;; Other random VOPs.
 
 
-(defknown mach::do-pending-interrupt () (values))
-(define-vop (mach::do-pending-interrupt)
+(defknown unix::do-pending-interrupt () (values))
+(define-vop (unix::do-pending-interrupt)
   (:policy :fast-safe)
-  (:translate mach::do-pending-interrupt)
+  (:translate unix::do-pending-interrupt)
   (:generator 1
     (inst break vm:pending-interrupt-trap)))
 
diff --git a/compiler/proclaim.lisp b/compiler/proclaim.lisp
index 6b2e860b9e5fe18ca4868bba850bb58890c69562..c37274576d4ea28fd74f8649ae95179e51310988 100644
--- a/compiler/proclaim.lisp
+++ b/compiler/proclaim.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/proclaim.lisp,v 1.21 1992/02/05 18:34:02 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/proclaim.lisp,v 1.22 1992/02/14 23:47:30 wlott Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -208,12 +208,7 @@
 	  so that this slot accessor can be redefined:~%  ~S"
 	  (dd-name for) name)
 	 (undefine-structure for)
-	 (setf (info function kind name) :function)))
-     (when (info function alien-operator name)
-       (compiler-warning "Redefining alien operator as normal function:~%  ~S"
-			 name)
-       (setf (info function alien-operator name) nil)
-       (setf (info function source-transform name) nil)))
+	 (setf (info function kind name) :function))))
     (:macro
      (compiler-warning "~S previously defined as a macro." name)
      (setf (info function kind name) :function)
@@ -593,22 +588,3 @@
 (defun compiler-error-message (string &rest args)
   (apply #'warn string args))
 
-
-;;; Alien=>Lisp-Transform  --  Internal
-;;;
-;;;    This is the transform for alien-operators and other alien-valued
-;;; things which may be evaluated normally to yield an alien-value structure.
-;;;
-(defun alien=>lisp-transform (form)
-  (multiple-value-bind (binds stuff res)
-		       (analyze-alien-expression nil form)
-    `(let* ,(reverse binds)
-       ,(ignore-unreferenced-vars binds)
-       ,@(nreverse stuff)
-       ,(if (ct-a-val-alien res)
-	    (ct-a-val-alien res)
-	    `(lisp::make-alien-value
-	      ,(ct-a-val-sap res)
-	      ,(ct-a-val-offset res)
-	      ,(ct-a-val-size res)
-	      ',(ct-a-val-type res))))))
diff --git a/tools/comcom.lisp b/tools/comcom.lisp
index b348022e3c845d67a93d22d0a171dbe17a58d279..5b310f7afce458280cc8a2f9e9367294c30fd8f1 100644
--- a/tools/comcom.lisp
+++ b/tools/comcom.lisp
@@ -81,6 +81,7 @@
 (comf "target:compiler/typetran")
 (comf "target:compiler/generic/vm-typetran")
 (comf "target:compiler/float-tran")
+(comf "target:compiler/saptran")
 (comf "target:compiler/locall")
 (comf "target:compiler/dfo")
 (comf "target:compiler/checkgen")
diff --git a/tools/worldbuild.lisp b/tools/worldbuild.lisp
index 0184218686f0fc1684b4287566a4ac025c052a33..53958292d4eca3435fd3c1f02c59c79bcc060d09 100644
--- a/tools/worldbuild.lisp
+++ b/tools/worldbuild.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/tools/worldbuild.lisp,v 1.9 1992/02/13 09:10:54 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/tools/worldbuild.lisp,v 1.10 1992/02/14 23:46:35 wlott Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -68,7 +68,6 @@
     "target:code/irrat"
     "target:code/bignum"
     "target:code/defmacro"
-    "target:code/defrecord"
     "target:code/list"
     "target:code/hash"
     "target:code/macros"
@@ -82,8 +81,9 @@
     "target:code/extensions"
     "target:code/alieneval"
     "target:code/c-call"
-    "target:code/syscall"
-    "target:code/vm"
+    "target:code/sap"
+    "target:code/unix"
+    #+mach "target:code/mach"
     #+mach "target:code/mach-os"
     #+sunos "target:code/sunos-os"
     "target:code/serve-event"
@@ -97,16 +97,12 @@
     "target:code/backq"
     "target:code/sharpm"
     "target:code/load"
-    "target:code/machdef"
     ,@(when (string= (c:backend-name c:*backend*) "PMAX")
-	'("target:code/pmax-vm"
-	  "target:code/pmax-machdef"))
+	'("target:code/pmax-vm"))
     ,@(when (string= (c:backend-name c:*backend*) "SPARC")
-	'("target:code/sparc-vm"
-	  "target:code/sparc-machdef"))
+	'("target:code/sparc-vm"))
     ,@(when (string= (c:backend-name c:*backend*) "RT")
-	'("target:code/rt-vm"
-	  "target:code/rt-machdef"))
+	'("target:code/rt-vm"))
 
     "target:code/signal"
     "target:code/interr"
diff --git a/tools/worldcom.lisp b/tools/worldcom.lisp
index faf7b264e4bfb2e0c20167010c009ee141f7b519..68a3434e092d4d2a5da4e217fd48cdbb6c38ac07 100644
--- a/tools/worldcom.lisp
+++ b/tools/worldcom.lisp
@@ -1,12 +1,18 @@
-;;; -*- Package: User; Log: code.log -*-
+;;; -*- Package: USER -*-
 ;;;
 ;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; Spice Lisp is currently incomplete and under active development.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
+;;; This code was written as part of the CMU Common 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 CMU Common Lisp, please contact
+;;; Scott Fahlman or slisp-group@cs.cmu.edu.
+;;;
+(ext:file-comment
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/tools/worldcom.lisp,v 1.35 1992/02/14 23:46:37 wlott Exp $")
+;;;
 ;;; **********************************************************************
+;;;
+;;; This file contains noise to compile the lisp world.
+;;; 
 
 (in-package "USER")
 
@@ -66,10 +72,7 @@
 (comf "target:code/kernel")
 (comf "target:code/lispinit")
 (comf "target:code/fdefinition")
-#+mach (comf "target:code/mach-os")
-#+sunos (comf "target:code/sunos-os")
 
-(comf "target:code/interr")
 (comf "target:code/error")
 (comf "target:code/salterror")
 
@@ -80,6 +83,7 @@
 
 (comf "target:code/alieneval")
 (comf "target:code/c-call")
+(comf "target:code/sap")
 
 (comf "target:code/bit-bash")
 (comf "target:code/array")
@@ -93,17 +97,16 @@
 (comf "target:code/string")
 (comf "target:code/mipsstrops")
 
-(comf "target:code/machdef")
+(comf "target:code/unix")
+#+mach (comf "target:code/mach")
+#+mach (comf "target:code/mach-os")
+#+sunos (comf "target:code/sunos-os")
 
 (when (string= (c:backend-name c:*backend*) "PMAX")
-  (comf "target:code/pmax-machdef")
-  (comf "target:code/pmax-vm")
-  (comf "target:code/pmax-disassem"))
+  (comf "target:code/pmax-vm"))
 (when (string= (c:backend-name c:*backend*) "SPARC")
-  (comf "target:code/sparc-machdef")
   (comf "target:code/sparc-vm"))
 (when (string= (c:backend-name c:*backend*) "RT")
-  (comf "target:code/rt-machdef")
   (comf "target:code/rt-vm"))
 
 (comf "target:code/symbol")
@@ -137,8 +140,6 @@
 (comf "target:code/sharpm")
 (comf "target:code/backq")
 
-(comf "target:code/syscall")
-(comf "target:code/vm")
 (comf "target:code/serve-event")
 (pushnew :serve-event *features*)
 (comf "target:code/fd-stream")
@@ -151,6 +152,7 @@
 (comf "target:code/eval")
 
 (comf "target:code/signal")
+(comf "target:code/interr")
 (comf "target:code/debug-info")
 (comf "target:code/debug-int")
 (comf "target:code/debug")
@@ -187,6 +189,7 @@
 (comf "target:code/remote")
 
 (comf "target:code/setf-funs")
+(comf "target:code/exports")
 
 ;;; Compile basic macros that we assume are already in the compilation
 ;;; environment.  We inhibit compile-time definition to prevent these functions
@@ -198,7 +201,6 @@
 (let ((c:*compile-time-define-macros* nil))
   (comf "target:code/defstruct")
   (comf "target:code/defmacro")
-  (comf "target:code/defrecord")
   (comf "target:compiler/globaldb")
   ;; We can't compile anything after macros, 'cause it breaks the running lisp.
   (comf "target:code/macros"))
diff --git a/tools/worldload.lisp b/tools/worldload.lisp
index b4583ea82e5e3b1b1092e928c13820f9662773c6..a04b791f24c5d56d65aa79979cc9dc5ed32dbd9a 100644
--- a/tools/worldload.lisp
+++ b/tools/worldload.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/tools/worldload.lisp,v 1.40 1992/02/12 18:20:53 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/tools/worldload.lisp,v 1.41 1992/02/14 23:46:39 wlott Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -83,8 +83,6 @@
 (load "code:run-program")
 (load "code:query")
 (load "code:loop")
-(load "code:syscall") ; syscall gets cold-loaded, but we need to re-run some
-		      ; of the exports.
 (load "code:internet")
 (load "code:wire")
 (load "code:remote")