From b2d32f3de0383fbf3739c1c34930807798d33717 Mon Sep 17 00:00:00 2001
From: ram <ram>
Date: Mon, 9 Nov 1992 15:21:43 +0000
Subject: [PATCH] Initial revision

---
 pcl/bench.lisp            |  448 ++++++++
 pcl/dlisp.lisp            |  410 +++++++
 pcl/dlisp2.lisp           |  175 +++
 pcl/fast-init.lisp        |  895 +++++++++++++++
 pcl/inline.lisp           |  263 +++++
 pcl/misc-kcl-patches.text |  340 ++++++
 pcl/new-kcl-wrapper.text  | 2157 +++++++++++++++++++++++++++++++++++++
 pcl/slots-boot.lisp       |  396 +++++++
 8 files changed, 5084 insertions(+)
 create mode 100644 pcl/bench.lisp
 create mode 100644 pcl/dlisp.lisp
 create mode 100644 pcl/dlisp2.lisp
 create mode 100644 pcl/fast-init.lisp
 create mode 100644 pcl/inline.lisp
 create mode 100644 pcl/misc-kcl-patches.text
 create mode 100644 pcl/new-kcl-wrapper.text
 create mode 100644 pcl/slots-boot.lisp

diff --git a/pcl/bench.lisp b/pcl/bench.lisp
new file mode 100644
index 000000000..3b0273f20
--- /dev/null
+++ b/pcl/bench.lisp
@@ -0,0 +1,448 @@
+;;;-*- Mode: Lisp; Syntax: Common-lisp; Package: user -*- 
+
+(in-package :bench :use '(:lisp :pcl))
+
+;;;Here are a few homebrew benchmarks for testing out Lisp performance.
+;;; BENCH-THIS-LISP: benchmarks for common lisp.
+;;; BENCH-THIS-CLOS: benchmarks for CLOS.
+;;; BENCH-FLAVORS:    ditto for Symbolics flavors.
+;;; BE SURE TO CHANGE THE PACKAGE DEFINITION TO GET THE CLOS + LISP YOU WANT TO TEST.
+;;;
+;;;Each benchmark is reported as operations per second.  Without-interrupts is used,
+;;;  so the scheduler isn't supposed to get in the way.  Accuracy is generally
+;;;  between one and five percent.
+;;;
+;;;Elapsed time is measured using get-internal-run-time.  Because the accuracy of
+;;;  this number is fairly crude, it is important to use a large number of 
+;;;  iterations to get an accurate benchmark.  The function median-time may
+;;;  complain to you if you didn't pick enough iterations.
+;;;
+;;;July 1992.  Watch out!  In some cases the instruction being timed will be
+;;;  optimized away by a clever compiler.  Beware of benchmarks that are
+;;;  nearly as fast as *speed-of-empty-loop*.
+;;;
+;;;Thanks to Ken Anderson for much of this code.
+;;;
+;;; jeff morrill
+;;; jmorrill@bbn.com
+
+#+Genera
+(eval-when (compile load eval)
+  (import '(clos-internals::allocate-instance)))
+
+(proclaim '(optimize (speed 3) (safety 1) (space 0) #+lucid (compilation-speed 0)))
+
+;;;*********************************************************************
+
+(defvar *min-time* (/ 500 (float internal-time-units-per-second))
+  "At least 2 orders of magnitude larger than our time resolution.")
+
+(defmacro elapsed-time (form)
+  "Returns (1) the result of form and (2) the time (seconds) it takes to evaluate form."
+  ;; Note that this function is completely portable.
+  (let ((start-time (gensym)) (end-time (gensym)))
+    `(let ((,start-time (get-internal-run-time)))
+	 (values ,form
+		 (let ((,end-time (get-internal-run-time)))
+		   (/ (abs (- ,end-time ,start-time))
+		      ,(float internal-time-units-per-second)))))))
+
+(defmacro without-interruption (&body forms)
+  #+genera `(scl:without-interrupts ,@forms)
+  #+lucid `(lcl::with-scheduling-inhibited ,@forms)
+  #+allegro `(excl:without-interrupts ,@forms)
+  #+(and (not genera) (not lucid) (not allegro)) `(progn ,@forms))
+
+(defmacro median-time (form &optional (I 5))
+  "Return the median time it takes to evaluate form."
+  ;; I: number of samples to take.
+  `(without-interruption
+     (let ((results nil))
+       (dotimes (ignore ,I)
+	 (multiple-value-bind (ignore time) (elapsed-time ,form)
+	   (declare (ignore ignore))
+	   (if (< time *min-time*)
+	       (format t "~% Warning.  Evaluating ~S took only ~S seconds.~
+                          ~% You should probably use more iterations." ',form time))
+	   (push time results)))
+       (nth ,(truncate I 2) (sort results #'<)))))
+
+#+debug
+(defun test () (median-time (sleep 1.0)))
+
+;;;*********************************************************************
+
+;;;OPERATIONS-PER-SECOND actually does the work of computing a benchmark.  The amount
+;;;  of time it takes to execute the form N times is recorded, minus the time it
+;;;  takes to execute the empty loop.  OP/S = N/time.  This quantity is recomputed
+;;;  five times and the median value is returned.  Variance in the numbers increases
+;;;  when memory is being allocated (cons, make-instance, etc).
+
+(defmacro repeat (form N)
+  ;; Minimal loop
+  (let ((count (gensym)) (result (gensym)))
+    `(let ((,count ,N) ,result)
+       (loop 
+	 ;; If you don't use the setq, the compiler may decide that since the
+	 ;; result is ignored, FORM can be "compiled out" of the loop.
+	 (setq ,result ,form)
+	 (if (zerop (decf ,count)) (return ,result))))))
+
+(defun nempty (N)
+  "The empty loop."
+  (repeat nil N))
+
+(defun empty-speed (N) (median-time (nempty N)))
+
+(defun compute-empty-iterations (&optional (default 1000000))
+  (format t "~%Computing speed of empty loop...")
+  (let ((time nil))
+    (loop
+      (setq time (empty-speed default))
+      (if (< time *min-time*) (setq default (* default 10)) (return)))
+    (format t "done.")
+    default))
+
+(defvar *empty-iterations*)
+(defvar *speed-of-empty-loop*)
+
+(eval-when (load eval)
+  (setq *empty-iterations* (compute-empty-iterations))
+  (setq *speed-of-empty-loop* (/ (empty-speed *empty-iterations*)
+				 (float *empty-iterations*))))
+
+(defmacro operations-per-second (form N &optional (I 5))
+  "Return the number of times FORM can evaluate in one second."
+  `(let ((time (median-time (repeat ,form ,N) ,I)))
+     (/ (float ,N) (- time (* *speed-of-empty-loop* N)))))
+
+(defmacro bench (pretty-name name N &optional (stream t))
+  `(format ,stream "~%~A: ~30T~S" ,pretty-name (,name ,N)))
+
+;;;****************************************************************************
+
+;;;BENCH-THIS-LISP
+
+(defun Nmult (N)
+  (let ((a 2.1))
+    (operations-per-second (* a a) N)))
+
+(defun Nadd (N)
+  (let ((a 2.1))
+    (operations-per-second (+ a a) N))) 
+
+(defun square (x) (* x x))
+
+(defun funcall-1 (N)
+  ;; inlined
+  (let ((x 2.1))
+    (operations-per-second (funcall #'(lambda (a) (* a a)) x) N)))
+
+(defun f1 (n) n)
+
+(defun funcall-2 (N)
+  (let ((f #'f1) 
+	(x 2.1))
+    (operations-per-second (funcall f x) N)))
+
+(defun funcall-3 (N)
+  (let ((x 2.1))
+    (operations-per-second (f1 x) N)))
+
+(defun funcall-4 (N)
+  (let ((x 2.1))
+    (operations-per-second (funcall #'square x) N)))
+
+(defun funcall-5 (N)
+  (let ((x 2.1)
+	(f #'square))
+    (let ((g #'(lambda (x) 
+		 (operations-per-second (funcall f x) N))))
+      (funcall g x))))
+
+(defun Nsetf (N)
+  (let ((array (make-array 15)))
+    (operations-per-second (setf (aref array 5) t) N)))
+
+(defun Nsymeval (N) (operations-per-second (eval T) N))
+
+(defun Repeatuations (N) (operations-per-second (eval '(* 2.1 2.1)) N))
+
+(defun n-cons (N) (let ((a 1)) (operations-per-second (cons a a) N)))
+
+(defvar *object* t)
+(Defun nspecial (N) (operations-per-second (null *object*) N))
+
+(defun nlexical (N) 
+  (let ((o t))
+    (operations-per-second (null o) N)))
+
+(defun nfree (N) 
+  (let ((o t))
+    (let ((g #'(lambda ()
+		 #+genera (declare (sys:downward-function))
+		 (operations-per-second (null o) N))))
+      (funcall g))))
+
+(defun nfree2 (N) 
+  (let ((o t))
+    (let ((g #'(lambda ()
+		 (let ((f #'(lambda ()
+			      #+genera (declare (sys:downward-function))
+			      (operations-per-second (null o) N))))
+		   (funcall f)))))
+      (funcall g))))
+
+(defun ncompilations (N)
+  (let ((lambda-expression
+	  '(lambda (bar) (let ((baz t)) (if baz (cons bar nil))))))
+    (operations-per-second (compile 'bob lambda-expression) N)))
+
+(defun bench-this-lisp ()
+  (let ((N (/ *empty-iterations* 10)))
+    (bench "(* 2.1 2.1)" nmult N)
+    (bench "(+ 2.1 2.1)" nadd N)
+    (bench "funcall & (* 2.1 2.1)" funcall-3 N)
+    (bench "special reference" nspecial *empty-iterations*)
+    (bench "lexical reference" nlexical *empty-iterations*)
+    ;;  (bench "ivar reference" n-ivar-ref N)
+    (bench "(setf (aref array 5) t)" nsetf N)
+    (bench "(funcall lexical-f x)" funcall-2 N)
+    (bench "(f x)" funcall-3 N) 
+    ;;  (Bench "(eval t)" nsymeval 10000)
+    ;;  (bench "(eval '(* 2.1 2.1))" repeatuations 10000)
+    ;;  (bench "(cons 1 2)" n-cons 100000)
+    ;;  (bench "compile simple function" ncompilations 50)
+    ))
+
+;(bench-this-lisp)
+
+;;;**************************************************************
+
+#+genera
+(progn
+  
+(scl:defflavor bar (a b) ()
+  :initable-instance-variables
+  :writable-instance-variables)
+
+(scl:defflavor frob (c) (bar)
+  :initable-instance-variables
+  :writable-instance-variables)
+
+(scl:defmethod (hop bar) ()
+  a)
+
+(scl:defmethod (set-hop bar) (n)
+  (setq a n))
+
+(scl:defmethod (nohop bar) ()
+  5)
+
+(defun n-ivar-ref (N)
+  (let ((i (scl:make-instance 'bar :a 0 :b 0)))
+    (ivar-ref i N)))
+
+(scl:defmethod (ivar-ref bar) (N)
+  (operations-per-second b N))
+
+
+(defun Ninstances (N) (operations-per-second (flavor:make-instance 'bar) N))
+
+(defun n-svref (N)
+  (let ((instance (flavor:make-instance 'bar :a 1)))
+    (operations-per-second (scl:symbol-value-in-instance instance 'a) N)))
+(defun n-hop (N)
+  (let ((instance (flavor:make-instance 'bar :a 1)))
+    (operations-per-second (hop instance) n)))
+(defun n-gf (N)
+  (let ((instance (flavor:make-instance 'bar :a 1)))
+    (operations-per-second (nohop instance) n)))
+(defun n-set-hop (N)
+  (let ((instance (flavor:make-instance 'bar :a 1)))
+    (operations-per-second (set-hop instance) n)))
+(defun n-type-of (N)
+  (let ((instance (flavor:make-instance 'bar)))
+    (operations-per-second (flavor::%instance-flavor instance) N)))
+
+(defun n-bar-b (N)
+  (let ((instance (flavor:make-instance 'bar :a 0 :b 0)))
+    (operations-per-second (bar-b instance) N)))
+
+(defun n-frob-bar-b (N)
+  (let ((instance (flavor:make-instance 'frob :a 0 :b 0)))
+    (operations-per-second (bar-b instance) N)))
+
+(defun bench-flavors ()
+  (bench "flavor:make-instance (2 slots)" ninstances 5000)
+  (bench "flavor:symbol-value-in-instance" n-svref 100000)
+  (bench "1 method, 1 dispatch" n-gf 100000)
+  (bench "slot symbol in method (access)" n-hop 100000)
+  (bench "slot symbol in method (modify)" n-hop 100000)
+  (bench "slot accessor bar" n-bar-b 100000)
+  (bench "slot accessor frob" n-frob-bar-b 100000) 
+  (bench "instance-flavor" n-type-of 500000))
+
+) ; end of #+genera
+
+;;;**************************************************************
+
+;;;BENCH-THIS-CLOS
+;;; (evolved from Ken Anderson's tests of Symbolics CLOS)
+
+(defmethod strange ((x t)) t)			; default method
+(defmethod area ((x number)) 'green)		; builtin class
+
+(defclass point
+	  ()
+    ((x :initform 0 :accessor x :initarg :x)
+     (y :initform 0 :accessor y :initarg :y)))
+
+(defmethod color ((thing point)) 'red)
+(defmethod address ((thing point)) 'boston)
+(defmethod area ((thing point)) 0)
+(defmethod move-to ((p1 point) (p2 point)) 0)
+
+(defmethod x-offset ((thing point))
+  (with-slots (x y) thing x))
+
+(defmethod set-x-offset ((thing point) new-x)
+  (with-slots (x y) thing (setq x new-x)))
+
+(defclass box
+	  (point)
+    ((width :initform 10 :accessor width :initarg :width)
+     (height :initform 10 :accessor height :initarg :height)))
+
+(defmethod area ((thing box)) 0)
+(defmethod move-to ((box box) (point point)) 0)
+(defmethod address :around ((thing box)) (call-next-method))	
+
+(defvar p (make-instance 'point))
+(defvar b (make-instance 'box))
+
+(defun n-strange (N) (operations-per-second (strange 5) N))
+(defun n-accesses (N)
+  (let ((instance p))
+    (operations-per-second (x instance) N)))
+(defun n-color (N)
+  (let ((instance p))
+    (operations-per-second (color instance) n)))
+(defun n-call-next-method (N)
+  (let ((instance b))
+    (operations-per-second (address instance) n)))
+(defun n-area-1 (N)
+  (let ((instance p))
+    (operations-per-second (area instance) n)))
+(defun n-area-2 (N)
+  (operations-per-second (area 5) n))
+(defun n-move-1 (N)
+  (let ((instance p))
+    (operations-per-second (move-to instance instance) n)))
+(defun n-move-2 (N)
+  (let ((x p) (y b))
+    (operations-per-second (move-to x y) n)))
+(defun n-off (N)
+  (let ((instance p))
+    (operations-per-second (x-offset instance) n)))
+(defun n-setoff (N)
+  (let ((instance p))
+    (operations-per-second (set-x-offset instance 500) n)))
+(defun n-slot-value (N)
+  (let ((instance p))
+    (operations-per-second (slot-value instance 'x) n)))
+
+(defun n-class-of-1 (N)
+  (let ((instance p))
+    (operations-per-second (class-of instance) n)))
+(defun n-class-of-2 (N)
+  (operations-per-second (class-of 5) n))
+
+(defun n-alloc (N)
+  (let ((c (find-class 'point)))
+    (operations-per-second (allocate-instance c) n)))
+
+(defun n-make (N)
+  (operations-per-second (make-instance 'point) n))
+
+(defun n-make-initargs (N)
+  ;; Much slower than n-make!
+  (operations-per-second (make-instance 'point :x 0 :y 5) n))
+
+(defun n-make-variable-initargs (N)
+  ;; Much slower than n-make!
+  (let ((x 0)
+	(y 5))
+    (operations-per-second (make-instance 'point :x x :y y) n)))
+
+(pcl::expanding-make-instance-top-level
+
+(defun n-make1 (N)
+  (operations-per-second (make-instance 'point) n))
+
+(defun n-make-initargs1 (N)
+  ;; Much slower than n-make!
+  (operations-per-second (make-instance 'point :x 0 :y 5) n))
+
+(defun n-make-variable-initargs1 (N)
+  ;; Much slower than n-make!
+  (let ((x 0)
+	(y 5))
+    (operations-per-second (make-instance 'point :x x :y y) n)))
+
+)
+
+(pcl::precompile-random-code-segments)
+
+(defun bench-this-clos ()
+  (let ((N (/ *empty-iterations* 10)))
+    (bench "1 default method" n-strange N)
+    (bench "1 dispatch, 1 method" n-color N)
+    (bench "1 dispatch, :around + primary" n-call-next-method N)
+    (bench "1 dispatch, 3 methods, instance" n-area-1 N)
+    (bench "1 dispatch, 3 methods, noninstance" n-area-2 N)
+    (bench "2 dispatch, 2 methods" n-move-1 N)
+    (bench "slot reader method" n-accesses N)
+    (bench "with-slots (1 access)" n-off N)
+    (bench "with-slots (1 modify)" n-setoff N)
+    (bench "naked slot-value" n-slot-value N)
+    (bench "class-of instance" n-class-of-1 N)
+    (bench "class-of noninstance" n-class-of-2 N)
+    (bench "allocate-instance (2 slots)" n-alloc
+	   #+pcl 5000
+	   #+allegro 100000
+	   #+(and Genera (not pcl)) 100000
+	   #+(and Lucid (not pcl)) 10000)
+    (bench "make-instance (2 slots)" n-make
+	   #+pcl 5000
+	   #+allegro 100000
+	   #+(and Genera (not pcl)) 100000
+	   #+(and Lucid (not pcl)) 10000)
+    (bench "make-instance (2 constant initargs)" n-make-initargs
+	   #+pcl 1000
+	   #+allegro 100000
+	   #+(and Genera (not pcl)) 100000
+	   #+(and Lucid (not pcl)) 10000)
+    (bench "make-instance (2 variable initargs)" n-make-variable-initargs
+	   #+pcl 1000
+	   #+allegro 100000
+	   #+(and Genera (not pcl)) 100000
+	   #+(and Lucid (not pcl)) 10000)
+    
+    (bench "make-instance (2 slots)" n-make1
+	   #+pcl 5000
+	   #+allegro 100000
+	   #+(and Genera (not pcl)) 100000
+	   #+(and Lucid (not pcl)) 10000)
+    (bench "make-instance (2 constant initargs)" n-make-initargs1
+	   #+pcl 1000
+	   #+allegro 100000
+	   #+(and Genera (not pcl)) 100000
+	   #+(and Lucid (not pcl)) 10000)
+    (bench "make-instance (2 variable initargs)" n-make-variable-initargs1
+	   #+pcl 1000
+	   #+allegro 100000
+	   #+(and Genera (not pcl)) 100000
+	   #+(and Lucid (not pcl)) 10000)) )
+
+;(bench-this-clos)
diff --git a/pcl/dlisp.lisp b/pcl/dlisp.lisp
new file mode 100644
index 000000000..da9c8a261
--- /dev/null
+++ b/pcl/dlisp.lisp
@@ -0,0 +1,410 @@
+;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*-
+;;;
+;;; *************************************************************************
+;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
+;;; All rights reserved.
+;;;
+;;; Use and copying of this software and preparation of derivative works
+;;; based upon this software are permitted.  Any distribution of this
+;;; software or derivative works must comply with all applicable United
+;;; States export control laws.
+;;; 
+;;; This software is made available AS IS, and Xerox Corporation makes no
+;;; warranty about the software, its performance or its conformity to any
+;;; specification.
+;;; 
+;;; Any person obtaining a copy of this software is requested to send their
+;;; name and post office or electronic mail address to:
+;;;   CommonLoops Coordinator
+;;;   Xerox PARC
+;;;   3333 Coyote Hill Rd.
+;;;   Palo Alto, CA 94304
+;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
+;;;
+;;; Suggestions, comments and requests for improvements are also welcome.
+;;; *************************************************************************
+;;;
+
+(in-package 'pcl)
+
+;;; This file is (almost) functionally equivalent to dlap.lisp,
+;;; but easier to read.
+
+;;; Might generate faster code, too, depending on the compiler and 
+;;; whether an implementation-specific lap assembler was used.
+
+(defun emit-one-class-reader (class-slot-p)
+  (emit-reader/writer :reader 1 class-slot-p))
+
+(defun emit-one-class-writer (class-slot-p)
+  (emit-reader/writer :writer 1 class-slot-p))
+
+(defun emit-two-class-reader (class-slot-p)
+  (emit-reader/writer :reader 2 class-slot-p))
+
+(defun emit-two-class-writer (class-slot-p)
+  (emit-reader/writer :writer 2 class-slot-p))
+
+;;; --------------------------------
+
+(defun emit-one-index-readers (class-slot-p)
+  (emit-one-or-n-index-reader/writer :reader nil class-slot-p))
+
+(defun emit-one-index-writers (class-slot-p)
+  (emit-one-or-n-index-reader/writer :writer nil class-slot-p))
+
+(defun emit-n-n-readers ()
+  (emit-one-or-n-index-reader/writer :reader t nil))
+
+(defun emit-n-n-writers ()
+  (emit-one-or-n-index-reader/writer :writer t nil))
+
+;;; --------------------------------
+
+(defun emit-checking (metatypes applyp)
+  (emit-checking-or-caching nil nil metatypes applyp))
+
+(defun emit-caching (metatypes applyp)
+  (emit-checking-or-caching t nil metatypes applyp))
+
+(defun emit-in-checking-cache-p (metatypes)
+  (emit-checking-or-caching nil t metatypes nil))
+
+(defun emit-constant-value (metatypes)
+  (emit-checking-or-caching t t metatypes nil))
+
+;;; --------------------------------
+
+(defvar *precompiling-lap* nil)
+(defvar *emit-function-p* t)
+
+(defun emit-default-only (metatypes applyp)
+  (when (and (null *precompiling-lap*) *emit-function-p*)
+    (return-from emit-default-only
+      (emit-default-only-function metatypes applyp)))
+  (let* ((dlap-lambda-list (make-dlap-lambda-list metatypes applyp))
+	 (args (remove '&rest dlap-lambda-list))
+	 (restl (when applyp '(.lap-rest-arg.))))
+    (generating-lisp '(emf)
+		     dlap-lambda-list
+      `(invoke-effective-method-function emf ,applyp ,@args ,@restl))))
+      
+(defmacro emit-default-only-macro (metatypes applyp)
+  (let ((*emit-function-p* nil)
+	(*precompiling-lap* t))
+    (values
+     (emit-default-only metatypes applyp))))
+
+;;; --------------------------------
+
+(defun generating-lisp (closure-variables args form)
+  (let* ((rest (memq '&rest args))
+	 (ldiff (and rest (ldiff args rest)))
+	 (args (if rest (append ldiff '(&rest .lap-rest-arg.)) args))
+	 (lambda `(lambda ,closure-variables
+		    ,@(when (member 'miss-fn closure-variables)
+			`((declare (type function miss-fn))))
+		    #'(lambda ,args
+			(let ()
+			  (declare #.*optimize-speed*)
+			  ,form)))))
+    (values (if *precompiling-lap*
+		`#',lambda
+		(compile-lambda lambda))
+	    nil)))
+
+(defun emit-reader/writer (reader/writer 1-or-2-class class-slot-p)
+  (when (and (null *precompiling-lap*) *emit-function-p*)
+    (return-from emit-reader/writer
+      (emit-reader/writer-function reader/writer 1-or-2-class class-slot-p)))    
+  (let ((instance nil)
+	(arglist  ())
+	(closure-variables ())
+	(field (first-wrapper-cache-number-index))
+	(readp (eq reader/writer :reader))
+	(read-form (emit-slot-read-form class-slot-p 'index 'slots)))
+    ;;we need some field to do the fast obsolete check
+    (ecase reader/writer
+      (:reader (setq instance (dfun-arg-symbol 0)
+		     arglist  (list instance)))
+      (:writer (setq instance (dfun-arg-symbol 1)
+		     arglist  (list (dfun-arg-symbol 0) instance))))
+    (ecase 1-or-2-class
+      (1 (setq closure-variables '(wrapper-0 index miss-fn)))
+      (2 (setq closure-variables '(wrapper-0 wrapper-1 index miss-fn))))
+    (generating-lisp closure-variables
+		     arglist
+       `(let* (,@(unless class-slot-p `((slots nil)))
+	       (wrapper (cond ((std-instance-p ,instance)
+			       ,@(unless class-slot-p
+				   `((setq slots (std-instance-slots ,instance))))
+			       (std-instance-wrapper ,instance))
+			      ((fsc-instance-p ,instance)
+			       ,@(unless class-slot-p
+				   `((setq slots (fsc-instance-slots ,instance))))
+			       (fsc-instance-wrapper ,instance))))
+	       ,@(when readp '(value)))
+	  (if (or (null wrapper)
+		  (zerop (wrapper-cache-number-vector-ref wrapper ,field))
+		  (not (or (eq wrapper wrapper-0)
+			   ,@(when (eql 2 1-or-2-class)
+			       `((eq wrapper wrapper-1)))))
+		  ,@(when readp `((eq *slot-unbound* (setq value ,read-form)))))
+	      (funcall miss-fn ,@arglist)
+	      ,(if readp
+		   'value
+		   `(setf ,read-form ,(car arglist))))))))
+
+(defun emit-slot-read-form (class-slot-p index slots)
+  (if class-slot-p
+      `(cdr ,index)
+      `(%instance-ref ,slots ,index)))
+
+(defun emit-boundp-check (value-form miss-fn arglist)
+  `(let ((value ,value-form))
+     (if (eq value *slot-unbound*)
+	 (funcall ,miss-fn ,@arglist)
+	 value)))
+
+(defun emit-slot-access (reader/writer class-slot-p slots index miss-fn arglist)
+  (let ((read-form (emit-slot-read-form class-slot-p index slots)))
+    (ecase reader/writer
+      (:reader (emit-boundp-check read-form miss-fn arglist))
+      (:writer `(setf ,read-form ,(car arglist))))))
+
+(defmacro emit-reader/writer-macro (reader/writer 1-or-2-class class-slot-p)
+  (let ((*emit-function-p* nil)
+	(*precompiling-lap* t))
+    (values 
+     (emit-reader/writer reader/writer 1-or-2-class class-slot-p))))
+
+(defun emit-one-or-n-index-reader/writer (reader/writer cached-index-p class-slot-p)
+  (when (and (null *precompiling-lap*) *emit-function-p*)
+    (return-from emit-one-or-n-index-reader/writer
+      (emit-one-or-n-index-reader/writer-function
+       reader/writer cached-index-p class-slot-p)))
+  (multiple-value-bind (arglist metatypes)
+      (ecase reader/writer
+	(:reader (values (list (dfun-arg-symbol 0))
+			 '(standard-instance)))
+	(:writer (values (list (dfun-arg-symbol 0) (dfun-arg-symbol 1))
+			 '(t standard-instance))))
+    (generating-lisp `(cache ,@(unless cached-index-p '(index)) miss-fn)
+		     arglist
+      `(let (,@(unless class-slot-p '(slots))
+	     ,@(when cached-index-p '(index)))
+         ,(emit-dlap arglist metatypes
+		     (emit-slot-access reader/writer class-slot-p
+				       'slots 'index 'miss-fn arglist)
+		     `(funcall miss-fn ,@arglist)
+		     (when cached-index-p 'index)
+		     (unless class-slot-p '(slots)))))))
+
+(defmacro emit-one-or-n-index-reader/writer-macro
+    (reader/writer cached-index-p class-slot-p)
+  (let ((*emit-function-p* nil)
+	(*precompiling-lap* t))
+    (values
+     (emit-one-or-n-index-reader/writer reader/writer cached-index-p class-slot-p))))
+
+(defun emit-miss (miss-fn args &optional applyp)
+  (let ((restl (when applyp '(.lap-rest-arg.))))
+    (if restl
+	`(apply ,miss-fn ,@args ,@restl)
+	`(funcall ,miss-fn ,@args ,@restl))))
+
+(defun emit-checking-or-caching (cached-emf-p return-value-p metatypes applyp)
+  (when (and (null *precompiling-lap*) *emit-function-p*)
+    (return-from emit-checking-or-caching
+      (emit-checking-or-caching-function
+       cached-emf-p return-value-p metatypes applyp)))
+  (let* ((dlap-lambda-list (make-dlap-lambda-list metatypes applyp))
+	 (args (remove '&rest dlap-lambda-list))
+	 (restl (when applyp '(.lap-rest-arg.))))
+    (generating-lisp `(cache ,@(unless cached-emf-p '(emf)) miss-fn)
+		     dlap-lambda-list
+      `(let (,@(when cached-emf-p '(emf)))
+         ,(emit-dlap args
+	             metatypes
+	             (if return-value-p
+			 (if cached-emf-p 'emf t)
+			 `(invoke-effective-method-function emf ,applyp
+			   ,@args ,@restl))
+	             (emit-miss 'miss-fn args applyp)
+		     (when cached-emf-p 'emf))))))
+
+(defmacro emit-checking-or-caching-macro (cached-emf-p return-value-p metatypes applyp)
+  (let ((*emit-function-p* nil)
+	(*precompiling-lap* t))
+    (values
+     (emit-checking-or-caching cached-emf-p return-value-p metatypes applyp))))
+
+(defun emit-dlap (args metatypes hit miss value-reg &optional slot-regs)
+  (let* ((index -1)
+	 (wrapper-bindings (mapcan #'(lambda (arg mt)
+				       (unless (eq mt 't)
+					 (incf index)
+					 `((,(intern (format nil "WRAPPER-~D" index)
+					             *the-pcl-package*)
+					    ,(emit-fetch-wrapper mt arg 'miss
+					      (pop slot-regs))))))
+				   args metatypes))
+	 (wrappers (mapcar #'car wrapper-bindings)))
+    (declare (fixnum index))
+    (unless wrappers (error "Every metatype is T."))
+    `(block dfun
+       (tagbody
+	  (let ((field (cache-field cache))
+		(cache-vector (cache-vector cache))
+		(mask (cache-mask cache))
+		(size (cache-size cache))
+		(overflow (cache-overflow cache))
+		,@wrapper-bindings)
+	    (declare (fixnum size field mask))
+	    ,(cond ((cdr wrappers)
+		    (emit-greater-than-1-dlap wrappers 'miss value-reg))
+		   (value-reg
+		    (emit-1-t-dlap (car wrappers) 'miss value-reg))
+		   (t
+		    (emit-1-nil-dlap (car wrappers) 'miss)))
+	    (return-from dfun ,hit))
+	miss
+	  (return-from dfun ,miss)))))
+
+(defun emit-1-nil-dlap (wrapper miss-label)
+  `(let* ((primary ,(emit-1-wrapper-compute-primary-cache-location wrapper miss-label))
+	  (location primary))
+     (declare (fixnum primary location))
+     (block search
+       (loop (when (eq ,wrapper (cache-vector-ref cache-vector location))
+	       (return-from search nil))
+	     (setq location (the fixnum (+ location 1)))
+	     (when (= location size)
+	       (setq location 0))
+	     (when (= location primary)
+	       (dolist (entry overflow)
+		 (when (eq (car entry) ,wrapper)
+		   (return-from search nil)))
+	       (go ,miss-label))))))
+
+(defmacro get-cache-vector-lock-count (cache-vector)
+  `(let ((lock-count (cache-vector-lock-count ,cache-vector)))
+     (unless (typep lock-count 'fixnum)
+       (error "my cache got freed somehow"))
+     (the fixnum lock-count)))
+
+(defun emit-1-t-dlap (wrapper miss-label value)
+  `(let ((primary ,(emit-1-wrapper-compute-primary-cache-location wrapper miss-label))
+	 (initial-lock-count (get-cache-vector-lock-count cache-vector)))
+     (declare (fixnum primary initial-lock-count))
+     (let ((location primary))
+       (declare (fixnum location))
+       (block search
+	 (loop (when (eq ,wrapper (cache-vector-ref cache-vector location))
+		 (setq ,value (cache-vector-ref cache-vector (1+ location)))
+		 (return-from search nil))
+	       (setq location (the fixnum (+ location 2)))
+	       (when (= location size)
+		 (setq location 0))
+	       (when (= location primary)
+		 (dolist (entry overflow)
+		   (when (eq (car entry) ,wrapper)
+		     (setq ,value (cdr entry))
+		     (return-from search nil)))
+		 (go ,miss-label))))
+       (unless (= initial-lock-count
+		  (get-cache-vector-lock-count cache-vector))
+	 (go ,miss-label)))))
+
+(defun emit-greater-than-1-dlap (wrappers miss-label value)
+  (declare (type list wrappers))
+  (let ((cache-line-size (compute-line-size (+ (length wrappers) (if value 1 0)))))
+    `(let ((primary 0) (size-1 (the fixnum (- size 1))))
+       (declare (fixnum primary size-1))
+       ,(emit-n-wrapper-compute-primary-cache-location wrappers miss-label)
+       (let ((initial-lock-count (get-cache-vector-lock-count cache-vector)))
+	 (declare (fixnum initial-lock-count))
+	 (let ((location primary) (next-location 0))
+	   (declare (fixnum location next-location))
+	   (block search
+	     (loop (setq next-location (the fixnum (+ location ,cache-line-size)))
+		   (when (and ,@(mapcar
+				 #'(lambda (wrapper)
+				     `(eq ,wrapper 
+				       (cache-vector-ref cache-vector
+					(setq location
+					 (the fixnum (+ location 1))))))
+				 wrappers))
+		     ,@(when value
+			 `((setq location (the fixnum (+ location 1)))
+			   (setq ,value (cache-vector-ref cache-vector location))))
+		     (return-from search nil))
+		   (setq location next-location)
+		   (when (= location size-1)
+		     (setq location 0))
+		   (when (= location primary)
+		     (dolist (entry overflow)
+		       (let ((entry-wrappers (car entry)))
+			 (when (and ,@(mapcar #'(lambda (wrapper)
+						  `(eq ,wrapper (pop entry-wrappers)))
+					      wrappers))
+			   ,@(when value
+			       `((setq ,value (cdr entry))))
+			   (return-from search nil))))
+		     (go ,miss-label))))
+	   (unless (= initial-lock-count
+		      (get-cache-vector-lock-count cache-vector))
+	     (go ,miss-label)))))))
+
+(defun emit-1-wrapper-compute-primary-cache-location (wrapper miss-label)
+  `(let ((wrapper-cache-no (wrapper-cache-number-vector-ref ,wrapper field)))
+     (declare (fixnum wrapper-cache-no))
+     (when (zerop wrapper-cache-no) (go ,miss-label))
+     ,(let ((form `(#+lucid %logand #-lucid logand
+		    mask wrapper-cache-no)))
+	#+lucid form
+	#-lucid `(the fixnum ,form))))
+
+(defun emit-n-wrapper-compute-primary-cache-location (wrappers miss-label)
+  (declare (type list wrappers))
+  ;; this returns 1 less that the actual location
+  `(progn
+     ,@(let ((adds 0) (len (length wrappers)))
+	 (declare (fixnum adds len))
+	 (mapcar #'(lambda (wrapper)
+		     `(let ((wrapper-cache-no (wrapper-cache-number-vector-ref 
+					       ,wrapper field)))
+		        (declare (fixnum wrapper-cache-no))
+		        (when (zerop wrapper-cache-no) (go ,miss-label))
+		        (setq primary (the fixnum (+ primary wrapper-cache-no)))
+		        ,@(progn
+			    (incf adds)
+			    (when (or (zerop (mod adds wrapper-cache-number-adds-ok))
+				      (eql adds len))
+			      `((setq primary
+				      ,(let ((form `(#+lucid %logand #-lucid logand
+						     primary mask)))
+					 #+lucid form
+					 #-lucid `(the fixnum ,form))))))))
+		 wrappers))))
+     
+(defun emit-fetch-wrapper (metatype argument miss-label &optional slot)
+  (ecase metatype
+    ((standard-instance #+new-kcl-wrapper structure-instance)
+     `(cond ((std-instance-p ,argument)
+	     ,@(when slot `((setq ,slot (std-instance-slots ,argument))))
+	     (std-instance-wrapper ,argument))
+	    ((fsc-instance-p ,argument)
+	     ,@(when slot `((setq ,slot (fsc-instance-slots ,argument))))
+	     (fsc-instance-wrapper ,argument))
+	    (t
+	     (go ,miss-label))))
+    (class
+     (when slot (error "Can't do a slot reg for this metatype."))
+     `(wrapper-of-macro ,argument))
+    ((built-in-instance #-new-kcl-wrapper structure-instance)
+     (when slot (error "Can't do a slot reg for this metatype."))
+     `(#+new-kcl-wrapper built-in-wrapper-of
+       #-new-kcl-wrapper built-in-or-structure-wrapper
+       ,argument))))
+
diff --git a/pcl/dlisp2.lisp b/pcl/dlisp2.lisp
new file mode 100644
index 000000000..7bff7953e
--- /dev/null
+++ b/pcl/dlisp2.lisp
@@ -0,0 +1,175 @@
+;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*-
+;;;
+;;; *************************************************************************
+;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
+;;; All rights reserved.
+;;;
+;;; Use and copying of this software and preparation of derivative works
+;;; based upon this software are permitted.  Any distribution of this
+;;; software or derivative works must comply with all applicable United
+;;; States export control laws.
+;;; 
+;;; This software is made available AS IS, and Xerox Corporation makes no
+;;; warranty about the software, its performance or its conformity to any
+;;; specification.
+;;; 
+;;; Any person obtaining a copy of this software is requested to send their
+;;; name and post office or electronic mail address to:
+;;;   CommonLoops Coordinator
+;;;   Xerox PARC
+;;;   3333 Coyote Hill Rd.
+;;;   Palo Alto, CA 94304
+;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
+;;;
+;;; Suggestions, comments and requests for improvements are also welcome.
+;;; *************************************************************************
+;;;
+
+(in-package 'pcl)
+
+(defun emit-reader/writer-function (reader/writer 1-or-2-class class-slot-p)
+  (values
+   (ecase reader/writer
+     (:reader (ecase 1-or-2-class
+		(1 (if class-slot-p
+		       (emit-reader/writer-macro :reader 1 t)
+		       (emit-reader/writer-macro :reader 1 nil)))
+		(2 (if class-slot-p
+		       (emit-reader/writer-macro :reader 2 t)
+		       (emit-reader/writer-macro :reader 2 nil)))))
+     (:writer (ecase 1-or-2-class
+		(1 (if class-slot-p
+		       (emit-reader/writer-macro :writer 1 t)
+		       (emit-reader/writer-macro :writer 1 nil)))
+		(2 (if class-slot-p
+		       (emit-reader/writer-macro :writer 2 t)
+		       (emit-reader/writer-macro :writer 2 nil))))))
+   nil))
+
+(defun emit-one-or-n-index-reader/writer-function
+    (reader/writer cached-index-p class-slot-p)
+  (values
+   (ecase reader/writer
+     (:reader (if cached-index-p
+		  (if class-slot-p
+		      (emit-one-or-n-index-reader/writer-macro :reader t t)
+		      (emit-one-or-n-index-reader/writer-macro :reader t nil))
+		  (if class-slot-p
+		      (emit-one-or-n-index-reader/writer-macro :reader nil t)
+		      (emit-one-or-n-index-reader/writer-macro :reader nil nil))))
+     (:writer (if cached-index-p
+		  (if class-slot-p
+		      (emit-one-or-n-index-reader/writer-macro :writer t t)
+		      (emit-one-or-n-index-reader/writer-macro :writer t nil))
+		  (if class-slot-p
+		      (emit-one-or-n-index-reader/writer-macro :writer nil t)
+		      (emit-one-or-n-index-reader/writer-macro :writer nil nil)))))
+   nil))
+
+(eval-when (compile load eval)
+(defparameter checking-or-caching-list
+  '()
+  #||
+  '((T NIL (CLASS) NIL)
+    (T NIL (CLASS CLASS) NIL)
+    (T NIL (CLASS CLASS CLASS) NIL)
+    (T NIL (CLASS CLASS T) NIL)
+    (T NIL (CLASS CLASS T T) NIL)
+    (T NIL (CLASS CLASS T T T) NIL)
+    (T NIL (CLASS T) NIL)
+    (T NIL (CLASS T T) NIL)
+    (T NIL (CLASS T T T) NIL)
+    (T NIL (CLASS T T T T) NIL)
+    (T NIL (CLASS T T T T T) NIL)
+    (T NIL (CLASS T T T T T T) NIL)
+    (T NIL (T CLASS) NIL)
+    (T NIL (T CLASS T) NIL)
+    (T NIL (T T CLASS) NIL)
+    (T NIL (CLASS) T)
+    (T NIL (CLASS CLASS) T)
+    (T NIL (CLASS T) T)
+    (T NIL (CLASS T T) T)
+    (T NIL (CLASS T T T) T)
+    (T NIL (T CLASS) T)
+    (T T (CLASS) NIL)
+    (T T (CLASS CLASS) NIL)
+    (T T (CLASS CLASS CLASS) NIL)
+    (NIL NIL (CLASS) NIL)
+    (NIL NIL (CLASS CLASS) NIL)
+    (NIL NIL (CLASS CLASS T) NIL)
+    (NIL NIL (CLASS CLASS T T) NIL)
+    (NIL NIL (CLASS T) NIL)
+    (NIL NIL (T CLASS T) NIL)
+    (NIL NIL (CLASS) T)
+    (NIL NIL (CLASS CLASS) T)) ||# ))
+
+(defmacro make-checking-or-caching-function-list ()
+  `(list ,@(mapcar #'(lambda (key)
+		       `(cons ',key (emit-checking-or-caching-macro ,@key)))
+		   checking-or-caching-list)))
+
+(defvar checking-or-caching-function-list)
+
+(defun initialize-checking-or-caching-function-list ()
+  (setq checking-or-caching-function-list
+	(make-checking-or-caching-function-list)))
+
+(initialize-checking-or-caching-function-list)
+
+(defmacro emit-checking-or-caching-function-precompiled ()
+  `(cdr (assoc (list cached-emf-p return-value-p metatypes applyp)
+	       checking-or-caching-function-list
+	       :test #'equal)))
+
+(defun emit-checking-or-caching-function (cached-emf-p return-value-p metatypes applyp)
+  (let ((fn (emit-checking-or-caching-function-precompiled)))
+    (if fn
+	(values fn nil)
+	(values (emit-checking-or-caching-function-preliminary
+		 cached-emf-p return-value-p metatypes applyp)
+		t))))
+
+(defvar not-in-cache (make-symbol "not in cache"))
+
+(defun emit-checking-or-caching-function-preliminary
+    (cached-emf-p return-value-p metatypes applyp)
+  (declare (ignore applyp))
+  (if cached-emf-p
+      #'(lambda (cache miss-fn)
+	  #'(lambda (&rest args)
+	      (declare #.*optimize-speed*)
+	      (with-dfun-wrappers (args metatypes)
+		(dfun-wrappers invalid-wrapper-p)
+		(apply miss-fn args)
+		(if invalid-wrapper-p
+		    (apply miss-fn args)
+		    (let ((emf (probe-cache cache dfun-wrappers not-in-cache)))
+		      (if (eq emf not-in-cache)
+			  (apply miss-fn args)
+			  (if return-value-p
+			      emf
+			      (invoke-emf emf args))))))))
+      #'(lambda (cache emf miss-fn)
+	  #'(lambda (&rest args)
+	      (declare #.*optimize-speed*)
+	      (with-dfun-wrappers (args metatypes)
+		(dfun-wrappers invalid-wrapper-p)
+		(apply miss-fn args)
+		(if invalid-wrapper-p
+		    (apply miss-fn args)
+		    (let ((found-p (not (eq not-in-cache
+					    (probe-cache cache dfun-wrappers
+							 not-in-cache)))))
+		      (if found-p
+			  (invoke-emf emf args)
+			  (if return-value-p
+			      t
+			      (apply miss-fn args))))))))))
+
+
+(defun emit-default-only-function (metatypes applyp)
+  (declare (ignore metatypes applyp))
+  (values #'(lambda (emf)
+	      #'(lambda (&rest args)
+		  (invoke-emf emf args)))
+	  t))
diff --git a/pcl/fast-init.lisp b/pcl/fast-init.lisp
new file mode 100644
index 000000000..a083f5c25
--- /dev/null
+++ b/pcl/fast-init.lisp
@@ -0,0 +1,895 @@
+;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*-
+;;;
+;;; *************************************************************************
+;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
+;;; All rights reserved.
+;;;
+;;; Use and copying of this software and preparation of derivative works
+;;; based upon this software are permitted.  Any distribution of this
+;;; software or derivative works must comply with all applicable United
+;;; States export control laws.
+;;; 
+;;; This software is made available AS IS, and Xerox Corporation makes no
+;;; warranty about the software, its performance or its conformity to any
+;;; specification.
+;;; 
+;;; Any person obtaining a copy of this software is requested to send their
+;;; name and post office or electronic mail address to:
+;;;   CommonLoops Coordinator
+;;;   Xerox PARC
+;;;   3333 Coyote Hill Rd.
+;;;   Palo Alto, CA 94304
+;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
+;;;
+;;; Suggestions, comments and requests for improvements are also welcome.
+;;; *************************************************************************
+;;;
+;;;
+;;; This file defines the optimized make-instance functions.
+;;; 
+
+(in-package 'pcl)
+
+;make-instance-functions take up more space when compiled.
+(defvar *inhibit-compile-make-instance-functions-p* nil)
+
+(defvar *compile-make-instance-functions-p* nil) ; this gets bound to t below
+
+(defvar *make-instance-function-table* (make-hash-table :test 'equal))
+
+(defvar gmif-class nil)
+
+(defun update-make-instance-function-table (&optional (gmif-class *the-class-t*))
+  (when (symbolp gmif-class) (setq gmif-class (find-class gmif-class)))
+  (let ((class gmif-class))
+    (when (eq class *the-class-t*) (setq class *the-class-slot-object*))
+    (when (memq *the-class-slot-object* (class-precedence-list class))
+      (map-all-classes #'reset-class-initialize-info class)))
+  (maphash #'get-make-instance-function *make-instance-function-table*))
+
+(defun get-make-instance-function-key (class initargs)
+  (let ((keys nil)(allow-other-keys-p nil) key value)
+    (when initargs
+      (let ((initargs-tail initargs))
+	(setq key (pop initargs-tail) value (pop initargs-tail))
+	(when (eq key ':allow-other-keys)
+	  (setq allow-other-keys-p value))
+	(setq keys (cons key nil))
+	(when initargs-tail
+	  (let ((keys-tail keys))
+	    (loop (setq key (pop initargs-tail) value (pop initargs-tail))
+		  (when (eq key ':allow-other-keys)
+		    (setq allow-other-keys-p value))
+		  (if keys-tail
+		      (setf (cdr keys-tail) (cons key nil)
+			    keys-tail (cdr keys-tail))
+		      (setf keys-tail (setf keys (cons key nil))))
+		  (when (null initargs-tail) (return nil)))))))
+    (list class keys allow-other-keys-p)))
+
+(defmacro %get-make-instance-function (class initargs)
+  `(let ((key (get-make-instance-function-key ,class ,initargs)))
+     (or (car (gethash key *make-instance-function-table*))
+	 (get-make-instance-function key))))
+
+(defun constant-symbol-p (form)
+  (and (constantp form) (symbolp (eval form))))
+
+(defvar *make-instance-function-keys* nil)
+(defvar *skip-boundp-check* nil)
+
+(defun expand-make-instance-form (form &optional
+				       (skip-boundp-check *skip-boundp-check*))
+  (let ((class (cadr form)) (initargs (cddr form))
+	(keys nil)(allow-other-keys-p nil) key value)
+    (when (and (constant-symbol-p class)
+	       (let ((initargs-tail initargs))
+		 (loop (when (null initargs-tail) (return t))
+		       (unless (constant-symbol-p (car initargs-tail))
+			 (return nil))		       
+		       (setq key (eval (pop initargs-tail)))
+		       (setq value (pop initargs-tail))
+		       (when (eq ':allow-other-keys key)
+			 (setq allow-other-keys-p value))
+		       (push key keys))))
+      (let* ((class (eval class))
+	     (keys (nreverse keys))
+	     (key (list class keys allow-other-keys-p))
+	     (sym (make-instance-function-symbol key)))
+	(push key *make-instance-function-keys*)
+	(if (and sym skip-boundp-check)
+	    `(,sym ',class (list ,@initargs))
+	    `(funcall ,(if sym
+			   `(if (#-akcl fboundp #+akcl %fboundp ',sym)
+			        (#-akcl symbol-function #+akcl %symbol-function ',sym)
+			        (get-make-instance-function ',key))
+			   `(get-make-instance-function ',key))
+	             ',class (list ,@initargs)))))))
+
+(defmacro expanding-make-instance-top-level (&rest forms &environment env)
+  (let* ((*make-instance-function-keys* nil)
+	 (*skip-boundp-check* t)
+	 (form (macroexpand `(expanding-make-instance ,@forms) env)))
+    `(progn
+       ,@(when *make-instance-function-keys*
+	   `((get-make-instance-functions ',*make-instance-function-keys*)))
+       ,form)))
+	  
+(defmacro expanding-make-instance (&rest forms &environment env)
+  `(progn
+     ,@(mapcar #'(lambda (form)
+		   (walk-form form env 
+			      #'(lambda (subform context env)
+				  (declare (ignore env))
+				  (or (and (eq context ':eval)
+					   (consp subform)
+					   (eq (car subform) 'make-instance)
+					   (expand-make-instance-form subform))
+				      subform))))
+	       forms)))
+
+(defmacro defconstructor
+	  (name class lambda-list &rest initialization-arguments)
+  `(expanding-make-instance-top-level
+    (defun ,name ,lambda-list
+      (make-instance ',class ,@initialization-arguments))))
+
+(defun get-make-instance-functions (key-list &optional compile-p)
+  (let ((*compile-make-instance-functions-p* compile-p))
+    (dolist (key key-list)
+      (if compile-p
+	  (get-make-instance-function key)
+	  (set-make-instance-function (make-instance-function-symbol key)
+				      key
+				      (make-lazy-get-make-instance-function key)
+				      nil)))))
+
+(defun make-instance-function-symbol (key)
+  (let ((class (car key)))
+    (when (or (symbolp class) (classp class))
+      (let* ((class-name (if (symbolp class) class (class-name class)))
+	     (keys (cadr key))
+	     (allow-other-keys-p (caddr key)))
+	(let ((*package* *the-pcl-package*)
+	      (*print-length* nil) (*print-level* nil)
+	      (*print-circle* nil) (*print-case* :upcase)
+	      (*print-pretty* nil))
+	  (intern (format nil "MAKE-INSTANCE ~S ~S ~S"
+			  class-name keys allow-other-keys-p)))))))
+
+(defun make-lazy-get-make-instance-function (key)
+  #'(lambda (class initargs)
+      (if (eq *boot-state* 'complete)
+	  (funcall (get-make-instance-function key) class initargs)
+	  (apply #'make-instance class initargs))))
+
+(defun get-make-instance-function (key &optional (value (list nil nil)))
+  (let* ((class (car key))
+	 (keys (cadr key))
+	 (gmif-class-1 gmif-class) (gmif-class nil)
+	 name)
+    (flet ((return-function (function)
+	     (return-from get-make-instance-function
+	       (set-make-instance-function name key function nil))))
+      (unless (eq *boot-state* 'complete)
+	(return-function (make-lazy-get-make-instance-function key)))
+      (when (symbolp class)
+	(let ((real-class (find-class class nil)))
+	  (unless real-class
+	    (if gmif-class-1
+		(return-function (make-lazy-get-make-instance-function key))
+		(error "class ~S not found" class)))
+	  (setq class real-class)))
+      (when (classp class)
+	(unless (class-finalized-p class) (finalize-inheritance class))
+	(when (and gmif-class-1
+		   (not (member gmif-class-1 (class-precedence-list class))))
+	  (return-from get-make-instance-function nil))
+	(setq name (make-instance-function-symbol key))
+      (when (and gmif-class-1 (not *compile-make-instance-functions-p*))
+	(return-function 
+	 #'(lambda (class initargs)
+	     (funcall (get-make-instance-function key) class initargs)))))
+    (let* ((initargs (mapcan #'(lambda (key) (list key nil)) keys))
+	   (class-and-initargs (list* class initargs))
+	   (make-instance (gdefinition 'make-instance))
+	   (make-instance-methods
+	    (compute-applicable-methods make-instance class-and-initargs))
+	   (std-mi-meth (find-standard-ii-method make-instance-methods 'class))
+	   (class+initargs (list class initargs))
+	   (default-initargs (gdefinition 'default-initargs))
+	   (default-initargs-methods
+	    (compute-applicable-methods default-initargs class+initargs))
+	   (proto (and (classp class) (class-prototype class)))
+	   (initialize-instance-methods
+	    (when proto
+	      (compute-applicable-methods (gdefinition 'initialize-instance)
+					  (list* proto initargs))))
+	   (shared-initialize-methods
+	    (when proto
+	      (compute-applicable-methods (gdefinition 'shared-initialize)
+					  (list* proto t initargs)))))
+      (when (null make-instance-methods)
+	(return-function 
+	 #'(lambda (class initargs)
+	     (apply #'no-applicable-method make-instance class initargs))))
+      (unless (and (null (cdr make-instance-methods))
+		   (eq (car make-instance-methods) std-mi-meth)
+		   (null (cdr default-initargs-methods))
+		   (eq (car (method-specializers (car default-initargs-methods)))
+		       *the-class-slot-class*)
+		   (flet ((check-meth (meth)
+			    (let ((quals (method-qualifiers meth)))
+			      (if (null quals)
+				  (eq (car (method-specializers meth))
+				      *the-class-slot-object*)
+				  (and (null (cdr quals))
+				       (or (eq (car quals) ':before)
+					   (eq (car quals) ':after)))))))
+		     (and (every #'check-meth initialize-instance-methods)
+			  (every #'check-meth shared-initialize-methods))))
+	(return-function
+	 #'(lambda (class initargs)
+	     (apply #'make-instance class initargs))))
+      (get-make-instance-function-internal 
+       class key (default-initargs class initargs) 
+       initialize-instance-methods shared-initialize-methods
+       name 
+       (or (cadr value)
+	   (and *compile-make-instance-functions-p*
+		(not *inhibit-compile-make-instance-functions-p*))))))))
+
+(defun get-make-instance-function-internal (class key initargs 
+						  initialize-instance-methods
+						  shared-initialize-methods
+						  &optional (name nil name-p)
+						  compile-p)
+  (let* ((*compile-make-instance-functions-p* compile-p)
+	 (keys (cadr key))
+	 (allow-other-keys-p (caddr key))
+	 (allocate-instance-methods
+	  (compute-applicable-methods (gdefinition 'allocate-instance)
+				      (list* class initargs))))
+    (unless allow-other-keys-p
+      (unless (check-initargs-1
+	       class initargs
+	       (append allocate-instance-methods
+		       initialize-instance-methods
+		       shared-initialize-methods)
+	       t nil)
+	(return-from get-make-instance-function-internal
+	  (make-lazy-get-make-instance-function key))))
+    (let ((function (if (or (cdr allocate-instance-methods)
+			    (some #'complicated-instance-creation-method
+				  initialize-instance-methods)
+			    (some #'complicated-instance-creation-method
+				  shared-initialize-methods))
+			(make-instance-function-complex
+			 key class keys
+			 initialize-instance-methods shared-initialize-methods)
+			(make-instance-function-simple
+			 key class keys
+			 initialize-instance-methods shared-initialize-methods))))
+      (when name-p (set-make-instance-function name key function compile-p))
+      function)))
+
+(defun set-make-instance-function (name key function compile-p)
+  #-cmu (set-function-name function name)
+  (when name (setf (symbol-function name) function))
+  (setf (gethash key *make-instance-function-table*) 
+	(list function compile-p))
+  function)
+
+(defun complicated-instance-creation-method (m)
+  (let ((qual (method-qualifiers m)))
+    (if qual 
+	(not (and (null (cdr qual)) (eq (car qual) ':after)))
+	(let ((specl (car (method-specializers m))))
+	  (or (not (classp specl))
+	      (not (eq 'slot-object (class-name specl))))))))
+
+(defun find-standard-ii-method (methods class-names)
+  (dolist (m methods)
+    (when (null (method-qualifiers m))
+      (let ((specl (car (method-specializers m))))
+	(when (and (classp specl)
+		   (if (listp class-names)
+		       (member (class-name specl) class-names)
+		       (eq (class-name specl) class-names)))
+	  (return m))))))
+
+(defmacro call-initialize-function (initialize-function instance initargs)
+  `(let ((.function. ,initialize-function))
+     (if (and (consp .function.)
+	      (eq (car .function.) 'call-initialize-instance-simple))
+	 (initialize-instance-simple (cadr .function.) (caddr .function.)
+				     ,instance ,initargs)
+	 (funcall .function. ,instance ,initargs))))
+
+(defun make-instance-function-simple (key class keys 
+					  initialize-instance-methods 
+					  shared-initialize-methods)
+  (multiple-value-bind (initialize-function constants)
+      (get-simple-initialization-function class keys (caddr key))
+    (let* ((wrapper (class-wrapper class))
+	   (lwrapper (list wrapper))
+	   (allocate-function 
+	    (cond ((structure-class-p class)
+		   #'allocate-structure-instance)
+		  ((standard-class-p class)
+		   #'allocate-standard-instance)
+		  ((funcallable-standard-class-p class)
+		   #'allocate-funcallable-instance)
+		  (t 
+		   (error "error in make-instance-function-simple"))))
+	   (std-si-meth (find-standard-ii-method shared-initialize-methods
+						 'slot-object))
+	   (shared-initfns
+	    (nreverse (mapcar #'(lambda (method)
+				  (make-effective-method-function
+				   #'shared-initialize
+				   `(call-method ,method nil)
+				   nil lwrapper))
+			      (remove std-si-meth shared-initialize-methods))))
+	   (std-ii-meth (find-standard-ii-method initialize-instance-methods
+						 'slot-object))
+	   (initialize-initfns 
+	    (nreverse (mapcar #'(lambda (method)
+				  (make-effective-method-function
+				   #'initialize-instance
+				   `(call-method ,method nil)
+				   nil lwrapper))
+			      (remove std-ii-meth
+				      initialize-instance-methods)))))
+      #'(lambda (class1 initargs)
+	  (declare (ignore class1))
+	  (if (not (eq wrapper (class-wrapper class)))
+	      (funcall (get-make-instance-function key) class initargs)
+	      (let* ((instance (funcall allocate-function wrapper constants))
+		     (initargs (call-initialize-function initialize-function
+							 instance initargs)))
+		(dolist (fn shared-initfns)
+		  (invoke-effective-method-function fn t instance t initargs))
+		(dolist (fn initialize-initfns)
+		  (invoke-effective-method-function fn t instance initargs))
+		instance))))))
+
+(defun make-instance-function-complex (key class keys
+					   initialize-instance-methods
+					   shared-initialize-methods)
+  (multiple-value-bind (initargs-function initialize-function)
+      (get-complex-initialization-functions class keys (caddr key))
+    (let* ((wrapper (class-wrapper class))
+	   (shared-initialize
+	    (get-secondary-dispatch-function
+	     #'shared-initialize shared-initialize-methods
+	     `((class-eq ,class) t t)
+	     `((,(find-standard-ii-method shared-initialize-methods 'slot-object)
+		,#'(lambda (instance init-type &rest initargs)
+		     (declare (ignore init-type))
+		     (call-initialize-function initialize-function 
+					       instance initargs)
+		     instance)))
+	     (list wrapper *the-wrapper-of-t* *the-wrapper-of-t*)))
+	   (initialize-instance
+	    (get-secondary-dispatch-function
+	     #'initialize-instance initialize-instance-methods
+	     `((class-eq ,class) t)
+	     `((,(find-standard-ii-method initialize-instance-methods 'slot-object)
+		,#'(lambda (instance &rest initargs)
+		     (invoke-effective-method-function
+		      shared-initialize t instance t initargs))))
+	     (list wrapper *the-wrapper-of-t*))))
+      #'(lambda (class1 initargs)
+	  (declare (ignore class1))
+	  (if (not (eq wrapper (class-wrapper class)))
+	      (funcall (get-make-instance-function key) class initargs)
+	      (let* ((initargs (call-initialize-function initargs-function 
+							 nil initargs))
+		     (instance (apply #'allocate-instance class initargs)))
+		(invoke-effective-method-function
+		 initialize-instance t instance initargs)
+		instance))))))
+
+(defmacro define-cached-reader (type name trap)
+  (let ((reader-name (intern (format nil "~A-~A" type name)))
+	(cached-name (intern (format nil "~A-CACHED-~A" type name))))
+    `(defmacro ,reader-name (info)
+       `(let ((value (,',cached-name ,info)))
+	  (if (eq value ':unknown)
+	      (progn
+		(,',trap ,info ',',name)
+		(,',cached-name ,info))
+	      value)))))
+
+(eval-when (compile load eval)
+(defparameter initialize-info-cached-slots
+  '(valid-p				; t or (:invalid key)
+    ri-valid-p
+    initargs-form-list
+    new-keys
+    default-initargs-function
+    shared-initialize-t-function
+    shared-initialize-nil-function
+    constants
+    combined-initialize-function)))
+
+(defmacro define-initialize-info ()
+  (flet ((cached-slot-name (name)
+	   (intern (format nil "CACHED-~A" name)))
+	 (cached-name (name)
+	   (intern (format nil "~A-CACHED-~A" 'initialize-info name))))
+    `(progn
+       (defstruct initialize-info 
+	 key wrapper 
+	 ,@(mapcar #'cached-slot-name initialize-info-cached-slots))
+       (defun reset-initialize-info (info)
+	 ,@(mapcar #'(lambda (name)
+		       `(setf (,(cached-name name) info) ':unknown))
+		   initialize-info-cached-slots)
+	 info)
+      ,@(mapcar #'(lambda (name)
+		    `(define-cached-reader initialize-info ,name 
+		      update-initialize-info-internal))
+	        initialize-info-cached-slots))))
+
+(define-initialize-info)
+
+(defvar *initialize-info-cache-class* nil)
+(defvar *initialize-info-cache-initargs* nil)
+(defvar *initialize-info-cache-info* nil)
+
+(defun reset-class-initialize-info (class)
+  (reset-class-initialize-info-1 (class-initialize-info class)))
+
+(defun reset-class-initialize-info-1 (cell)
+  (when (consp cell)
+    (when (car cell)
+      (setf (initialize-info-wrapper (car cell)) nil))
+    (let ((alist (cdr cell)))
+      (dolist (a alist)
+	(reset-class-initialize-info-1 (cdr a))))))
+
+(defun initialize-info (class initargs &optional (plist-p t) allow-other-keys-arg)
+  (let ((info nil))
+    (if (and (eq *initialize-info-cache-class* class)
+	     (eq *initialize-info-cache-initargs* initargs))
+	(setq info *initialize-info-cache-info*)
+	(let ((initargs-tail initargs)
+	      (cell (or (class-initialize-info class)
+			(setf (class-initialize-info class) (cons nil nil)))))
+	  (loop (when (null initargs-tail) (return nil))
+		(let ((keyword (pop initargs-tail))
+		      (alist-cell cell))
+		  (when plist-p
+		    (if (eq keyword :allow-other-keys)
+			(setq allow-other-keys-arg (pop initargs-tail))
+			(pop initargs-tail)))
+		  (loop (let ((alist (cdr alist-cell)))
+			  (when (null alist)
+			    (setq cell (cons nil nil))
+			    (setf (cdr alist-cell) (list (cons keyword cell)))
+			    (return nil))
+			  (when (eql keyword (caar alist))
+			    (setq cell (cdar alist))
+			    (return nil))
+			  (setq alist-cell alist)))))
+	  (setq info (or (car cell)
+			 (setf (car cell) (make-initialize-info))))))
+    (let ((wrapper (initialize-info-wrapper info)))
+      (unless (eq wrapper (class-wrapper class))
+	(unless wrapper
+	  (let* ((initargs-tail initargs)
+		 (klist-cell (list nil))
+		 (klist-tail klist-cell))
+	    (loop (when (null initargs-tail) (return nil))
+		  (let ((key (pop initargs-tail)))
+		    (setf (cdr klist-tail) (list key)))
+		  (setf klist-tail (cdr klist-tail))
+		  (when plist-p (pop initargs-tail)))
+	    (setf (initialize-info-key info)
+		  (list class (cdr klist-cell) allow-other-keys-arg))))
+	(update-initialize-info info)))
+    (setq *initialize-info-cache-class* class)
+    (setq *initialize-info-cache-initargs* initargs)
+    (setq *initialize-info-cache-info* info)    
+    info))
+
+(defun update-initialize-info (info)
+  (let* ((key (initialize-info-key info))
+	 (class (car key)))
+    (setf (initialize-info-wrapper info) (class-wrapper class))
+    (reset-initialize-info info)
+    info))
+
+(defun update-initialize-info-internal (info name)
+  (let* ((key (initialize-info-key info))
+	 (class (car key))
+	 (keys (cadr key))
+	 (allow-other-keys-arg (caddr key)))
+    (ecase name
+      ((initargs-form-list new-keys)
+       (multiple-value-bind (initargs-form-list new-keys)
+	   (make-default-initargs-form-list class keys)
+	 (setf (initialize-info-cached-initargs-form-list info) initargs-form-list)
+	 (setf (initialize-info-cached-new-keys info) new-keys)))
+      ((default-initargs-function)
+       (let ((initargs-form-list (initialize-info-initargs-form-list info)))
+	 (setf (initialize-info-cached-default-initargs-function info)
+	       (initialize-instance-simple-function class initargs-form-list))))
+      ((valid-p ri-valid-p)
+       (flet ((compute-valid-p (methods)
+		(or (not (null allow-other-keys-arg))
+		    (multiple-value-bind (legal allow-other-keys)
+			(check-initargs-values class methods)
+		      (or (not (null allow-other-keys))
+			  (dolist (key keys t)
+			    (unless (member key legal)
+			      (return (cons :invalid key)))))))))
+	 (let ((proto (class-prototype class)))
+	   (setf (initialize-info-cached-valid-p info)
+		 (compute-valid-p (list (list* 'allocate-instance class nil)
+					(list* 'initialize-instance proto nil)
+					(list* 'shared-initialize proto t nil))))
+	   (setf (initialize-info-cached-ri-valid-p info)
+		 (compute-valid-p (list (list* 'reinitialize-instance proto nil)
+					(list* 'shared-initialize proto nil nil)))))))
+      ((shared-initialize-t-function)
+       (multiple-value-bind (initialize-form-list ignore)
+	   (make-shared-initialize-form-list class keys t nil)
+	 (declare (ignore ignore))
+	 (setf (initialize-info-cached-shared-initialize-t-function info)
+	       (initialize-instance-simple-function class initialize-form-list))))
+      ((shared-initialize-nil-function)
+       (multiple-value-bind (initialize-form-list ignore)
+	   (make-shared-initialize-form-list class keys nil nil)
+	 (declare (ignore ignore))
+	 (setf (initialize-info-cached-shared-initialize-nil-function info)
+	       (initialize-instance-simple-function class initialize-form-list))))
+      ((constants combined-initialize-function)
+       (let ((initargs-form-list (initialize-info-initargs-form-list info))
+	     (new-keys (initialize-info-new-keys info)))
+	 (multiple-value-bind (initialize-form-list constants)
+	     (make-shared-initialize-form-list class new-keys t t)
+	   (setf (initialize-info-cached-constants info) constants)
+	   (setf (initialize-info-cached-combined-initialize-function info)
+		 (initialize-instance-simple-function 
+		  class (append initargs-form-list initialize-form-list))))))))
+  info)
+
+(defun get-simple-initialization-function (class keys &optional allow-other-keys-arg)
+  (let ((info (initialize-info class keys nil allow-other-keys-arg)))
+    (values (initialize-info-combined-initialize-function info)
+	    (initialize-info-constants info))))
+
+(defun get-complex-initialization-functions (class keys &optional allow-other-keys-arg
+						   separate-p)
+  (let* ((info (initialize-info class keys nil allow-other-keys-arg))
+	 (default-initargs-function (initialize-info-default-initargs-function info)))
+    (if separate-p
+	(values default-initargs-function
+		(initialize-info-shared-initialize-t-function info))
+	(values default-initargs-function
+		(initialize-info-shared-initialize-t-function
+		 (initialize-info class (initialize-info-new-keys info)
+				  nil allow-other-keys-arg))))))
+
+(defun add-forms (forms forms-list)
+  (when forms
+    (setq forms (copy-list forms))
+    (if (null (car forms-list))
+	(setf (car forms-list) forms)
+	(setf (cddr forms-list) forms))
+    (setf (cdr forms-list) (last forms)))
+  (car forms-list))
+
+(defun make-default-initargs-form-list (class keys &optional (separate-p t))
+  (let ((initargs-form-list (cons nil nil))
+	(default-initargs (class-default-initargs class))
+	(nkeys keys))
+    (dolist (default default-initargs)
+      (let ((key (car default))
+	    (function (cadr default)))
+	(unless (member key nkeys)
+	  (add-forms `((funcall ,function) (push-initarg ,key))
+		     initargs-form-list)
+	  (push key nkeys))))
+    (when separate-p
+      (add-forms `((update-initialize-info-cache
+		    ,class ,(initialize-info class nkeys nil)))
+		 initargs-form-list))
+    (add-forms `((finish-pushing-initargs))
+	       initargs-form-list)
+    (values (car initargs-form-list) nkeys)))
+
+(defun make-shared-initialize-form-list (class keys si-slot-names simple-p)
+  (let* ((initialize-form-list (cons nil nil))
+	 (type (cond ((structure-class-p class)
+		      'structure)
+		     ((standard-class-p class)
+		      'standard)
+		     ((funcallable-standard-class-p class)
+		      'funcallable)
+		     (t (error "error in make-shared-initialize-form-list"))))
+	 (wrapper (class-wrapper class))
+	 (constants (when simple-p
+		      (make-list (wrapper-no-of-instance-slots wrapper)
+				 ':initial-element *slot-unbound*)))
+	 (slots (class-slots class))
+	 (slot-names (mapcar #'slot-definition-name slots))
+	 (slots-key (mapcar #'(lambda (slot)
+				(let ((index most-positive-fixnum))
+				  (dolist (key (slot-definition-initargs slot))
+				    (let ((pos (position key keys)))
+				      (when pos (setq index (min index pos)))))
+				  (cons slot index)))
+			    slots))
+	 (slots (stable-sort slots-key #'< :key #'cdr)))
+    (let ((n-popped 0))
+      (dolist (slot+index slots)
+	(let* ((slot (car slot+index))
+	       (name (slot-definition-name slot))
+	       (npop (1+ (- (cdr slot+index) n-popped))))
+	  (unless (eql (cdr slot+index) most-positive-fixnum)
+	    (let* ((pv-offset (1+ (position name slot-names))))
+	      (add-forms `(,@(when (plusp npop)
+			       `((pop-initargs ,(* 2 npop))))
+			   (instance-set ,pv-offset ,slot))
+			 initialize-form-list))
+	    (incf n-popped npop)))))
+    (dolist (slot+index slots)
+      (let* ((slot (car slot+index))
+	     (name (slot-definition-name slot)))
+	(when (and (eql (cdr slot+index) most-positive-fixnum)
+		   (or (eq si-slot-names 't)
+		       (member name si-slot-names)))
+	  (let* ((initform (slot-definition-initform slot))
+		 (initfunction (slot-definition-initfunction slot))
+		 (location (unless (eq type 'structure)
+			     (slot-definition-location slot)))
+		 (pv-offset (1+ (position name slot-names)))
+		 (forms (cond ((null initfunction)
+			       nil)
+			      ((constantp initform)
+			       (let ((value (funcall initfunction)))
+				 (if (and simple-p (integerp location))
+				     (progn (setf (nth location constants) value)
+					    nil)
+				     `((const ,value)
+				       (instance-set ,pv-offset ,slot)))))
+			      (t
+			       `((funcall ,(slot-definition-initfunction slot))
+				 (instance-set ,pv-offset ,slot))))))
+	    (add-forms `(,@(unless (or simple-p (null forms))
+			     `((skip-when-instance-boundp ,pv-offset ,slot
+				,(length forms))))
+			 ,@forms)
+		       initialize-form-list)))))
+    (values (car initialize-form-list) constants)))
+
+(defvar *class-pv-table-table* (make-hash-table :test 'eq))
+
+(defun get-pv-cell-for-class (class)
+  (let* ((slot-names (mapcar #'slot-definition-name (class-slots class)))
+	 (slot-name-lists (list (cons nil slot-names)))
+	 (pv-table (gethash class *class-pv-table-table*)))
+    (unless (and pv-table
+		 (equal slot-name-lists (pv-table-slot-name-lists pv-table)))
+      (setq pv-table (intern-pv-table :slot-name-lists slot-name-lists))
+      (setf (gethash class *class-pv-table-table*) pv-table))
+    (pv-table-lookup pv-table (class-wrapper class))))    
+
+(defvar *initialize-instance-simple-alist* nil)
+(defvar *note-iis-entry-p* nil)
+
+(defun initialize-instance-simple-function (class form-list)
+  (let ((pv-cell (get-pv-cell-for-class class)))
+    (if (and *compile-make-instance-functions-p*
+	     (not *inhibit-compile-make-instance-functions-p*))
+	(multiple-value-bind (form args)
+	    (form-list-to-lisp pv-cell form-list)
+	  (let ((entry (assoc form *initialize-instance-simple-alist*
+			      :test #'equal)))
+	    (unless entry
+	      (setq entry (list form
+				(unless *note-iis-entry-p* (compile-lambda form))
+				nil))
+	      (setq *initialize-instance-simple-alist*
+		    (nconc *initialize-instance-simple-alist*
+			   (list entry))))
+	    (if (cadr entry)
+		(apply (cadr entry) args)
+		`(call-initialize-instance-simple ,pv-cell ,form-list))))
+	#||
+	#'(lambda (instance initargs)
+	    (initialize-instance-simple pv-cell form-list instance initargs))
+	||#
+	`(call-initialize-instance-simple ,pv-cell ,form-list))))
+
+(defun load-precompiled-iis-entry (form function system)
+  (let ((entry (assoc form *initialize-instance-simple-alist*
+		      :test #'equal)))
+    (unless entry
+      (setq entry (list form nil nil))
+      (setq *initialize-instance-simple-alist*
+	    (nconc *initialize-instance-simple-alist*
+		   (list entry))))
+    (setf (cadr entry) function)
+    (setf (caddr entry) system)))
+
+(defmacro precompile-iis-functions (&optional system)
+  (let ((index -1))
+    `(progn
+      ,@(gathering1 (collecting)
+	 (dolist (iis-entry *initialize-instance-simple-alist*)
+	   (when (or (null (caddr iis-entry))
+		     (eq (caddr iis-entry) system))
+	     (when system (setf (caddr iis-entry) system))
+	     (gather1
+	      (make-top-level-form
+	       `(precompile-initialize-instance-simple ,system ,(incf index))
+	       '(load)
+	       `(load-precompiled-iis-entry
+		 ',(car iis-entry)
+		 #',(car iis-entry)
+		 ',system)))))))))
+
+(defun compile-iis-functions (after-p)
+  (let ((*compile-make-instance-functions-p* t)
+	(*note-iis-entry-p* (not after-p)))
+    (declare (special *compile-make-instance-functions-p*))
+    (when (eq *boot-state* 'complete)
+      (update-make-instance-function-table))))
+
+
+;(const const)
+;(funcall function)
+;(push-initarg const)
+;(pop-supplied count) ; a positive odd number 
+;(instance-set pv-offset slotd)
+;(skip-when-instance-boundp pv-offset slotd n)
+
+(defun initialize-instance-simple (pv-cell form-list instance initargs)
+  (let ((pv (car pv-cell))
+	(initargs-tail initargs)
+	(slots (get-slots-or-nil instance))
+	(class (class-of instance))
+	value)
+    (loop (when (null form-list) (return nil))
+	  (let ((form (pop form-list)))
+	    (ecase (car form)
+	      (push-initarg 
+	       (push value initargs)
+	       (push (cadr form) initargs))
+	      (const
+	       (setq value (cadr form)))
+	      (funcall
+	       (setq value (funcall (cadr form))))
+	      (pop-initargs
+	       (setq initargs-tail (nthcdr (1- (cadr form)) initargs-tail))
+	       (setq value (pop initargs-tail)))
+	      (instance-set
+	       (instance-write-internal 
+		pv slots (cadr form) value
+		(setf (slot-value-using-class class instance (caddr form)) value)))
+	      (skip-when-instance-boundp
+	       (when (instance-boundp-internal 
+		      pv slots (cadr form)
+		      (slot-boundp-using-class class instance (caddr form)))
+		 (dotimes (i (cadddr form))
+		   (pop form-list))))
+	      (update-initialize-info-cache
+	       (when (consp initargs)
+		 (setq initargs (cons (car initargs) (cdr initargs))))
+	       (setq *initialize-info-cache-class* (cadr form))
+	       (setq *initialize-info-cache-initargs* initargs)
+	       (setq *initialize-info-cache-info* (caddr form)))
+	      (finish-pushing-initargs
+	       (setq initargs-tail initargs)))))
+    initargs))
+
+(defun add-to-cvector (cvector constant)
+  (or (position constant cvector)
+      (prog1 (fill-pointer cvector)
+	(vector-push-extend constant cvector))))
+
+(defvar *inline-iis-instance-locations-p* t)
+
+(defun first-form-to-lisp (forms cvector pv)
+  (flet ((const (constant)
+	   (cond ((or (numberp constant) (characterp constant))
+		  constant)
+		 ((and (symbolp constant) (symbol-package constant))
+		  `',constant)
+		 (t
+		  `(svref cvector ,(add-to-cvector cvector constant))))))
+    (let ((form (pop (car forms))))
+      (ecase (car form)
+	(push-initarg
+	 `((push value initargs)
+	   (push ,(const (cadr form)) initargs)))
+	(const
+	 `((setq value ,(const (cadr form)))))
+	(funcall
+	 `((setq value (funcall (the function ,(const (cadr form)))))))
+	(pop-initargs
+	 `((setq initargs-tail (,@(let ((pop (1- (cadr form))))
+				    (case pop
+				      (1 `(cdr))
+				      (3 `(cdddr))
+				      (t `(nthcdr ,pop))))
+				initargs-tail))
+	   (setq value (pop initargs-tail))))
+	(instance-set
+	 (let* ((pv-offset (cadr form))
+		(location (pvref pv pv-offset))
+		(default `(setf (slot-value-using-class class instance
+							,(const (caddr form)))
+				value)))
+	   (if *inline-iis-instance-locations-p*
+	       (typecase location
+		 (fixnum `((setf (%instance-ref slots ,(const location)) value)))
+		 (cons `((setf (cdr ,(const location)) value)))
+		 (t `(,default)))
+	       `((instance-write-internal pv slots ,(const pv-offset) value
+		  ,default
+		  ,(typecase location
+		     (fixnum ':instance)
+		     (cons ':class)
+		     (t ':default)))))))
+	(skip-when-instance-boundp
+	 (let* ((pv-offset (cadr form))
+		(location (pvref pv pv-offset))
+		(default `(slot-boundp-using-class class instance
+			   ,(const (caddr form)))))
+	   `((unless ,(if *inline-iis-instance-locations-p*
+			  (typecase location
+			    (fixnum `(not (eq (%instance-ref slots ,(const location))
+					      ',*slot-unbound*)))
+			    (cons `(not (eq (cdr ,(const location)) ',*slot-unbound*)))
+			    (t default))
+			  `(instance-boundp-internal pv slots ,(const pv-offset)
+			    ,default
+			    ,(typecase (pvref pv pv-offset)
+			       (fixnum ':instance)
+			       (cons ':class)
+			       (t ':default))))
+	       ,@(let ((sforms (cons nil nil)))
+		   (dotimes (i (cadddr form) (car sforms))
+		     (add-forms (first-form-to-lisp forms cvector pv) sforms)))))))
+	(update-initialize-info-cache
+	 `((when (consp initargs)
+	     (setq initargs (cons (car initargs) (cdr initargs))))
+	   (setq *initialize-info-cache-class* ,(const (cadr form)))
+	   (setq *initialize-info-cache-initargs* initargs)
+	   (setq *initialize-info-cache-info* ,(const (caddr form)))))
+	(finish-pushing-initargs
+	 `((setq initargs-tail initargs)))))))
+
+(defmacro iis-body (&body forms)
+  `(let ((initargs-tail initargs)
+	 (slots (get-slots-or-nil instance))
+	 (class (class-of instance))
+	 (pv (car pv-cell))
+	 value)
+     initargs instance initargs-tail pv cvector slots class value
+     ,@forms))
+
+(defun form-list-to-lisp (pv-cell form-list)
+  (let* ((forms (list form-list))
+	 (cvector (make-array (floor (length form-list) 2)
+			      :fill-pointer 0 :adjustable t))
+	 (pv (car pv-cell))
+	 (body (let ((rforms (cons nil nil)))
+		 (loop (when (null (car forms)) (return (car rforms)))
+		       (add-forms (first-form-to-lisp forms cvector pv)
+				  rforms))))
+	 (cvector-type `(simple-vector ,(length cvector))))
+    (values
+     `(lambda (pv-cell cvector)
+        (declare (type ,cvector-type cvector))
+        #'(lambda (instance initargs)
+	    (declare #.*optimize-speed*)
+	    (iis-body ,@body)
+	    initargs))
+     (list pv-cell (coerce cvector cvector-type)))))
diff --git a/pcl/inline.lisp b/pcl/inline.lisp
new file mode 100644
index 000000000..b884310ef
--- /dev/null
+++ b/pcl/inline.lisp
@@ -0,0 +1,263 @@
+;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*-
+
+(in-package :pcl)
+
+;; This file contains some of the things that will have to change to support
+;; inlining of methods.
+
+(defun make-method-lambda-internal (method-lambda &optional env)
+  (unless (and (consp method-lambda) (eq (car method-lambda) 'lambda))
+    (error "The method-lambda argument to make-method-lambda, ~S,~
+            is not a lambda form" method-lambda))
+  (multiple-value-bind (documentation declarations real-body)
+      (extract-declarations (cddr method-lambda) env)
+    (let* ((name-decl (get-declaration 'method-name declarations))
+	   (sll-decl (get-declaration 'method-lambda-list declarations))
+	   (method-name (when (consp name-decl) (car name-decl)))
+	   (generic-function-name (when method-name (car method-name)))
+	   (specialized-lambda-list (or sll-decl (cadr method-lambda))))
+      (multiple-value-bind (parameters lambda-list specializers)
+	  (parse-specialized-lambda-list specialized-lambda-list)
+	(let* ((required-parameters
+		(mapcar #'(lambda (r s) (declare (ignore s)) r)
+			parameters
+			specializers))
+	       (slots (mapcar #'list required-parameters))
+	       (calls (list nil))
+	       (parameters-to-reference
+		(make-parameter-references specialized-lambda-list
+					   required-parameters
+					   declarations
+					   method-name
+					   specializers))
+	       (class-declarations
+		`(declare
+		  ,@(remove nil
+			    (mapcar #'(lambda (a s) (and (symbolp s)
+							 (neq s 't)
+							 `(class ,a ,s)))
+				    parameters
+				    specializers))))
+	       (method-lambda
+		  ;; Remove the documentation string and insert the
+		  ;; appropriate class declarations.  The documentation
+		  ;; string is removed to make it easy for us to insert
+		  ;; new declarations later, they will just go after the
+		  ;; cadr of the method lambda.  The class declarations
+		  ;; are inserted to communicate the class of the method's
+		  ;; arguments to the code walk.
+		  `(lambda ,lambda-list
+		     ,class-declarations
+		     ,@declarations
+		     (progn ,@parameters-to-reference)
+		     (block ,(if (listp generic-function-name)
+				 (cadr generic-function-name)
+				 generic-function-name)
+		       ,@real-body)))
+	       (constant-value-p (and (null (cdr real-body))
+				      (constantp (car real-body))))
+	       (constant-value (and constant-value-p
+				    (eval (car real-body))))
+	       (plist (if (and constant-value-p
+			       (or (typep constant-value '(or number character))
+				   (and (symbolp constant-value)
+					(symbol-package constant-value))))
+			  (list :constant-value constant-value)
+			  ()))
+	       (applyp (dolist (p lambda-list nil)
+			 (cond ((memq p '(&optional &rest &key))
+				(return t))
+			       ((eq p '&aux)
+				(return nil))))))
+	    (multiple-value-bind (walked-lambda call-next-method-p closurep
+						next-method-p-p)
+		(walk-method-lambda method-lambda required-parameters env 
+				    slots calls)
+	      (multiple-value-bind (ignore walked-declarations walked-lambda-body)
+		  (extract-declarations (cddr walked-lambda))
+		(declare (ignore ignore))
+		(when (or next-method-p-p call-next-method-p)
+		  (setq plist (list* :needs-next-methods-p 't plist)))
+		(when (some #'cdr slots)
+		  (multiple-value-bind (slot-name-lists call-list)
+		      (slot-name-lists-from-slots slots calls)
+		    (let ((pv-table-symbol (make-symbol "pv-table")))
+		      (setq plist 
+			    `(,@(when slot-name-lists 
+				  `(:slot-name-lists ,slot-name-lists))
+			      ,@(when call-list
+				  `(:call-list ,call-list))
+			      :pv-table-symbol ,pv-table-symbol
+			      ,@plist))
+		      (setq walked-lambda-body
+			    `((pv-binding (,required-parameters ,slot-name-lists
+					   ,pv-table-symbol)
+			       ,@walked-lambda-body))))))
+		(when (and (memq '&key lambda-list)
+			   (not (memq '&allow-other-keys lambda-list)))
+		  (let ((aux (memq '&aux lambda-list)))
+		    (setq lambda-list (nconc (ldiff lambda-list aux)
+					     (list '&allow-other-keys)
+					     aux))))
+		(values `(lambda (.method-args. .next-methods.)
+			   (simple-lexical-method-functions
+			       (,lambda-list .method-args. .next-methods.
+				:call-next-method-p ,call-next-method-p 
+				:next-method-p-p ,next-method-p-p
+				:closurep ,closurep
+				:applyp ,applyp)
+			     ,@walked-declarations
+			     ,@walked-lambda-body))
+			`(,@(when plist 
+			      `(:plist ,plist))
+			  ,@(when documentation 
+			      `(:documentation ,documentation)))))))))))
+
+(define-inline-function slot-value (instance slot-name) (form closure-p env)
+  :predicate (and (not closure-p) (constantp slot-name))
+  :inline-arguments (required-parameters slots)
+  :inline (optimize-slot-value     
+	   slots
+	   (can-optimize-access form required-parameters env)
+	   form))
+
+;collect information about:
+; uses of the required-parameters
+; uses of call-next-method and next-method-p:
+;   called-p
+;   apply-p
+;   arglist info
+;optimize calls to slot-value, set-slot-value, slot-boundp
+;optimize calls to find-class
+;optimize generic-function calls
+(defun make-walk-function (required-parameters info slots calls)
+  #'(lambda (form context env)
+      (cond ((not (eq context ':eval)) form)
+	    ((not (listp form)) form)
+	    ((eq (car form) 'call-next-method)
+	     (setq call-next-method-p 't)
+	     form)
+	    ((eq (car form) 'next-method-p)
+	     (setq next-method-p-p 't)
+	     form)
+	    ((and (eq (car form) 'function)
+		  (cond ((eq (cadr form) 'call-next-method)
+			 (setq call-next-method-p 't)
+			 (setq closurep t)
+			 form)
+			((eq (cadr form) 'next-method-p)
+			 (setq next-method-p-p 't)
+			 (setq closurep t)
+			 form)
+			(t nil))))
+	    ((and (or (eq (car form) 'slot-value)
+		      (eq (car form) 'set-slot-value)
+		      (eq (car form) 'slot-boundp))
+		  (constantp (caddr form)))
+	     (let ((parameter
+		    (can-optimize-access form
+					 required-parameters env)))
+	       (ecase (car form)
+		 (slot-value
+		  (optimize-slot-value     slots parameter form))
+		 (set-slot-value
+		  (optimize-set-slot-value slots parameter form))
+		 (slot-boundp
+		  (optimize-slot-boundp    slots parameter form)))))
+	    ((and (or (symbolp (car form))
+		      (and (consp (car form))
+			   (eq (caar form) 'setf)))
+		  (gboundp (car form))
+		  (if (eq *boot-state* 'complete)
+		      (standard-generic-function-p (gdefinition (car form)))
+		      (funcallable-instance-p (gdefinition (car form)))))
+	     (optimize-generic-function-call 
+	      form required-parameters env slots calls))
+	    (t form))))
+
+(defun walk-method-lambda (method-lambda required-parameters env slots calls)
+  (let* ((call-next-method-p nil)   ;flag indicating that call-next-method
+				    ;should be in the method definition
+	 (closurep nil)		    ;flag indicating that #'call-next-method
+				    ;was seen in the body of a method
+	 (next-method-p-p nil)      ;flag indicating that next-method-p
+				    ;should be in the method definition
+	 (walk-functions `((call-next-method-p
+			    ,#'(lambda (form closure-p env)
+				 (setq call-next-method-p 't)
+				 (when closure-p
+				   (setq closurep t))
+				 form))
+			   (next-method-p
+			    ,#'(lambda (form closure-p env)
+				 (setq next-method-p-p 't)
+				 (when closure-p
+				   (setq closurep t))
+				 form))
+			   ((slot-value set-slot-value slot-boundp)
+			    ,#'(lambda (form closure-p env)
+				 (if (and (not closure-p)
+					  (constantp (caddr form)))
+				     
+    (let ((walked-lambda (walk-form method-lambda env 
+				    (make-walk-function 
+				     `((call-next-method-p
+					,#'(lambda (form closure-p env)
+					     (setq call-next-method-p 't)
+					     (when closure-p
+					       (setq closurep t))
+					     form))
+				       (next-method-p
+					,#'(lambda (form closure-p env)
+					     (setq next-method-p-p 't)
+					     (when closure-p
+					       (setq closurep t))
+					     form))
+				       ((slot-value set-slot-value slot-boundp)
+					,#'(lambda (form closure-p env)
+					     (
+      (values walked-lambda
+	      call-next-method-p closurep next-method-p-p)))))
+
+(defun initialize-method-function (initargs &optional return-function-p method)
+  (let* ((mf (getf initargs ':function))
+	 (method-spec (getf initargs ':method-spec))
+	 (plist (getf initargs ':plist))
+	 (pv-table-symbol (getf plist ':pv-table-symbol))
+	 (pv-table nil)
+	 (mff (getf initargs ':fast-function)))
+    (flet ((set-mf-property (p v)
+	     (when mf
+	       (setf (method-function-get mf p) v))
+	     (when mff
+	       (setf (method-function-get mff p) v))))
+      (when method-spec
+	(when mf
+	  (setq mf (set-function-name mf method-spec)))
+	(when mff
+	  (let ((name `(,(or (get (car method-spec) 'fast-sym)
+			     (setf (get (car method-spec) 'fast-sym)
+				   (intern (format nil "FAST-~A"
+						   (car method-spec))
+					   *the-pcl-package*)))
+			 ,@(cdr method-spec))))
+	    (set-function-name mff name)
+	    (unless mf
+	      (set-mf-property :name name)))))
+      (when plist
+	(let ((snl (getf plist :slot-name-lists))
+	      (cl (getf plist :call-list)))
+	  (when (or snl cl)
+	    (setq pv-table (intern-pv-table :slot-name-lists snl
+					    :call-list cl))
+	    (when pv-table (set pv-table-symbol pv-table))
+	    (set-mf-property :pv-table pv-table)))    
+	(loop (when (null plist) (return nil))
+	      (set-mf-property (pop plist) (pop plist)))      
+	(when method
+	  (set-mf-property :method method))    
+	(when return-function-p
+	  (or mf (method-function-from-fast-function mff)))))))
+
+
+
diff --git a/pcl/misc-kcl-patches.text b/pcl/misc-kcl-patches.text
new file mode 100644
index 000000000..54bb9c718
--- /dev/null
+++ b/pcl/misc-kcl-patches.text
@@ -0,0 +1,340 @@
+c/cmpaux.c
+*** c/cmpaux.c    Mon Jul  6 00:14:55 1992
+--- ../akcl-1-615/c/cmpaux.c      Thu Jun 18 20:01:07 1992
+***************
+*** 229,239 ****
+      if (leng > 0 && leng < x->st.st_dim && x->st.st_self[leng]==0)
+      return x->st.st_self;
+    if (x->st.st_dim == leng
+        && ( leng % sizeof(object))
+       )
+!     { x->st.st_self[leng] = 0;
+        return x->st.st_self;
+      }
+    else
+      {char *res=malloc(leng+1);
+       bcopy(x->st.st_self,res,leng);
+--- 229,240 ----
+      if (leng > 0 && leng < x->st.st_dim && x->st.st_self[leng]==0)
+      return x->st.st_self;
+    if (x->st.st_dim == leng
+        && ( leng % sizeof(object))
+       )
+!     { if(x->st.st_self[leng] != 0)
+!          x->st.st_self[leng] = 0;
+        return x->st.st_self;
+      }
+    else
+      {char *res=malloc(leng+1);
+       bcopy(x->st.st_self,res,leng);
+c/main.c
+*** c/main.c      Mon Jul  6 00:14:59 1992
+--- ../akcl-1-615/c/main.c        Fri Jul  3 02:19:37 1992
+***************
+*** 611,621 ****
+            {catch_fatal = -1;
+             if (sgc_enabled)
+               { sgc_quit();}
+             if (sgc_enabled==0)
+               { install_segmentation_catcher() ;}
+!            FEerror("Caught fatal error [memory may be damaged]"); }
+          printf("\nUnrecoverable error: %s.\n", s);
+          fflush(stdout);
+  #ifdef UNIX
+          abort();
+  #endif
+--- 611,621 ----
+            {catch_fatal = -1;
+             if (sgc_enabled)
+               { sgc_quit();}
+             if (sgc_enabled==0)
+               { install_segmentation_catcher() ;}
+!            FEerror("Caught fatal error [memory may be damaged] ~A",1,make_simple_string(s)); }
+          printf("\nUnrecoverable error: %s.\n", s);
+          fflush(stdout);
+  #ifdef UNIX
+          abort();
+  #endif
+***************
+*** 853,872 ****
+  
+  siLsave_system()
+  {
+          int i;
+  
+- #ifdef HAVE_YP_UNBIND
+-         extern object truename(),namestring();
+          check_arg(1);
+!         /* prevent subsequent consultation of yp by getting
+!            truename now*/
+!         vs_base[0]=namestring(truename(vs_base[0]));
+!         {char name[200];
+!          char *dom = name;
+!          if (0== getdomainname(dom,sizeof(name)))
+!            yp_unbind(dom);}
+  #endif
+          
+          saving_system = TRUE;
+          GBC(t_contiguous);
+  
+--- 853,867 ----
+  
+  siLsave_system()
+  {
+          int i;
+  
+          check_arg(1);
+! #ifdef HAVE_YP_UNBIND
+!         /* see unixsave.c */
+!         {char *dname;
+!          yp_get_default_domain(&dname);}
+  #endif
+          
+          saving_system = TRUE;
+          GBC(t_contiguous);
+  
+c/num_log.c
+*** c/num_log.c   Mon Jul  6 00:15:00 1992
+--- ../akcl-1-615/c/num_log.c     Mon Jun 15 21:15:59 1992
+***************
+*** 266,286 ****
+          return(~j);
+  }
+  
+  int
+  big_bitp(x, p)
+! object  x;
+! int     p;
+  { GEN u = MP(x);
+    int ans ;
+    int i = p /32;
+    if (signe(u) < 0)
+      {  save_avma;
+         u = complementi(u);
+         restore_avma;
+     }
+!   if (i < lgef(u))
+      { ans = ((MP_ITH_WORD(u,i,lgef(u))) & (1 << p%32));}
+    else if (big_sign(x) < 0) ans = 1;
+    else ans = 0;
+    return ans;
+  }
+--- 266,286 ----
+          return(~j);
+  }
+  
+  int
+  big_bitp(x, p)
+! object  x;
+! int     p;
+  { GEN u = MP(x);
+    int ans ;
+    int i = p /32;
+    if (signe(u) < 0)
+      {  save_avma;
+         u = complementi(u);
+         restore_avma;
+     }
+!   if (i < lgef(u) -MP_CODE_WORDS)
+      { ans = ((MP_ITH_WORD(u,i,lgef(u))) & (1 << p%32));}
+    else if (big_sign(x) < 0) ans = 1;
+    else ans = 0;
+    return ans;
+  }
+c/unixsave.c
+*** c/unixsave.c  Mon Jul  6 00:15:07 1992
+--- ../akcl-1-615/c/unixsave.c    Fri Jul  3 02:52:36 1992
+***************
+*** 71,81 ****
+--- 71,160 ----
+                          break;
+                  } else
+                          break;
+  }
+  
++ #include "page.h"
+  
++ /* string is aligned on a word boundary */
++ int
++ find_string_in_memory(string,length,other_p,function)
++      char *string;
++      int length,other_p;
++      int *function();
++ {
++   int *imem_first,*imem_last,*imem,word;
++   char *mem;
++   int len,page_first,page_last,i;
++   int maxpage = page(heap_end);
++   if(((int)string & 3) == 0 && length >= 4) /* just to be safe */
++     {word=*(int *)string;
++      for (page_first = 0;  page_first < maxpage;  page_first++)
++        if ((enum type)type_map[page_first] != t_other)
++          break;
++      for (;  page_first < maxpage;  page_first++)
++        if (((enum type)type_map[page_first] == t_other)?other_p:!other_p)
++          {for (page_last = page_first+1;  page_last < maxpage;  page_last++)
++             if ( !(((enum type)type_map[page_last] == t_other)?other_p:!other_p) )
++               break;
++           imem_first=(int *)pagetochar(page_first);
++           imem_last=(int *)( ( ((int)pagetochar(page_last)) - length) &~3 );
++           for (imem = imem_first; imem <= imem_last; imem++)
++             if (*imem == word)
++               {mem=(char *)imem;
++                for(i=4; i<length && mem[i]==string[i]; i++);
++                if(i>=length)
++                  if((*function)(mem))
++                    return TRUE;}}}
++   return FALSE;
++ }
++ 
++ int 
++ fsim_first(address)
++      char *address;
++ {
++   return TRUE;
++ }
++ 
++ int 
++ fsim_reset_pointer(address)
++      char **address;
++ {
++   *address = NULL;
++   return FALSE;
++ }
++ 
++ #define t_other_PAGES TRUE
++ #define NOT_t_other_PAGES FALSE
++ 
++ int
++ reset_other_pointers(address)
++      char *address;
++ {
++   int word=(int)address;
++   find_string_in_memory(&word,4,t_other_PAGES,fsim_reset_pointer);
++ }
++ 
++ int
++ maybe_reset_pointers(address)
++      char *address;
++ {
++   int word=(int)address;
++   if(!find_string_in_memory(&word,4,NOT_t_other_PAGES,fsim_first))
++     reset_other_pointers(address);
++   return FALSE;
++ }
++ 
++ reset_other_pointers_to_string(string)
++      char *string;
++ {
++   int length=strlen(string)+1;
++   find_string_in_memory(string,length,t_other_PAGES,maybe_reset_pointers);
++ }
++ 
++ bool saving_system;
++ 
+  memory_save(original_file, save_file)
+  char *original_file, *save_file;
+  {       MEM_SAVE_LOCALS;
+          char *data_begin, *data_end;
+          int original_data;
+***************
+*** 100,110 ****
+--- 179,206 ----
+          n = open(save_file, O_CREAT|O_WRONLY, 0777);
+          if (n != 1 || (save = fdopen(n, "w")) != stdout) {
+                  fprintf(stderr, "Can't open the save file.\n");
+                  exit(1);
+          }
++ 
+          setbuf(save, stdout_buf);
++ 
++ #ifdef HAVE_YP_UNBIND
++ /* yp_get_default_domain() caches the result of getdomainname() in
++    a malloc'ed block of memory; and gethostbyname saves the result of
++    yp_get_default_domain() in yet another chunk of memory.  These
++    cached values will cause problems if the saved image is run on a
++    machine having a different local domainname.  [When getdomainname 
++    is called (by CLX, for example) KCL will wait forever.]  There doesn't
++    seem to be any way to uncache these things (apparently yp_unbind does 
++    not do this), nor any good way to find these blocks of memory.         */
++    
++         if(saving_system)
++           {char *dname;
++            yp_get_default_domain(&dname);
++            reset_other_pointers(dname);}
++ #endif
+  
+          READ_HEADER;
+          FILECPY_HEADER;
+  
+          for (n = header.a_data, p = data_begin;  ;  n -= BUFSIZ, p += BUFSIZ)
+cmpnew/cmpcall.lsp
+*** cmpnew/cmpcall.lsp    Mon Jul  6 00:15:13 1992
+--- ../akcl-1-615/cmpnew/cmpcall.lsp      Thu Jun 18 21:43:24 1992
+***************
+*** 118,127 ****
+--- 118,128 ----
+                          ;;; responsible for maintaining this condition.
+        (let ((*vs* *vs*) (form (caddr funob)))
+             (declare (object form))
+             (cond ((and (listp args)
+                         *use-sfuncall*
++                        (<= (length (cdr args)) 10)
+                         ;;Determine if only one value at most is required:
+                         (or
+                          (eq *value-to-go* 'trash)
+                          (and (consp *value-to-go*)
+                               (eq (car *value-to-go*) 'var))
+lsp/autoload.lsp
+*** lsp/autoload.lsp      Mon Jul  6 00:15:27 1992
+--- ../akcl-1-615/lsp/autoload.lsp        Tue Jun 16 02:36:45 1992
+***************
+*** 430,440 ****
+          '(cons
+            fixnum bignum ratio short-float long-float complex
+            character symbol package hash-table
+            array vector string bit-vector
+            structure stream random-state readtable pathname
+!           cfun cclosure sfun gfun cfdata spice fat-string ))
+  
+  (defun room (&optional x)
+    (let ((l (multiple-value-list (si:room-report)))
+          maxpage leftpage ncbpage maxcbpage ncb cbgbccount npage
+          rbused rbfree nrbpage
+--- 430,440 ----
+          '(cons
+            fixnum bignum ratio short-float long-float complex
+            character symbol package hash-table
+            array vector string bit-vector
+            structure stream random-state readtable pathname
+!           cfun cclosure sfun gfun vfun cfdata spice fat-string dclosure))
+  
+  (defun room (&optional x)
+    (let ((l (multiple-value-list (si:room-report)))
+          maxpage leftpage ncbpage maxcbpage ncb cbgbccount npage
+          rbused rbfree nrbpage
+lsp/cmpinit.lsp
+*** lsp/cmpinit.lsp       Mon Jul  6 00:15:28 1992
+--- ../akcl-1-615/lsp/cmpinit.lsp Mon Jun 22 17:11:11 1992
+***************
+*** 4,12 ****
+  (setq compiler::*eval-when-defaults* '(compile eval load))
+  (or (fboundp 'si::get-&environment) (load "defmacro.lsp"))
+  ;(or (get 'si::s-data 'si::s-data)
+  ;    (progn (load "../lsp/setf.lsp") (load "../lsp/defstruct.lsp")))
+  (if (probe-file "sys-proclaim.lisp")(load "sys-proclaim.lisp"))
+! 
+! 
+  
+  ;;;;;
+--- 4,13 ----
+  (setq compiler::*eval-when-defaults* '(compile eval load))
+  (or (fboundp 'si::get-&environment) (load "defmacro.lsp"))
+  ;(or (get 'si::s-data 'si::s-data)
+  ;    (progn (load "../lsp/setf.lsp") (load "../lsp/defstruct.lsp")))
+  (if (probe-file "sys-proclaim.lisp")(load "sys-proclaim.lisp"))
+! (unless (get 'si::basic-wrapper 'si::s-data)
+!   (setf (get 'si::s-data 'si::s-data) nil)
+!   (load "../lsp/defstruct.lsp"))
+  
+  ;;;;;
diff --git a/pcl/new-kcl-wrapper.text b/pcl/new-kcl-wrapper.text
new file mode 100644
index 000000000..7f161a6c5
--- /dev/null
+++ b/pcl/new-kcl-wrapper.text
@@ -0,0 +1,2157 @@
+The new-kcl-wrapper modifications make the storage of standard-objects
+and structure objects much more similar than before.  These changes should 
+greatly speed up WRAPPER-OF for structure objects and should speed up
+WRAPPER-OF for standard-instances also (but not funcallable instances).
+
+Look first at the defstructs defined here (scan this file for "(defstruct (").
+Then look at cache.lisp, at the "#+structure-wrapper" for the new definition of
+the wrapper structure.  Finally, look in low.lisp, at the 
+"#+new-structure-wrapper" for the definition of %allocate-instance--class.
+
+You need to have akcl-1-615 to use this file.
+
+This file contains new versions of the files V/c/structure.c and 
+V/lsp/defstruct.lsp, as well as small changes to the files c/gbc.c, c/sgbc.c, 
+cmpnew/cmpinit.lsp, lsp/cmpinit.lsp, and lsp/describe.lsp.
+
+-- The gbc changes allow the garbage collector to work correctly even when
+structures which define other structures (ones which can be the value of 
+STRUCTURE-DEF) are not allocated in static storage. 
+
+
+c/gbc.c
+*** c/gbc.c       Tue Jun 30 04:11:00 1992
+--- ../akcl-1-615/c/gbc.c Tue Jun 30 02:48:04 1992
+***************
+*** 427,453 ****
+                          break;
+                  goto COPY_STRING;
+  
+          case t_structure:
+                  mark_object(x->str.str_def);
+                  p = x->str.str_self;
+                  if (p == NULL)
+!                         break;
+!                 {object def=x->str.str_def;
+!                  unsigned char * s_type = &SLOT_TYPE(def,0);
+!                  unsigned short *s_pos= & SLOT_POS(def,0);
+!                  for (i = 0, j = S_DATA(def)->length;  i < j;  i++)
+                     if (s_type[i]==0) mark_object(STREF(object,x,s_pos[i]));
+                   if ((int)what_to_collect >= (int)t_contiguous) {
+                       if (inheap(x->str.str_self)) {
+                         if (what_to_collect == t_contiguous)
+                           mark_contblock((char *)p,
+!                                         S_DATA(def)->size);
+  
+                       } else
+!                        x->str.str_self = (object *)
+!                          copy_relblock((char *)p, S_DATA(def)->size);
+                     }}
+                  break;
+  
+          case t_stream:
+                  switch (x->sm.sm_mode) {
+--- 427,461 ----
+                          break;
+                  goto COPY_STRING;
+  
+          case t_structure:
++                 x->d.m = 2; 
+                  mark_object(x->str.str_def);
+                  p = x->str.str_self;
+                  if (p == NULL)
+!                         {x->d.m = TRUE; break;}
+!                 {object def=x->str.str_def;
+!                  struct s_data *sdef=S_DATA(def);
+!                  unsigned char *s_type;
+!                  unsigned short *s_pos;
+!                  if((int)what_to_collect >= (int)t_contiguous &&
+!                     !inheap(sdef) && def->d.m==TRUE)
+!                    sdef=(struct s_data *)(((char *)sdef)+(rb_start1-rb_start));
+!                  s_type = sdef->raw->ust.ust_self;
+!                  s_pos = &USHORT(sdef->slot_position,0);
+!                  for (i = 0, j = sdef->length;  i < j;  i++)
+                     if (s_type[i]==0) mark_object(STREF(object,x,s_pos[i]));
+                   if ((int)what_to_collect >= (int)t_contiguous) {
+                       if (inheap(x->str.str_self)) {
+                         if (what_to_collect == t_contiguous)
+                           mark_contblock((char *)p,
+!                                         sdef->size);
+  
+                       } else
+!                         x->str.str_self = (object *)
+!                          copy_relblock((char *)p, sdef->size);
+                     }}
++                 x->d.m = TRUE; 
+                  break;
+  
+          case t_stream:
+                  switch (x->sm.sm_mode) {
+*** c/sgbc.c      Mon Jun 15 21:16:01 1992
+--- akcl-1-615/c/sgbc.c   Wed Jul  1 18:37:24 1992
+***************
+*** 355,386 ****
+                  if (cp == NULL)
+                          break;
+                  goto COPY_STRING;
+  
+          case t_structure:
+                  sgc_mark_object(x->str.str_def);
+                  p = x->str.str_self;
+                  if (p == NULL)
+!                         break;
+!                 {object def=x->str.str_def;
+!                  unsigned char * s_type = &SLOT_TYPE(def,0);
+!                  unsigned short *s_pos= & SLOT_POS(def,0);
+!                  for (i = 0, j = S_DATA(def)->length;  i < j;  i++)
+                     if (s_type[i]==0 &&
+                         ON_WRITABLE_PAGE(& STREF(object,x,s_pos[i]))
+                         )
+                       sgc_mark_object(STREF(object,x,s_pos[i]));
+                   if ((int)what_to_collect >= (int)t_contiguous) {
+                       if (inheap(x->str.str_self)) {
+                         if (what_to_collect == t_contiguous)
+                           mark_contblock((char *)p,
+!                                         S_DATA(def)->size);
+  
+                       } else if(SGC_RELBLOCK_P(p))
+                         x->str.str_self = (object *)
+!                          copy_relblock((char *)p, S_DATA(def)->size);
+                     }}
+                  break;
+  
+          case t_stream:
+                  switch (x->sm.sm_mode) {
+                  case smm_input:
+--- 355,394 ----
+                  if (cp == NULL)
+                          break;
+                  goto COPY_STRING;
+  
+          case t_structure:
++                 x->d.m = 2;
+                  sgc_mark_object(x->str.str_def);
+                  p = x->str.str_self;
+                  if (p == NULL)
+!                         {x->d.m = TRUE; break;}
+!                 {object def=x->str.str_def;
+!                  struct s_data *sdef=S_DATA(def);
+!                  unsigned char *s_type;
+!                  unsigned short *s_pos;
+!                  if((int)what_to_collect >= (int)t_contiguous &&
+!                     !inheap(sdef) && def->d.m==TRUE)
+!                    sdef=(struct s_data *)(((char *)sdef)+(rb_start1-rb_start));
+!                  s_type = sdef->raw->ust.ust_self;
+!                  s_pos = &USHORT(sdef->slot_position,0);
+!                  for (i = 0, j = sdef->length;  i < j;  i++)
+                     if (s_type[i]==0 &&
+                         ON_WRITABLE_PAGE(& STREF(object,x,s_pos[i]))
+                         )
+                       sgc_mark_object(STREF(object,x,s_pos[i]));
+                   if ((int)what_to_collect >= (int)t_contiguous) {
+                       if (inheap(x->str.str_self)) {
+                         if (what_to_collect == t_contiguous)
+                           mark_contblock((char *)p,
+!                                         sdef->size);
+  
+                       } else if(SGC_RELBLOCK_P(p))
+                         x->str.str_self = (object *)
+!                          copy_relblock((char *)p, sdef->size);
+                     }}
++                 x->d.m = TRUE; 
+                  break;
+  
+          case t_stream:
+                  switch (x->sm.sm_mode) {
+                  case smm_input:
+cmpnew/cmpinit.lsp
+*** cmpnew/cmpinit.lsp    Tue Jun 30 04:11:13 1992
+--- ../akcl-1-615/cmpnew/cmpinit.lsp      Mon Jun 22 18:41:51 1992
+***************
+*** 4,7 ****
+--- 4,10 ----
+  (load "sys-proclaim.lisp")
+  (setq compiler::*eval-when-defaults* '(compile eval load))
+  
+  ;(dolist (v '( cmpeval cmpopt cmptype cmpbind cmpinline cmploc cmpvar cmptop cmplet cmpcall cmpmulti cmplam cmplabel          cmpeval))   (load (format nil "~(~a~).lsp" v)))
++ (unless (get 'si::basic-wrapper 'si::s-data)
++   (setf (get 'si::s-data 'si::s-data) nil)
++   (load "../lsp/defstruct.lsp"))
+lsp/cmpinit.lsp
+*** lsp/cmpinit.lsp       Tue Jun 30 04:11:26 1992
+--- ../akcl-1-615/lsp/cmpinit.lsp Mon Jun 22 17:11:11 1992
+***************
+*** 5,12 ****
+  (or (fboundp 'si::get-&environment) (load "defmacro.lsp"))
+  ;(or (get 'si::s-data 'si::s-data)
+  ;    (progn (load "../lsp/setf.lsp") (load "../lsp/defstruct.lsp")))
+  (if (probe-file "sys-proclaim.lisp")(load "sys-proclaim.lisp"))
+! 
+! 
+  
+  ;;;;;
+--- 5,13 ----
+  (or (fboundp 'si::get-&environment) (load "defmacro.lsp"))
+  ;(or (get 'si::s-data 'si::s-data)
+  ;    (progn (load "../lsp/setf.lsp") (load "../lsp/defstruct.lsp")))
+  (if (probe-file "sys-proclaim.lisp")(load "sys-proclaim.lisp"))
+! (unless (get 'si::basic-wrapper 'si::s-data)
+!   (setf (get 'si::s-data 'si::s-data) nil)
+!   (load "../lsp/defstruct.lsp"))
+  
+  ;;;;;
+lsp/describe.lsp
+*** lsp/describe.lsp      Tue Jun 30 04:11:27 1992
+--- ../akcl-1-615/lsp/describe.lsp        Tue Jun 23 16:39:07 1992
+***************
+*** 266,282 ****
+  
+  (defun inspect-structure (x &aux name)
+    (format t "Structure of type ~a ~%Byte:[Slot Type]Slot Name   :Slot Value"
+            (setq name (type-of x)))
+!   (let* ((sd (get name 'si::s-data))
+           (spos (s-data-slot-position sd)))
+      (dolist (v (s-data-slot-descriptions sd))
+              (format t "~%~4d:~@[[~s] ~]~20a:~s"   
+!                     (aref spos (nth 4 v))
+!                     (let ((type (nth 2 v)))
+                        (if (eq t type) nil type))
+!                     (car v)
+!                     (structure-ref1 x (nth 4 v))))))
+      
+    
+  (defun inspect-object (object &aux (*inspect-level* *inspect-level*))
+    (inspect-indent)
+--- 266,282 ----
+  
+  (defun inspect-structure (x &aux name)
+    (format t "Structure of type ~a ~%Byte:[Slot Type]Slot Name   :Slot Value"
+            (setq name (type-of x)))
+!   (let* ((sd (structure-def x))
+           (spos (s-data-slot-position sd)))
+      (dolist (v (s-data-slot-descriptions sd))
+              (format t "~%~4d:~@[[~s] ~]~20a:~s"   
+!                     (aref spos (slot-offset v))
+!                     (let ((type (slot-type v)))
+                        (if (eq t type) nil type))
+!                     (slot-name v)
+!                     (structure-ref1 x (slot-offset v))))))
+      
+    
+  (defun inspect-object (object &aux (*inspect-level* *inspect-level*))
+    (inspect-indent)
+==============================================================================
+=============================== c/structure.c ================================
+Changes file for /kcl/c/structure.c
+Usage \n@s[Original text\n@s|Replacement Text\n@s]
+See the file rascal.ics.utexas.edu:/usr2/ftp/merge.c
+for a program to merge change files.  Anything not between
+ "\n@s[" and  "\n@s]" is a simply a comment.
+This file was constructed using emacs and  merge.el
+ by (Bill Schelter)  wfs@carl.ma.utexas.edu 
+
+
+****Change:(orig (15 17 d))
+@s[object siSstructure_print_function;
+object siSstructure_slot_descriptions;
+object siSstructure_include;
+
+@s|
+@s]
+
+
+****Change:(orig (18 18 a))
+@s[
+
+@s|
+#define COERCE_DEF(x) if (type_of(x)==t_symbol) \
+  x=getf(x->s.s_plist,siLs_data,Cnil)
+
+#define check_type_structure(x) \
+  if(type_of((x))!=t_structure) \
+    FEwrong_type_argument(Sstructure,(x)) 
+
+
+
+@s]
+
+
+****Change:(orig (22 31 c))
+@s[{
+	do {
+		if (type_of(x) != t_symbol)
+		        return(FALSE);
+
+@s,       } while (x != Cnil);
+	return(FALSE);
+}
+
+@s|{ if (x==y) return 1;
+  if (type_of(x)!= t_structure
+      || type_of(y)!=t_structure)
+    FEerror("bad call to structure_subtypep",0);
+  {if (S_DATA(y)->included == Cnil) return 0;
+   while ((x=S_DATA(x)->includes) != Cnil)
+     { if (x==y) return 1;}
+   return 0;
+ }}
+
+@s]
+
+
+****Change:(orig (32 32 a))
+@s[
+
+@s|
+static
+bad_raw_type()
+{           FEerror("Bad raw struct type",0);}
+
+
+
+@s]
+
+
+****Change:(orig (34 34 c))
+@s[structure_ref(x, name, n)
+
+@s|structure_ref(x, name, i)
+
+@s]
+
+
+****Change:(orig (36 38 c))
+@s[object x, name;
+int n;
+{
+	int i;
+
+@s|object x, name;
+int i;
+{unsigned short *s_pos;
+ COERCE_DEF(name);
+ if (type_of(x) != t_structure ||
+     (type_of(name)!=t_structure) ||
+     !structure_subtypep(x->str.str_def, name))
+   FEwrong_type_argument((type_of(name)==t_structure ?
+		          S_DATA(name)->name : name),
+		         x);
+ s_pos = &SLOT_POS(x->str.str_def,0);
+ switch((SLOT_TYPE(x->str.str_def,i)))
+   {
+   case aet_object: return(STREF(object,x,s_pos[i]));
+   case aet_fix:  return(make_fixnum((STREF(int,x,s_pos[i]))));
+   case aet_ch:  return(code_char(STREF(char,x,s_pos[i])));
+   case aet_bit:
+   case aet_char: return(make_fixnum(STREF(char,x,s_pos[i])));
+   case aet_sf: return(make_shortfloat(STREF(shortfloat,x,s_pos[i])));
+   case aet_lf: return(make_longfloat(STREF(longfloat,x,s_pos[i])));
+   case aet_uchar: return(make_fixnum(STREF(unsigned char,x,s_pos[i])));
+   case aet_ushort: return(make_fixnum(STREF(unsigned short,x,s_pos[i])));
+   case aet_short: return(make_fixnum(STREF(short,x,s_pos[i])));
+   default:
+     bad_raw_type();
+     return 0;
+   }}
+
+@s]
+
+
+****Change:(orig (40 43 c))
+@s[       if (type_of(x) != t_structure ||
+	    !structure_subtypep(x->str.str_name, name))
+		FEwrong_type_argument(name, x);
+	return(x->str.str_self[n]);
+
+@s|
+void
+siLstructure_ref1()
+{object x=vs_base[0];
+ int n=fix(vs_base[1]);
+ object def;
+ check_type_structure(x);
+ def=x->str.str_def;
+ if(n>= S_DATA(def)->length)
+   FEerror("Structure ref out of bounds",0);
+ vs_base[0]=structure_ref(x,x->str.str_def,n);
+ vs_top=vs_base+1;
+
+@s]
+
+
+****Change:(orig (45 45 a))
+@s[}
+
+
+@s|}
+
+void
+siLstructure_set1()
+{object x=vs_base[0];
+ int n=fix(vs_base[1]);
+ object v=vs_base[2];
+ object def;
+ check_type_structure(x);
+ def=x->str.str_def;
+ if(n>= S_DATA(def)->length)
+   FEerror("Structure ref out of bounds",0);
+ vs_base[0]=structure_set(x,x->str.str_def,n,v);
+ vs_top=vs_base+1;
+}  
+
+
+
+@s]
+
+
+****Change:(orig (47 47 c))
+@s[structure_set(x, name, n, v)
+
+@s|structure_set(x, name, i, v)
+
+@s]
+
+
+****Change:(orig (49 51 c))
+@s[object x, name, v;
+int n;
+{
+	int i;
+
+@s|object x, name, v;
+int i;
+{unsigned short *s_pos;
+ 
+ COERCE_DEF(name);
+ if (type_of(x) != t_structure ||
+     type_of(name) != t_structure ||
+     !structure_subtypep(x->str.str_def, name))
+   FEwrong_type_argument((type_of(name)==t_structure ?
+		          S_DATA(name)->name : name)
+		         , x);
+
+@s]
+
+
+****Change:(orig (53 57 c))
+@s[       if (type_of(x) != t_structure ||
+	    !structure_subtypep(x->str.str_name, name))
+		FEwrong_type_argument(name, x);
+	x->str.str_self[n] = v;
+
+@s,       return(v);
+
+@s|#ifdef SGC
+ /* make sure the structure header is on a writable page */
+ if (x->d.m) FEerror("bad gc field",0); else  x->d.m = 0;
+#endif   
+ 
+ s_pos= & SLOT_POS(x->str.str_def,0);
+ switch(SLOT_TYPE(x->str.str_def,i)){
+   
+   case aet_object: STREF(object,x,s_pos[i])=v; break;
+   case aet_fix:  (STREF(int,x,s_pos[i]))=fix(v); break;
+   case aet_ch:  STREF(char,x,s_pos[i])=char_code(v); break;
+   case aet_bit:
+   case aet_char: STREF(char,x,s_pos[i])=fix(v); break;
+   case aet_sf: STREF(shortfloat,x,s_pos[i])=sf(v); break;
+   case aet_lf: STREF(longfloat,x,s_pos[i])=lf(v); break;
+   case aet_uchar: STREF(unsigned char,x,s_pos[i])=fix(v); break;
+   case aet_ushort: STREF(unsigned short,x,s_pos[i])=fix(v); break;
+   case aet_short: STREF(short,x,s_pos[i])=fix(v); break;
+ default:
+   bad_raw_type();
+
+   }
+ return(v);
+
+@s]
+
+
+****Change:(orig (59 59 a))
+@s[}
+
+
+@s|}
+
+void
+siLstructure_subtype_p()
+{object x,y;
+ check_arg(2);
+ x=vs_base[0];
+ y=vs_base[1];
+ if (type_of(x)!=t_structure)
+   {vs_base[0]=Cnil; goto BOTTOM;}
+ x=x->str.str_def;
+ COERCE_DEF(y);
+ if (structure_subtypep(x,y)) vs_base[0]=Ct;
+ else vs_base[0]=Cnil;
+ BOTTOM:
+ vs_top=vs_base+1;
+}
+ 
+static object
+slot_name(x)
+     object x;
+{
+  if(type_of(x)==t_cons)
+    return car(x);
+  if(type_of(x)==t_structure)
+    return x->str.str_self[0];
+  return Cnil;
+}
+
+
+@s]
+
+
+****Change:(orig (64 64 a))
+@s[object x;
+{
+	object *p, s;
+
+@s|object x;
+{
+	object *p, s;
+	struct s_data *def=S_DATA(x->str.str_def);
+
+@s]
+
+
+****Change:(orig (66 69 c))
+@s[
+	s = getf(x->str.str_name->s.s_plist,
+	         siSstructure_slot_descriptions, Cnil);
+	vs_push(x->str.str_name);
+
+@s|       
+	s = def->slot_descriptions;
+	vs_push(def->name);
+
+@s]
+
+
+****Change:(orig (72 73 c))
+@s[       for (i=0, n=x->str.str_length;  !endp(s)&&i<n;  s=s->c.c_cdr, i++) {
+		*p = make_cons(car(s->c.c_car), Cnil);
+
+@s|       for (i=0, n=def->length;  !endp(s)&&i<n;  s=s->c.c_cdr, i++) {
+		*p = make_cons(slot_name(s->c.c_car), Cnil);
+
+@s]
+
+
+****Change:(orig (75 75 c))
+@s[               *p = make_cons(x->str.str_self[i], Cnil);
+
+@s|               *p = make_cons(structure_ref(x,x->str.str_def,i), Cnil);
+
+@s]
+
+
+****Change:(orig (81 81 a))
+@s[       stack_cons();
+	return(vs_pop);
+}
+
+
+@s|       stack_cons();
+	return(vs_pop);
+}
+
+void
+
+@s]
+
+
+****Change:(orig (84 85 c))
+@s[       object x;
+	int narg, i;
+
+@s|  object x,name,*base;
+  struct s_data *def;
+  int narg, i,size;
+  base=vs_base;
+  if ((narg = vs_top - base) == 0)
+    too_few_arguments();
+  x = alloc_object(t_structure);
+  name=base[0];
+  COERCE_DEF(name);
+  if (type_of(name)!=t_structure  ||
+      (def=S_DATA(name))->length != --narg)
+    FEerror("Bad make_structure args for type ~a",1,
+	    base[0]);
+  x->str.str_def = name;
+  x->str.str_self = NULL;
+  size=S_DATA(name)->size;
+  base[0] = x;
+  x->str.str_self = (object *)
+    (def->staticp == Cnil ? alloc_relblock(size)
+     : alloc_contblock(size));
+  /* There may be holes in the structure.
+     We want them zero, so that equal can work better.
+     */
+  if (S_DATA(name)->has_holes != Cnil)
+    bzero(x->str.str_self,size);
+  {unsigned char *s_type;
+   unsigned short *s_pos;
+   s_pos= (&SLOT_POS(x->str.str_def,0));
+   s_type = (&(SLOT_TYPE(x->str.str_def,0)));
+   base=base+1;
+   for (i = 0;  i < narg;  i++)
+     {object v=base[i];
+      switch(s_type[i]){
+	     
+      case aet_object: STREF(object,x,s_pos[i])=v; break;
+      case aet_fix:  (STREF(int,x,s_pos[i]))=fix(v); break;
+      case aet_ch:  STREF(char,x,s_pos[i])=char_code(v); break;
+      case aet_bit:
+      case aet_char: STREF(char,x,s_pos[i])=fix(v); break;
+      case aet_sf: STREF(shortfloat,x,s_pos[i])=sf(v); break;
+      case aet_lf: STREF(longfloat,x,s_pos[i])=lf(v); break;
+      case aet_uchar: STREF(unsigned char,x,s_pos[i])=fix(v); break;
+      case aet_ushort: STREF(unsigned short,x,s_pos[i])=fix(v); break;
+      case aet_short: STREF(short,x,s_pos[i])=fix(v); break;
+      default:
+	bad_raw_type();
+
+@s]
+
+
+****Change:(orig (87 97 c))
+@s[       if ((narg = vs_top - vs_base) == 0)
+		too_few_arguments();
+	x = alloc_object(t_structure);
+	x->str.str_name = vs_base[0];
+
+@s,               x->str.str_self[i] = vs_top[i];
+
+@s|      }}
+   vs_top = base;
+   vs_base=base-1;
+
+ }
+
+@s]
+
+
+****Change:(orig (99 99 a))
+@s[}
+
+
+@s|}
+
+void
+
+@s]
+
+
+****Change:(orig (103 103 c))
+@s[       object x, y;
+	int i, j;
+
+@s|       object x, y;
+	struct s_data *def;
+
+@s]
+
+
+****Change:(orig (105 105 c))
+@s[
+	check_arg(2);
+
+@s|
+	if (vs_top-vs_base < 1) too_few_arguments();
+
+@s]
+
+
+****Change:(orig (107 110 c))
+@s[       if (type_of(x) != t_structure || x->str.str_name != vs_base[1])
+		FEwrong_type_argument(vs_base[1], x);
+	vs_base[1] = y = alloc_object(t_structure);
+	y->str.str_name = x->str.str_name;
+
+@s|       check_type_structure(x);
+	vs_base[0] = y = alloc_object(t_structure);
+	def=S_DATA(y->str.str_def = x->str.str_def);
+
+@s]
+
+
+****Change:(orig (112 116 c))
+@s[       y->str.str_length = j = x->str.str_length;
+	y->str.str_self = (object *)alloc_relblock(sizeof(object)*j);
+	for (i = 0;  i < j;  i++)
+		y->str.str_self[i] = x->str.str_self[i];
+
+@s,       vs_base++;
+
+@s|       y->str.str_self = (object *)alloc_relblock(def->size);
+	bcopy(x->str.str_self,y->str.str_self,def->size);
+	vs_top=vs_base+1;
+
+@s]
+
+
+****Change:(orig (118 118 a))
+@s[}
+
+
+@s|}
+
+void
+siLcopy_structure_header()
+{
+	object x, y;
+
+	if (vs_top-vs_base < 1) too_few_arguments();
+	x = vs_base[0];
+	check_type_structure(x);
+	vs_base[0] = y = alloc_object(t_structure);
+	y->str.str_def = x->str.str_def;
+	y->str.str_self = x->str.str_self;
+	vs_top=vs_base+1;
+}
+
+
+void
+
+@s]
+
+
+****Change:(orig (122 124 c))
+@s[       if (type_of(vs_base[0]) != t_structure)
+		FEwrong_type_argument(Sstructure, vs_base[0]);
+	vs_base[0] = vs_base[0]->str.str_name;
+
+@s|       check_type_structure(vs_base[0]);
+	vs_base[0] = S_DATA(vs_base[0]->str.str_def)->name;
+
+@s]
+
+
+****Change:(orig (127 127 c))
+@s[}
+
+siLstructure_ref()
+
+@s|}
+
+#define FIND_SLOT(str,name) ((type_of(name)==t_fixnum)?fix(name): \
+		             structure_slot_position(str,name))
+
+object
+structure_ref_new(x, name, i)
+     object x,name,i;
+
+@s]
+
+
+****Change:(orig (129 131 c))
+@s[       object x;
+	int i;
+	check_arg(3);
+
+@s|  return structure_ref(x,name,FIND_SLOT(x,i));
+}
+
+@s]
+
+
+****Change:(orig (133 144 c))
+@s[       x = vs_base[0];
+	if (type_of(x) != t_structure ||
+	    !structure_subtypep(x->str.str_name, vs_base[1]))
+		FEwrong_type_argument(vs_base[1], x);
+
+@s,       vs_base[0] = x->str.str_self[i];
+	vs_top = vs_base+1;
+
+@s|object
+structure_set_new(x, name, i, v)
+     object x,name,i,v;
+{
+  return structure_set(x,name,FIND_SLOT(x,i),v);
+
+@s]
+
+
+****Change:(orig (146 146 a))
+@s[}
+
+
+@s|}
+
+void
+siLstructure_ref()
+{
+  check_arg(3);
+  vs_base[0]=structure_ref_new(vs_base[0],vs_base[1],vs_base[2]);
+  vs_top=vs_base+1;
+}
+
+void
+
+@s]
+
+
+****Change:(orig (149 150 d))
+@s[siLstructure_set()
+{
+	object x;
+	int i;
+
+@s|siLstructure_set()
+{
+
+@s]
+
+
+****Change:(orig (152 163 c))
+@s[
+	x = vs_base[0];
+	if (type_of(x) != t_structure ||
+	    !structure_subtypep(x->str.str_name, vs_base[1]))
+
+@s,       x->str.str_self[i] = vs_base[3];
+
+@s|       structure_set_new(vs_base[0],vs_base[1],vs_base[2],vs_base[3]);
+
+@s]
+
+
+****Change:(orig (166 166 a))
+@s[       vs_base = vs_top-1;
+}
+
+
+@s|       vs_base = vs_top-1;
+}
+
+void
+
+@s]
+
+
+****Change:(orig (228 228 c))
+@s[init_structure_function()
+
+@s|void
+siLmake_s_data_structure()
+{object x,y,raw,*base;
+ int i;
+ check_arg(5);
+ x=vs_base[0];
+ base=vs_base;
+ raw=vs_base[1];
+ y=alloc_object(t_structure);
+ y->str.str_def=y;
+ y->str.str_self = (object *)( x->v.v_self);
+ S_DATA(y)->name  =siLs_data;
+ S_DATA(y)->length=(raw->v.v_dim);
+ S_DATA(y)->raw   =raw;
+ for(i=3; i<raw->v.v_dim; i++)
+   y->str.str_self[i]=Cnil;
+ S_DATA(y)->slot_position=base[2];
+ S_DATA(y)->slot_descriptions=base[3];
+ S_DATA(y)->staticp=base[4];
+ S_DATA(y)->size = (raw->v.v_dim)*sizeof(object);
+ vs_base[0]=y;
+ vs_top=vs_base+1;
+}
+
+object siSstructure_init,siSstructure_init_named;
+object siSname,siSdefault_init;
+object siSraw,siSslot_position,siSsize,siSstaticp,siSslot_descriptions;
+
+static object
+slot_value(str,name)
+     object str,name;
+
+@s]
+
+
+****Change:(orig (230 237 c))
+@s[       siSstructure_print_function
+	= make_si_ordinary("STRUCTURE-PRINT-FUNCTION");
+	enter_mark_origin(&siSstructure_print_function);
+	siSstructure_slot_descriptions
+
+@s,       enter_mark_origin(&siSstructure_include);
+
+@s| top:
+  if(type_of(str)==t_structure)
+    return structure_ref_new(str,str->str.str_def,name);
+  if(str->c.c_car==siSstructure_init_named)
+    {object new=get(str->c.c_cdr,siLs_data);
+     str->c.c_car=siSstructure_init;
+     str->c.c_cdr=(type_of(new)==t_structure)?new:cdr(new);}
+  if(siSstructure_init!=car(str))
+    FEerror("Illegal call to SI:MAKE-STRUCTURES 1",0);
+  {object key=intern(coerce_to_string(name),keyword_package);
+   object value=getf(cdddr(str),key,NULL);
+   if(value!=NULL)
+     return value;
+   else
+     {object slots;
+      if(str==caddr(str)&&name==siSslot_descriptions)
+	FEerror("Illegal call to SI:MAKE-STRUCTURES 2",0);
+      slots=slot_value(caddr(str),siSslot_descriptions);
+      for(;!endp(slots);slots=cdr(slots))
+	if(name==slot_value(car(slots),siSname))
+	  {object result,form=slot_value(car(slots),siSdefault_init);
+	   object *old_vs_base=vs_base,*old_vs_top=vs_top;
+	   vs_base=vs_top;vs_push(form);Leval();result=vs_base[0];
+	   vs_base=old_vs_base; vs_top=old_vs_top;
+	   return result;}
+      FEerror("Illegal call to SI:MAKE-STRUCTURES 3",0);}}
+  return Cnil;
+}
+
+@s]
+
+
+****Change:(orig (238 238 a))
+@s[
+
+@s|
+int 
+structure_slot_position(str,name)
+     object str,name;
+{
+  if(type_of(name)==t_fixnum)
+    return fix(name);
+  else
+    {object slotd_list;
+     int pos;
+     check_type_structure(str);
+     slotd_list=S_DATA(str->str.str_def)->slot_descriptions;
+     for(pos=0; type_of(slotd_list)==t_cons; pos++,slotd_list=cdr(slotd_list))
+       {object slotd=car(slotd_list);
+	if(name==((type_of(slotd)==t_structure)?
+		  slotd->str.str_self[0]:slot_value(slotd,siSname)))
+	  return pos;}
+     FEerror("Slot ~S not found in structure ~S",2,name,str);
+     return 0;}  
+}
+
+static object
+make_structures_internal(value)
+     object value;
+{
+  object str,def;
+  int def_index,i,ind;
+
+  switch(type_of(value))
+    {case t_cons:
+       if(value->c.c_car==siSstructure_init_named)
+	 {object new=get(value->c.c_cdr,siLs_data);
+	  value->c.c_car=siSstructure_init;
+	  value->c.c_cdr=(type_of(new)==t_structure)?new:cdr(new);}
+       if(car(value)!=siSstructure_init)
+	 {value->c.c_car=make_structures_internal(value->c.c_car);
+	  value->c.c_cdr=make_structures_internal(value->c.c_cdr);
+	  break;}
+       if(type_of(cadr(value))==t_structure)
+	 {value=value->c.c_cdr->c.c_car;
+	  break;}
+       {object def=caddr(value),plist=cdddr(value),result;
+	object slots,slots_tail;
+	int size,staticp,len,i;
+	if(def!=value)def=make_structures_internal(def);
+	result=alloc_object(t_structure);
+	result->str.str_def=(def==value)?result:def;
+	result->str.str_self=NULL;
+	value->c.c_cdr->c.c_car=result;
+	size=fixint(slot_value(def,siSsize));
+	staticp=Cnil!=slot_value(def,siSstaticp);
+	slots=slot_value(def,siSslot_descriptions);
+	len=length(slots);
+	result->str.str_self=(object *)(staticp?alloc_contblock(size):
+		                                alloc_relblock(size));
+	bzero(result->str.str_self,size);
+	if(def==value)
+	  {S_DATA(result)->raw=slot_value(def,siSraw);
+	   S_DATA(result)->slot_position=slot_value(def,siSslot_position);}
+	for(i=0,slots_tail=slots; i<len; i++,slots_tail=cdr(slots_tail))
+	  {object svalue=slot_value(value,slot_value(car(slots_tail),siSname));
+	   structure_set(result,result->str.str_def,i,svalue);}
+	for(i=0,slots_tail=slots; i<len; i++,slots_tail=cdr(slots_tail))
+	  {object svalue=structure_ref(result,result->str.str_def,i);
+	   svalue=make_structures_internal(svalue);
+	   structure_set(result,result->str.str_def,i,svalue);}
+	value=result;
+	break;}
+     case t_vector:
+       if ((enum aelttype)value->v.v_elttype == aet_object)
+	 {int i,len=value->v.v_dim;
+	  for(i=0; i<len; i++)
+	    value->v.v_self[i]=make_structures_internal(value->v.v_self[i]);}
+       break;
+     case t_symbol:
+       {object plist=value->s.s_plist,next;
+	for(;!endp(plist);plist=cddr(plist))
+	  {next=plist->c.c_cdr;
+	   if(plist->c.c_car==siLs_data&&
+	      type_of(next->c.c_car)==t_cons)
+	     next->c.c_car=make_structures_internal(next->c.c_car);}
+	break;}}
+  return value;   
+}
+
+void
+siLmake_structures()
+{
+  check_arg(1);
+  vs_base[0]=make_structures_internal(vs_base[0]);
+}
+
+void
+siLstructure_def()
+{check_arg(1);
+ check_type_structure(vs_base[0]);
+  vs_base[0]=vs_base[0]->str.str_def;
+}
+
+short aet_sizes [] = {
+sizeof(object),  /* aet_object  t  */
+sizeof(char),  /* aet_ch  string-char  */
+sizeof(char),  /* aet_bit  bit  */
+sizeof(fixnum),  /* aet_fix  fixnum  */
+sizeof(float),  /* aet_sf  short-float  */
+sizeof(double),  /* aet_lf  long-float  */
+sizeof(char),  /* aet_char  signed char */
+sizeof(char),  /* aet_uchar  unsigned char */
+sizeof(short),  /* aet_short  signed short */
+sizeof(short)  /* aet_ushort  unsigned short   */
+};
+
+  
+
+
+
+void
+siLsize_of() 
+{ object x= vs_base[0];
+  int i;
+  i= aet_sizes[get_aelttype(x)];
+  vs_base[0]=make_fixnum(i);
+}
+  
+void
+siLaet_type()
+{vs_base[0]=make_fixnum(get_aelttype(vs_base[0]));}
+
+
+/* Return N such that something of type ARG can be aligned on
+   an address which is a multiple of N */
+
+
+void
+siLalignment()
+{struct {double x; int y; double z;
+	 float x1; int y1; float z1;}
+ joe;
+ joe.z=3.0;
+ 
+ if (vs_base[0]==Slong_float)
+   {vs_base[0]=make_fixnum((int)&joe.z- (int)&joe.y); return;}
+ else
+   if (vs_base[0]==Sshort_float)
+     {vs_base[0]=make_fixnum((int)&(joe.z1)-(int)&(joe.y1)); return;}
+   else
+     {siLsize_of();}
+}
+   
+void
+swap_structure_contents(str1,str2)
+   object str1,str2;
+{
+  object def1,*self1;
+  check_type_structure(str1);
+  check_type_structure(str2);
+  def1=str1->str.str_def;
+  self1=str1->str.str_self;
+  str1->str.str_def=str2->str.str_def;
+  str1->str.str_self=str2->str.str_self;
+  str2->str.str_def=def1;
+  str2->str.str_self=self1;
+}
+
+void
+siLswap_structure_contents()
+{
+  check_arg(2);
+  swap_structure_contents(vs_base[0],vs_base[1]);
+  vs_base[0]=Cnil;
+  vs_top=vs_base+1;
+}
+
+void
+siLset_structure_def()
+{check_arg(2);
+ check_type_structure(vs_base[0]);
+ check_type_structure(vs_base[1]);
+ vs_base[0]->str.str_def=vs_base[1];
+ vs_base[0]=vs_base[1];
+ vs_top=vs_base+1;
+}
+
+init_structure_function()
+{
+        siLs_data=make_si_ordinary("S-DATA");
+	siSstructure_init=make_si_ordinary("STRUCTURE-INIT");
+	siSstructure_init_named=make_si_ordinary("STRUCTURE-INIT-NAMED");
+	siSname=make_si_ordinary("NAME");
+	siSdefault_init=make_si_ordinary("DEFAULT-INIT");
+	siSraw=make_si_ordinary("RAW");
+	siSslot_position=make_si_ordinary("SLOT-POSITION");
+	siSsize=make_si_ordinary("SIZE");
+	siSstaticp=make_si_ordinary("STATICP");
+	siSslot_descriptions=make_si_ordinary("SLOT-DESCRIPTIONS");
+
+@s]
+
+
+****Change:(orig (239 239 a))
+@s[       make_si_function("MAKE-STRUCTURE", siLmake_structure);
+
+@s|       make_si_function("MAKE-STRUCTURE", siLmake_structure);
+	make_si_function("MAKE-S-DATA-STRUCTURE",siLmake_s_data_structure);
+
+@s]
+
+
+****Change:(orig (240 240 a))
+@s[       make_si_function("COPY-STRUCTURE", siLcopy_structure);
+
+@s|       make_si_function("COPY-STRUCTURE", siLcopy_structure);
+	make_si_function("COPY-STRUCTURE-HEADER", siLcopy_structure_header);
+
+@s]
+
+
+****Change:(orig (242 242 a))
+@s[       make_si_function("STRUCTURE-REF", siLstructure_ref);
+
+@s|       make_si_function("STRUCTURE-REF", siLstructure_ref);
+	make_si_function("STRUCTURE-DEF", siLstructure_def);
+	make_si_function("STRUCTURE-REF1", siLstructure_ref1);
+	make_si_function("STRUCTURE-SET1", siLstructure_set1);
+
+@s]
+
+
+****Change:(orig (245 245 c))
+@s[       make_si_function("STRUCTUREP", siLstructurep);
+
+
+@s|       make_si_function("STRUCTUREP", siLstructurep);
+	make_si_function("SIZE-OF", siLsize_of);
+	make_si_function("ALIGNMENT",siLalignment);
+	make_si_function("STRUCTURE-SUBTYPE-P",siLstructure_subtype_p);
+
+@s]
+
+
+****Change:(orig (247 247 a))
+@s[       make_si_function("LIST-NTH", siLlist_nth);
+
+@s|       make_si_function("LIST-NTH", siLlist_nth);
+	make_si_function("AET-TYPE",siLaet_type);
+	make_si_function("SWAP-STRUCTURE-CONTENTS",siLswap_structure_contents);
+	make_si_function("SET-STRUCTURE-DEF", siLset_structure_def);
+	make_si_function("MAKE-STRUCTURES", siLmake_structures);
+
+
+@s]
+
+==============================================================================
+============================== V/lsp/defstruct.lsp =============================
+Changes file for /kcl/lsp/defstruct.lsp
+Usage \n@s[Original text\n@s|Replacement Text\n@s]
+See the file rascal.ics.utexas.edu:/usr2/ftp/merge.c
+for a program to merge change files.  Anything not between
+ "\n@s[" and  "\n@s]" is a simply a comment.
+This file was constructed using emacs and  merge.el
+ by (Bill Schelter)  wfs@carl.ma.utexas.edu 
+
+
+****Change:(orig (20 71 c))
+@s[(defun make-access-function (name conc-name type named
+                             slot-name default-init slot-type read-only
+                             offset)
+  (declare (ignore named default-init slot-type))
+
+@s,          ((error "~S is an illegal structure type." type)))))
+
+@s|(defvar *accessors* (make-array 10 :adjustable t))
+(defvar *list-accessors* (make-array 2 :adjustable t))
+(defvar *vector-accessors* (make-array 2 :adjustable t))
+
+@s]
+
+
+****Change:(orig (72 72 a))
+@s[
+
+@s|
+(or (fboundp 'record-fn) (setf (symbol-function 'record-fn)
+		               #'(lambda (&rest l) l nil)))
+
+@s]
+
+
+****Change:(orig (73 73 a))
+@s[
+
+@s|
+(defun boot-slot-value (str name)
+  (if (structurep str)
+      (structure-ref str (structure-def str) name)
+      (getf (cdddr str) (intern (string name) :keyword))))
+
+(defun boot-set-slot-value (str name new-value)
+  (if (structurep str)
+      (structure-set str (structure-def str) name new-value)
+      (setf (getf (cdddr str) (intern (string name) :keyword)) new-value)))
+
+(defun boot-subtypep (type1 type2)
+  (or (eq type1 type2)
+      (let* ((s-data (get type1 's-data))
+	     (include (boot-s-data-name (boot-slot-value s-data 'includes))))
+	(boot-subtypep include type2))))
+
+(defun make-slot-boot (&rest args)
+  (if (get 's-data 's-data)
+      (apply #'make-slot args)
+      (list* 'structure-init
+	     nil
+	     '(structure-init-named . slot)
+	     args)))
+
+(defun make-s-data-boot (&rest args)
+  (if (get 's-data 's-data)
+      (apply #'make-s-data args)
+      (list* 'structure-init
+	     nil
+	     '(structure-init-named . s-data)
+	     args)))
+
+(defun make-boot-accessor (slot accessor)
+  (setf (symbol-function accessor) 
+	#'(lambda (object)
+	    (boot-slot-value object slot)))
+  (let ((writer (intern (format nil "SET ~A" accessor))))
+    (setf (symbol-function writer)
+	  #'(lambda (object value)
+	      (boot-set-slot-value object slot value)))
+    (eval `(defsetf ,accessor ,writer))))
+
+(defmacro defstructboot (name &rest slots)
+  (let ((conc-name (if (listp name)
+		       (string (second (assoc :conc-name (cdr name))))
+		       (format nil "~A-" name))))
+    `(progn
+       ,@(mapcar #'(lambda (slot)
+		     (let ((fname (intern (format nil "~A~A" conc-name slot))))
+		       `(make-boot-accessor ',slot ',fname)))
+	         slots))))
+
+(defstructboot (slot (:conc-name boot-slot-))
+  name default-init type read-only offset accessor-name type-changed)
+
+(defstructboot (s-data-internal (:conc-name boot-s-data-))
+  name length raw included includes staticp print-function
+  slot-descriptions slot-position size has-holes)
+
+(defstructboot (basic-wrapper (:conc-name boot-wrapper-))
+  cache-number-vector state class)
+
+(defstructboot (s-data (:conc-name boot-s-data-))
+  frozen documentation constructors offset
+  named type conc-name)
+
+(defun make-access-function (name conc-name type named include no-fun slot)
+  (declare (ignore named))
+  
+  (let* ((slot-name (boot-slot-name slot))
+	 (slot-type (boot-slot-type slot))
+	 (read-only (boot-slot-read-only slot))
+	 (offset (boot-slot-offset slot))
+	 (access-function
+	  (intern (si:string-concatenate (string conc-name)
+		                         (string slot-name))))
+	accsrs dont-overwrite)
+    (unless (boot-slot-accessor-name slot)
+      (setf (boot-slot-accessor-name slot) access-function))
+    (ecase type
+      ((nil)
+       (setf accsrs *accessors*))
+      (list
+	(setf accsrs *list-accessors*))
+      (vector
+	(setf accsrs *vector-accessors*)))
+    (or (> (length  accsrs) offset)
+	(adjust-array accsrs (+ offset 10)))
+    (unless
+     dont-overwrite
+     (record-fn access-function 'defun '(t) slot-type)
+     (or no-fun
+	 (and (fboundp access-function)
+	      (eq (aref accsrs offset) (symbol-function access-function)))
+	 (setf (symbol-function access-function)
+	   (or (aref accsrs offset)
+	       (setf (aref accsrs offset)
+		     (cond  ((eq accsrs *accessors*)
+		                #'(lambda (x)
+		                    (or (structurep x)
+		                        (error "~a is not a structure" x))
+		                    (structure-ref1 x offset)))
+		               ((eq accsrs *list-accessors*)
+		                #'(lambda(x)
+		                    (si:list-nth offset x)))
+		               ((eq accsrs *vector-accessors*)
+		                #'(lambda(x)
+		                    (aref x offset)))))))))
+    (cond (read-only
+	    (remprop access-function 'structure-access)
+	    (setf (get access-function 'struct-read-only) t))
+	  (t (remprop access-function 'setf-update-fn)
+	     (remprop access-function 'setf-lambda)
+	     (remprop access-function 'setf-documentation)
+	     (let ((tem (get access-function 'structure-access)))
+	       (cond ((and (consp tem) include
+		           (if (consp (get include 's-data))
+		               (boot-subtypep include (car tem))
+		               (subtypep include (car tem)))
+		           (eql (cdr tem) offset))
+		      ;; don't change overwrite accessor of subtype.
+		      (setq dont-overwrite t)
+		      )
+		     (t  (setf (get access-function 'structure-access)
+		               (cons (if type type name) offset)))))))
+    nil))
+
+
+@s]
+
+
+****Change:(orig (80 89 c))
+@s[                     (cond ((null x)
+                            ;; If the slot-description is NIL,
+                            ;;  it is in the padding of initial-offset.
+                            nil)
+
+@s,                           (t (car x))))
+
+@s|                    (or (boot-slot-name x)
+		         (and (boot-slot-default-init x)
+		              ;; If the slot name is NIL,
+		              ;;  it is the structure name.
+		              ;;  This is for typed structures with names.
+		              (list 'quote (boot-slot-default-init x)))))
+
+@s]
+
+
+****Change:(orig (94 97 c))
+@s[                     (cond ((null x) nil)
+                           ((null (car x)) nil)
+                           ((null (cadr x)) (list (car x)))
+                           (t (list (list  (car x) (cadr x))))))
+
+@s|                    (when (boot-slot-name x)
+		       (if (boot-slot-default-init x)
+		           (list (list (boot-slot-name x) (boot-slot-default-init x)))
+		           (list (boot-slot-name x)))))
+
+@s]
+
+
+****Change:(orig (248 248 d))
+@s[          ((error "~S is an illegal structure type" type)))))
+
+
+
+@s|          ((error "~S is an illegal structure type" type)))))
+
+
+@s]
+
+
+****Change:(orig (252 265 d))
+@s[
+(defun make-copier (name copier type named)
+  (declare (ignore named))
+  (cond ((null type)
+
+@s,        ((error "~S is an illegal structure type." type))))
+
+
+
+@s|
+@s]
+
+
+****Change:(orig (267 275 c))
+@s[  (cond ((null type)
+         ;; If TYPE is NIL, the predicate searches the link
+         ;;  of structure-include, until there is no included structure.
+         `(defun ,predicate (x)
+
+@s,                   (setq n (get n 'structure-include))))))
+
+@s|  (cond ((null type))
+	 ; done in define-structure
+
+@s]
+
+
+****Change:(orig (282 283 c))
+@s[                 (> (length x) ,name-offset)
+                 (eq (elt x ,name-offset) ',name))))
+
+@s|                 (> (the fixnum (length x)) ,name-offset)
+                 (eq (aref (the (vector t) x) ,name-offset) ',name))))
+
+@s]
+
+
+****Change:(orig (294 294 a))
+@s[                         ((= i 0) (and (consp y) (eq (car y) ',name)))
+
+@s|                         ((= i 0) (and (consp y) (eq (car y) ',name)))
+		         (declare (fixnum i))
+
+@s]
+
+
+****Change:(orig (300 301 c))
+@s[;;;  and returns a list of the form:
+;;;        (slot-name default-init slot-type read-only offset)
+
+@s|;;;  and returns a slot.
+
+@s]
+
+
+****Change:(orig (325 325 c))
+@s[    (list slot-name default-init slot-type read-only offset)))
+
+@s|    (make-slot-boot :name slot-name
+		    :default-init default-init
+		    :type slot-type
+		    :read-only read-only
+		    :offset offset)))
+
+@s]
+
+
+****Change:(orig (335 335 c))
+@s[      (let ((sds (member (caar olds) news :key #'car)))
+
+@s|      (let* ((old (car olds))
+	     (sds (member (boot-slot-name old) news :key #'slot-name))
+	     (new (car sds)))
+
+@s]
+
+
+****Change:(orig (337 348 c))
+@s[               (when (and (null (cadddr (car sds)))
+                          (cadddr (car olds)))
+                     ;; If read-only is true in the old
+                     ;;  and false in the new, signal an error.
+
+@s,                           (car (cddddr (car olds))))
+
+@s|               (when (and (null (boot-slot-read-only new))
+                          (boot-slot-read-only old))
+		 ;; If read-only is true in the old
+		 ;;  and false in the new, signal an error.
+		 (error "~S is an illegal include slot-description."
+		        new))
+	       ;; If
+	       (setf (boot-slot-type new)
+		     (best-array-element-type (boot-slot-type new)))
+	       (when (not (equal (normalize-type (or (boot-slot-type new) t))
+		                 (normalize-type (or (boot-slot-type old) t))))
+		 (error "Type mismmatch for included slot ~a" new))
+	       (cons (make-slot :name (boot-slot-name new)
+		                :default-init (boot-slot-default-init new)
+		                :type (boot-slot-type new)
+		                :read-only (boot-slot-read-only new)
+		                :offset (boot-slot-offset old))
+
+@s]
+
+
+****Change:(orig (353 353 a))
+@s[                     (overwrite-slot-descriptions news (cdr olds))))))))
+
+
+@s|                     (overwrite-slot-descriptions news (cdr olds))))))))
+
+(defvar *all-t-s-type* (make-array 50 :element-type 'unsigned-char :static t))
+
+@s]
+
+
+****Change:(orig (355 355 c))
+@s[;;; The DEFSTRUCT macro.
+
+@s|(defun make-t-type (n include slot-descriptions &aux i)
+  (let ((res  (make-array n :element-type 'unsigned-char :static t)))
+    (when include
+      (let ((tem (get include 's-data))raw)
+	(or tem (error "Included structure undefined ~a" include))
+	(setq raw (boot-s-data-raw tem))
+	(dotimes (i (min n (length raw)))
+	  (setf (aref res i) (aref raw i)))))
+    (dolist (v slot-descriptions)
+      (setq i (boot-slot-offset v))
+      (let ((type (boot-slot-type v)))
+	(cond ((<= (the fixnum (alignment type)) #. (alignment t))
+	       (setf (aref res i) (aet-type type))))))
+    (cond ((< n (length *all-t-s-type*))
+	   (dotimes (i n)
+	     (cond ((not (eql (the fixnum (aref res i)) 0))
+		    (return-from make-t-type res))))
+	   *all-t-s-type*)
+	  (t res))))
+
+@s]
+
+
+****Change:(orig (356 356 a))
+@s[
+
+@s|
+(defvar *standard-slot-positions*
+  (let ((ar (make-array 50 :element-type 'unsigned-short
+		        :static t))) 
+    (dotimes (i 50)
+	     (declare (fixnum i))
+	     (setf (aref ar i)(* #. (size-of t) i)))
+    ar))
+
+(eval-when (compile )
+(proclaim '(function round-up (fixnum fixnum ) fixnum))
+)
+
+(defun round-up (a b)
+  (declare (fixnum a b))
+  (setq a (ceiling a b))
+  (the fixnum (* a b)))
+
+
+(defun get-slot-pos (leng include slot-descriptions &aux type small-types
+		          has-holes) 
+  (declare (special *standard-slot-positions*)) include
+  (dolist (v slot-descriptions)
+    (when (boot-slot-name v)
+      (setf type (best-array-element-type (boot-slot-type v))
+	    (boot-slot-type v) type)
+      (let ((val (boot-slot-default-init v)))
+	(unless (typep val type)
+	  (if (and (symbolp val)
+		   (constantp val))
+	      (setf val (symbol-value val)))
+	  (and (constantp val)
+	       (setf (boot-slot-default-init v) (coerce val type)))))
+      (cond ((memq type '(signed-char unsigned-char
+		          short unsigned-short
+		          long-float
+		          bit))
+	     (setq small-types t)))))
+  (cond ((and (null small-types)
+	      (< leng (length *standard-slot-positions*))
+	      (list  *standard-slot-positions* (* leng #. (size-of t)) nil)))
+	(t (let ((ar (make-array leng :element-type 'unsigned-short
+		                 :static t))
+		 (pos 0)(i 0)(align 0)type (next-pos 0))
+	     (declare (fixnum pos i align next-pos))
+	     ;; A default array.
+		   
+	     (dolist (v slot-descriptions)
+	       (setq type (boot-slot-type v))
+	       (setq align (alignment type))
+	       (unless (<= align #. (alignment t))
+		 (setq type t)
+		 (setf (boot-slot-type v) t)
+		 (setq align #. (alignment t))
+		 (setf (boot-slot-type-changed v) t))
+	       (setq next-pos (round-up pos align))      
+	       (or (eql pos next-pos) (setq has-holes t))
+	       (setq pos next-pos)
+	       (setf (aref ar i) pos)
+	       (incf pos (size-of type))
+	       (incf i))
+	     (list ar (round-up pos (size-of t)) has-holes)
+	     ))))
+
+
+(defun define-structure (name conc-name type named slot-descriptions copier
+		              static include print-function constructors
+		              offset predicate &optional documentation no-funs
+		              &aux leng)
+  (and (consp type) (eq (car type) 'vector)(setq type 'vector))
+  (setq leng (length slot-descriptions))
+  (setq slot-descriptions 
+	(mapcar #'(lambda (info)
+		    (make-slot-boot :name (first info)
+		                    :default-init (second info)
+		                    :type (third info)
+		                    :read-only (fourth info)
+		                    :offset (fifth info)
+		                    :accessor-name (sixth info)
+		                    :type-changed (seventh info)))
+		slot-descriptions))
+  (dolist (x slot-descriptions)
+    (when (boot-slot-name x)
+      (make-access-function name conc-name type named include no-funs x)))
+  (when (and copier (not no-funs))
+    (setf (symbol-function copier)
+	  (ecase type
+	    ((nil) #'si::copy-structure)
+	    (list #'copy-list)
+	    (vector #'copy-seq))))
+  (let ((include-str (and include (get include 's-data))))
+    (when (and (eq include 's-data-internal)
+	       (not (eq name 'basic-wrapper)))
+      (error "only ~s can include ~s" 'basic-wrapper 's-data-internal))
+    (when include-str
+      (cond ((and (not (consp include-str))
+		  (s-data-frozen include-str)
+		  (or (not (s-data-included include-str))
+		      (not (let ((te (get name 's-data)))
+		             (and te
+		                  (eq (s-data-includes te)
+		                      include-str))))))
+	     (warn " ~a was frozen but now included"
+		   include)))
+      (let ((old-included (boot-slot-value include-str 'included)))
+	(unless (member name old-included)
+	  (boot-set-slot-value include-str 'included (cons name old-included)))))
+    (let* ((tem (get name 's-data))
+	   (g-s-p (and (null type)
+		       (get-slot-pos leng include slot-descriptions)))
+	   (slot-position (car g-s-p))
+	   (size (if g-s-p (cadr g-s-p) 0))
+	   (has-holes (caddr g-s-p))
+	   (def (make-s-data-boot :name name
+		                  :length leng
+		                  :raw
+		                  (and (null type)
+		                       (make-t-type leng include 
+		                                    slot-descriptions))
+		                  :slot-position slot-position
+		                  :size size
+		                  :has-holes has-holes
+		                  :staticp static
+		                  :includes include-str
+		                  :print-function print-function
+		                  :slot-descriptions slot-descriptions
+		                  :constructors constructors
+		                  :offset offset
+		                  :type type
+		                  :named named
+		                  :documentation documentation
+		                  :conc-name conc-name)))
+      (check-s-data tem def name)
+      (when (and (consp def) (eq name 's-data))
+	(make-structures def))))
+  (when documentation
+    (setf (get name 'structure-documentation)
+	  documentation))
+  (when (and  (null type)  predicate)
+    (record-fn predicate 'defun '(t) t)
+    (or no-funs
+	(setf (symbol-function predicate)
+	      #'(lambda (x)
+		  (si::structure-subtype-p x name))))
+    (setf (get predicate 'compiler::co1)
+	  'compiler::co1structure-predicate)
+    (setf (get predicate 'struct-predicate) name))
+  nil)
+
+(defun check-s-data (old new name)
+  (unless (and old (member name '(slot s-data-internal basic-wrapper s-data)))
+    (when (and old (eq (structure-def old) (get 's-data 's-data)))
+      (boot-set-slot-value new 'included (boot-slot-value old 'included))
+      (boot-set-slot-value new 'frozen (boot-slot-value old 'frozen)))
+    (unless (and old
+		 (eq (structure-def old) (get 's-data 's-data))
+		 (let ((new-cnv (boot-slot-value new 'cache-number-vector))
+		       (old-cnv (boot-slot-value old 'cache-number-vector)))
+		   (boot-set-slot-value new 'cache-number-vector old-cnv)
+		   (prog1 (equalp new old)
+		     (boot-set-slot-value new 'cache-number-vector new-cnv))))
+      (when old
+	(warn "structure ~a is changing" name)
+	(when (eq (structure-def old) (get 's-data 's-data))
+	  (boot-set-slot-value old 'state (list ':obsolete new))))
+      (setf (get name 's-data) new))))
+
+
+@s]
+
+
+****Change:(orig (364 364 c))
+@s[        predicate predicate-specified
+        include
+
+@s|        predicate predicate-specified
+        include include-s-data
+
+@s]
+
+
+****Change:(orig (367 367 c))
+@s[        offset name-offset
+        documentation)
+
+@s|        offset name-offset
+        documentation
+	static)
+
+@s]
+
+
+****Change:(orig (370 370 c))
+@s[          ;; The defstruct options are supplied.
+
+@s|         ;; The defstruct options are supplied.
+
+@s]
+
+
+****Change:(orig (390 425 c))
+@s[      (cond ((and (consp (car os)) (not (endp (cdar os))))
+             (setq o (caar os) v (cadar os))
+             (case o
+               (:conc-name
+
+@s,               (t (error "~S is an illegal defstruct option." o))))))
+
+@s|       (cond ((and (consp (car os)) (not (endp (cdar os))))
+	       (setq o (caar os) v (cadar os))
+	       (case o
+		 (:conc-name
+		   (if (null v)
+		       (setq conc-name "")
+		     (setq conc-name v)))
+		 (:constructor
+		   (if (null v)
+		       (setq no-constructor t)
+		     (if (endp (cddar os))
+		         (setq constructors (cons v constructors))
+		       (setq constructors (cons (cdar os) constructors)))))
+		 (:copier (setq copier v))
+		 (:static (setq static v))
+		 (:predicate
+		   (setq predicate v)
+		   (setq predicate-specified t))
+		 (:include
+		   (setq include (cdar os))
+		   (unless (setq include-s-data (get v 's-data))
+		           (error "~S is an illegal included structure." v)))
+		 (:print-function
+		  (and (consp v) (eq (car v) 'function)
+		       (setq v (second v)))
+		  (setq print-function v))
+		 (:type (setq type v))
+		 (:initial-offset (setq initial-offset v))
+		 (t (error "~S is an illegal defstruct option." o))))
+	      (t
+		(if (consp (car os))
+		    (setq o (caar os))
+		  (setq o (car os)))
+		(case o
+		  (:constructor
+		    (setq constructors
+		          (cons default-constructor constructors)))
+		  ((:conc-name :copier :predicate :print-function))
+		  (:named (setq named t))
+		  (t (error "~S is an illegal defstruct option." o))))))
+
+@s]
+
+
+****Change:(orig (426 426 a))
+@s[
+
+@s|
+    (setq conc-name (intern (string conc-name)))
+
+    (and include-s-data (not print-function)
+	 (setq print-function (boot-s-data-print-function include-s-data)))
+
+
+@s]
+
+
+****Change:(orig (434 435 c))
+@s[    (when include
+          (unless (equal type (get (car include) 'structure-type))
+
+@s|    (when include-s-data
+          (unless (equal type (boot-s-data-type include-s-data))
+
+@s]
+
+
+****Change:(orig (442 443 c))
+@s[          (t
+           (setq offset (get (car include) 'structure-offset))))
+
+@s|          (t 
+	    (setq offset (boot-s-data-offset include-s-data))))
+
+@s]
+
+
+****Change:(orig (457 458 c))
+@s[      (setq sds (cons (parse-slot-description (car ds) offset) sds))
+      (setq offset (1+ offset)))
+
+@s|       (setq sds (cons (parse-slot-description (car ds) offset) sds))
+	(setq offset (1+ offset)))
+
+@s]
+
+
+****Change:(orig (464 464 c))
+@s[                (cons (list nil name) slot-descriptions)))
+
+@s|                (cons (make-slot :default-init name) slot-descriptions)))
+
+@s]
+
+
+****Change:(orig (469 469 c))
+@s[                (append (make-list initial-offset) slot-descriptions)))
+
+@s|                (append (mapcar #'make-named-slot (make-list initial-offset))
+		        slot-descriptions)))
+
+@s]
+
+
+****Change:(orig (473 486 c))
+@s[    (cond ((null include))
+          ((endp (cdr include))
+           (setq slot-descriptions
+                 (append (get (car include) 'structure-slot-descriptions)
+
+@s,                         slot-descriptions))))
+
+@s|    (let ((include-slot-descriptions 
+	   (and include
+		(boot-s-data-slot-descriptions include-s-data))))
+      (cond ((null include))
+	    ((endp (cdr include))
+	     (setq slot-descriptions
+		   (append include-slot-descriptions
+		           slot-descriptions)))
+	    (t
+	     (setq slot-descriptions
+		   (append (overwrite-slot-descriptions
+		            (mapcar #'(lambda (sd)
+		                        (parse-slot-description sd 0))
+		                    (cdr include))
+		            include-slot-descriptions)
+		           slot-descriptions)))))
+
+@s]
+
+
+****Change:(orig (489 492 c))
+@s[           ;; If a constructor option is NIL,
+           ;;  no constructor should have been specified.
+           (when constructors
+                 (error "Contradictory constructor options.")))
+
+@s|           ;; If a constructor option is NIL,
+	    ;;  no constructor should have been specified.
+	    (when constructors
+		  (error "Contradictory constructor options.")))
+
+@s]
+
+
+****Change:(orig (494 495 c))
+@s[           ;; If no constructor is specified,
+           ;;  the default-constructor is made.
+
+@s|          ;; If no constructor is specified,
+	   ;;  the default-constructor is made.
+
+@s]
+
+
+****Change:(orig (497 497 a))
+@s[           (setq constructors (list default-constructor))))
+
+
+@s|           (setq constructors (list default-constructor))))
+
+    ;; We need a default constructor for the sharp-s-reader
+    (or (member t (mapcar 'symbolp  constructors))
+	(push (intern (string-concatenate "__si::" default-constructor))
+		      constructors))
+
+
+@s]
+
+
+****Change:(orig (509 509 c))
+@s[          (error "An print function is supplied to a typed structure."))
+
+@s|          (error "A print function is supplied to a typed structure."))
+    
+    `(progn
+       (define-structure ',name  ',conc-name ',type ',named
+		         ',(mapcar #'(lambda (slotd)
+		                       (list (boot-slot-name slotd)
+		                             (boot-slot-default-init slotd)
+		                             (boot-slot-type slotd)
+		                             (boot-slot-read-only slotd)
+		                             (boot-slot-offset slotd)
+		                             (boot-slot-accessor-name slotd)
+		                             (boot-slot-type-changed slotd)))
+		                   slot-descriptions)
+		         ',copier ',static ',include ',print-function ',constructors 
+		         ',offset ',predicate ',documentation)
+
+@s]
+
+
+****Change:(orig (511 542 c))
+@s[    `(progn (si:putprop ',name
+                        '(defstruct ,name ,@slots)
+                        'defstruct-form)
+            (si:putprop ',name t 'is-a-structure)
+
+@s,            (si:putprop ',name ,documentation 'structure-documentation)
+            ',name)))
+
+@s|       ,@(mapcar #'(lambda (constructor)
+		     (make-constructor name constructor type named
+		                       slot-descriptions))
+		 constructors)
+       ,@(if (and type predicate)
+	     (list (make-predicate name predicate type named
+		                   name-offset)))
+       ',name
+       )))
+
+@s]
+
+
+****Change:(orig (544 544 a))
+@s[
+
+
+@s|
+
+(eval-when (compile load eval)
+
+(defconstant wrapper-cache-number-adds-ok 4)
+
+(defconstant wrapper-cache-number-length
+	     (- (integer-length most-positive-fixnum)
+		wrapper-cache-number-adds-ok))
+
+(defconstant wrapper-cache-number-mask
+	     (1- (expt 2 wrapper-cache-number-length)))
+
+
+(defvar *get-wrapper-cache-number* (make-random-state))
+
+(defun get-wrapper-cache-number ()
+  (let ((n 0))
+    (declare (fixnum n))
+    (loop
+      (setq n
+	    (logand wrapper-cache-number-mask
+		    (random most-positive-fixnum *get-wrapper-cache-number*)))
+      (unless (zerop n) (return n)))))
+
+)
+
+(eval-when (compile load eval)
+
+(defconstant wrapper-cache-number-vector-length 8)
+
+(deftype cache-number-vector ()
+  `(simple-array fixnum (8)))
+
+(defconstant wrapper-layout (make-list wrapper-cache-number-vector-length
+		                       :initial-element 'number))
+
+)
+
+(defun make-wrapper-cache-number-vector ()
+  (let ((cnv (make-array #.wrapper-cache-number-vector-length
+		         :element-type 'fixnum)))
+    (dotimes (i #.wrapper-cache-number-vector-length)
+      (setf (aref cnv i) (get-wrapper-cache-number)))
+    cnv))
+
+(defstruct (slot
+	     (:static t)
+	     (:constructor make-slot)
+	     (:constructor make-named-slot (name)))
+  name
+  default-init
+  (type t)
+  read-only
+  offset
+  accessor-name
+  type-changed)
+
+;; All of the fields of s-data-internal must coincide with 
+;; the C structure s_data (see object.h).
+(defstruct (s-data-internal
+	     (:conc-name s-data-)
+	     (:constructor nil)
+	     (:static t))
+  ;; all of these slots are used by c code
+  name                    ; a symbol
+  (length 0 :type fixnum) ; length of slot-descriptions
+  raw                     ; a static array of unsigned-short (enum aelttype)
+  included                ; a list of the names of structures including this one
+  includes                ; nil or a s-data structure
+  staticp         ; t or nil
+  print-function  ; nil, a symbol, or a lambda expression
+  slot-descriptions       ; a list of slots
+  slot-position           ; a static array of unsigned-short
+  (size 0 :type fixnum) ; total size to allocate
+  has-holes)              ; t or nil
+
+(defstruct (basic-wrapper (:include s-data-internal)
+		          (:conc-name wrapper-)
+		          (:constructor nil)
+		          (:static t))
+  (cache-number-vector (make-wrapper-cache-number-vector))
+  (state t) ;  either t or a list (state-sym new-wrapper)
+  ;;           where state-sym is either :flush or :obsolete
+  (class nil))
+
+;(get name 'si::s-data) ;returns one of these:
+(defstruct (s-data (:include basic-wrapper)
+		   (:static t))
+  ;; these slots are used only from lisp
+  frozen          ; t or nil ; t means won't include this
+  documentation 
+  constructors            ; a list of either a symbol or a list symbol, arglist
+  offset          ; the total number of slots and placeholders
+  named                   ; t or nil
+  type                    ; one of: nil, list, or vector
+  conc-name)              ; an interned symbol
+
+#|| 
+(import '(si::wrapper-state si::wrapper-class si::basic-wrapper))
+
+(defstruct (wrapper (:include basic-wrapper)
+		    (:print-function print-wrapper)
+		    (:constructor make-wrapper-internal)
+		    (:predicate wrapper-p)
+		    (:conc-name wrapper-))
+  (class-slots nil :type list))
+
+(defun print-wrapper (instance stream depth)
+  (printing-random-thing (wrapper stream)
+    (format stream "Wrapper ~S" (wrapper-class wrapper))))
+||#
+
+(defun update-wrapper-state (old new same-p)
+  (unless (consp old)
+    (setf (wrapper-state old) 
+	  (list (if same-p ':flush ':obsolete) new))))
+
+(defun freeze-defstruct (name)
+  (let ((tem (and (symbolp name) (get name 's-data))))
+    (if tem (setf (s-data-frozen tem) t))))
+
+
+
+@s]
+
+
+****Change:(orig (551 553 c))
+@s[  (let ((l (read stream)))
+    (unless (get (car l) 'is-a-structure)
+            (error "~S is not a structure." (car l)))
+
+@s|  (let* ((l (prog1 (read stream t nil t)
+	      (if *read-suppress*
+		  (return-from sharp-s-reader nil))))
+	 (sd
+	   (or (get (car l) 's-data)
+	       
+	       (error "~S is not a structure." (car l)))))
+    
+
+@s]
+
+
+****Change:(orig (558 558 c))
+@s[         (do ((cs (get (car l) 'structure-constructors) (cdr cs)))
+
+@s|         (do ((cs (s-data-constructors sd) (cdr cs)))
+
+@s]
+
+
+****Change:(orig (571 571 d))
+@s[(set-dispatch-macro-character #\# #\S 'sharp-s-reader)
+
+
+
+@s|(set-dispatch-macro-character #\# #\S 'sharp-s-reader)
+
+
+@s]
+
+
+****Change:(orig (582 582 c))
+@s[(defstruct person name age sex)
+
+@s|(defstruct person name (age 20 :type signed-char) (eyes 2 :type signed-char)
+		                                        sex)
+(defstruct person name (age 20 :type signed-char) (eyes 2 :type signed-char)
+		                                        sex)
+(defstruct person1 name (age 20 :type fixnum)
+		                                        sex)
+
+@s]
+
+
+****Change:(orig (584 584 c))
+@s[(defstruct (astronaut (:include person (age 45))
+
+@s|(defstruct joe a (a1 0 :type (mod  30)) (a2 0 :type (mod  30))
+  (a3 0 :type (mod  30)) (a4 0 :type (mod 30)) )
+
+;(defstruct person name age sex)
+
+(defstruct (astronaut (:include person (age 45 :type fixnum))
+
+@s]
+
+
+****Change:(orig (605 605 a))
+@s[  associative
+  identity)
+
+@s|  associative
+  identity)
+
+
+@s]
+
+==============================================================================
diff --git a/pcl/slots-boot.lisp b/pcl/slots-boot.lisp
new file mode 100644
index 000000000..da7b525b1
--- /dev/null
+++ b/pcl/slots-boot.lisp
@@ -0,0 +1,396 @@
+;;;-*-Mode:LISP; Package:PCL; Base:10; Syntax:Common-lisp -*-
+;;;
+;;; *************************************************************************
+;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
+;;; All rights reserved.
+;;;
+;;; Use and copying of this software and preparation of derivative works
+;;; based upon this software are permitted.  Any distribution of this
+;;; software or derivative works must comply with all applicable United
+;;; States export control laws.
+;;; 
+;;; This software is made available AS IS, and Xerox Corporation makes no
+;;; warranty about the software, its performance or its conformity to any
+;;; specification.
+;;; 
+;;; Any person obtaining a copy of this software is requested to send their
+;;; name and post office or electronic mail address to:
+;;;   CommonLoops Coordinator
+;;;   Xerox PARC
+;;;   3333 Coyote Hill Rd.
+;;;   Palo Alto, CA 94304
+;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
+;;;
+;;; Suggestions, comments and requests for improvements are also welcome.
+;;; *************************************************************************
+;;;
+
+(in-package 'pcl)
+
+(defmacro slot-symbol (slot-name type)
+  `(if (and (symbolp ,slot-name) (symbol-package ,slot-name))
+       (or (get ,slot-name ',(ecase type
+			       (reader 'reader-symbol)
+			       (writer 'writer-symbol)
+			       (boundp 'boundp-symbol)))
+	   (intern (format nil "~A ~A slot ~a" 
+			   (package-name (symbol-package ,slot-name))
+			   (symbol-name ,slot-name)
+			   ,(symbol-name type))
+	           *slot-accessor-name-package*))
+       (progn 
+	 (error "non-symbol and non-interned symbol slot name accessors~
+                 are not yet implemented")
+	 ;;(make-symbol (format nil "~a ~a" ,slot-name ,type))
+	 )))
+
+(defun slot-reader-symbol (slot-name)
+  (slot-symbol slot-name reader))
+
+(defun slot-writer-symbol (slot-name)
+  (slot-symbol slot-name writer))
+
+(defun slot-boundp-symbol (slot-name)
+  (slot-symbol slot-name boundp))
+
+(defmacro asv-funcall (sym slot-name &rest args)
+  `(function-funcall (if (#-akcl fboundp #+akcl %fboundp ,sym)
+			 (#-akcl symbol-function #+akcl %symbol-function ,sym)
+			 (no-slot ,sym ,slot-name))
+                     ,@args))
+
+(defun no-slot (slot-name sym)
+  (error "No class has a slot named ~S (~s has no function binding)
+          (or maybe your files were compiled with an old version of PCL:~
+          try recompiling.)"
+	 slot-name sym))
+
+(defmacro accessor-slot-value (object slot-name)
+  (unless (constantp slot-name)
+    (error "~s requires its slot-name argument to be a constant" 
+	   'accessor-slot-value))
+  (let* ((slot-name (eval slot-name))
+	 (sym (slot-reader-symbol slot-name)))
+    `(asv-funcall ',sym ',slot-name ,object)))
+
+(defmacro accessor-set-slot-value (object slot-name new-value &environment env)
+  (unless (constantp slot-name)
+    (error "~s requires its slot-name argument to be a constant" 
+	   'accessor-set-slot-value))
+  (setq object (macroexpand object env))
+  (setq slot-name (macroexpand slot-name env))
+  (let* ((slot-name (eval slot-name))
+	 (bindings (unless (or (constantp new-value) (atom new-value))
+		     (let ((object-var (gensym)))
+		       (prog1 `((,object-var ,object))
+			 (setq object object-var)))))
+	 (sym (slot-writer-symbol slot-name))
+	 (form `(asv-funcall ',sym ',slot-name ,new-value ,object)))
+    (if bindings
+	`(let ,bindings ,form)
+	form)))
+
+(defconstant *optimize-slot-boundp* nil)
+
+(defmacro accessor-slot-boundp (object slot-name)
+  (unless (constantp slot-name)
+    (error "~s requires its slot-name argument to be a constant" 
+	   'accessor-slot-boundp))
+  (let* ((slot-name (eval slot-name))
+	 (sym (slot-boundp-symbol slot-name)))
+    (if (not *optimize-slot-boundp*)
+	`(slot-boundp-normal ,object ',slot-name)
+	`(asv-funcall ',sym ',slot-name ,object))))
+
+
+(defun structure-slot-boundp (object)
+  (declare (ignore object))
+  t)
+
+(defun make-structure-slot-boundp-function (slotd)
+  (let* ((reader (slot-definition-internal-reader-function slotd))
+	 (fun #'(lambda (object)
+		  (not (eq (funcall reader object) *slot-unbound*)))))
+    #+(and kcl turbo-closure) (si:turbo-closure fun)
+    fun))		    
+
+(defun get-optimized-std-accessor-method-function (class slotd name)
+  (if (structure-class-p class)
+      (ecase name
+	(reader (slot-definition-internal-reader-function slotd))
+	(writer (slot-definition-internal-writer-function slotd))
+	(boundp (make-structure-slot-boundp-function slotd)))
+      (let* ((fsc-p (cond ((standard-class-p class) nil)
+			  ((funcallable-standard-class-p class) t)
+			  (t (error "~S is not a standard-class" class))))
+	     (slot-name (slot-definition-name slotd))
+	     (index (slot-definition-location slotd))
+	     (function (ecase name
+			 (reader 'make-optimized-std-reader-method-function)
+			 (writer 'make-optimized-std-writer-method-function)
+			 (boundp 'make-optimized-std-boundp-method-function)))
+	     (value (funcall function fsc-p slot-name index)))
+	(values value index))))
+
+(defun make-optimized-std-reader-method-function (fsc-p slot-name index)
+  (declare #.*optimize-speed*)
+  (set-function-name
+   (etypecase index
+     (fixnum (if fsc-p
+		 #'(lambda (instance)
+		     (let ((value (%instance-ref (fsc-instance-slots instance) index)))
+		       (if (eq value *slot-unbound*)
+			   (slot-unbound (class-of instance) instance slot-name)
+			   value)))
+		 #'(lambda (instance)
+		     (let ((value (%instance-ref (std-instance-slots instance) index)))
+		       (if (eq value *slot-unbound*)
+			   (slot-unbound (class-of instance) instance slot-name)
+			   value)))))
+     (cons   #'(lambda (instance)
+		 (let ((value (cdr index)))
+		   (if (eq value *slot-unbound*)
+		       (slot-unbound (class-of instance) instance slot-name)
+		       value)))))
+   `(reader ,slot-name)))
+
+(defun make-optimized-std-writer-method-function (fsc-p slot-name index)
+  (declare #.*optimize-speed*)
+  (set-function-name
+   (etypecase index
+     (fixnum (if fsc-p
+		 #'(lambda (nv instance)
+		     (setf (%instance-ref (fsc-instance-slots instance) index) nv))
+		 #'(lambda (nv instance)
+		     (setf (%instance-ref (std-instance-slots instance) index) nv))))
+     (cons   #'(lambda (nv instance)
+		 (declare (ignore instance))
+		 (setf (cdr index) nv))))
+   `(writer ,slot-name)))
+
+(defun make-optimized-std-boundp-method-function (fsc-p slot-name index)
+  (declare #.*optimize-speed*)
+  (set-function-name
+   (etypecase index
+     (fixnum (if fsc-p
+		 #'(lambda (instance)
+		     (not (eq *slot-unbound*
+			      (%instance-ref (fsc-instance-slots instance) index))))
+		 #'(lambda (instance)
+		     (not (eq *slot-unbound* 
+			      (%instance-ref (std-instance-slots instance) index))))))
+     (cons   #'(lambda (instance)
+		 (declare (ignore instance))
+		 (not (eq *slot-unbound* (cdr index))))))
+   `(boundp ,slot-name)))
+
+(defun make-optimized-structure-slot-value-using-class-method-function (function)
+  #+cmu (declare (type function function))
+  #'(lambda (class object slotd)
+      (let ((value (funcall function object)))
+	(if (eq value *slot-unbound*)
+	    (slot-unbound class object (slot-definition-name slotd))
+	    value))))	    
+
+(defun make-optimized-structure-setf-slot-value-using-class-method-function (function)
+  #+cmu (declare (type function function))
+  #'(lambda (nv class object slotd)
+      (declare (ignore class slotd))
+      (funcall function nv object)))
+
+(defun make-optimized-structure-slot-boundp-using-class-method-function (function)
+  #+cmu (declare (type function function))
+  #'(lambda (class object slotd)
+      (declare (ignore class slotd))
+      (not (eq (funcall function object) *slot-unbound*))))
+
+(defun get-optimized-std-slot-value-using-class-method-function (class slotd name)
+  (if (structure-class-p class)
+      (ecase name
+	(reader (make-optimized-structure-slot-value-using-class-method-function
+		 (slot-definition-internal-reader-function slotd)))
+	(writer (make-optimized-structure-setf-slot-value-using-class-method-function
+		 (slot-definition-internal-writer-function slotd)))
+	(boundp (make-optimized-structure-slot-boundp-using-class-method-function
+		 (slot-definition-internal-writer-function slotd))))
+      (let* ((fsc-p (cond ((standard-class-p class) nil)
+			  ((funcallable-standard-class-p class) t)
+			  (t (error "~S is not a standard-class" class))))
+	     (slot-name (slot-definition-name slotd))
+	     (index (slot-definition-location slotd))
+	     (function 
+	      (ecase name
+		(reader 
+		 #'make-optimized-std-slot-value-using-class-method-function)
+		(writer 
+		 #'make-optimized-std-setf-slot-value-using-class-method-function)
+		(boundp 
+		 #'make-optimized-std-slot-boundp-using-class-method-function))))
+	#+cmu (declare (type function function))
+	(values (funcall function fsc-p slot-name index) index))))
+
+(defun make-optimized-std-slot-value-using-class-method-function
+    (fsc-p slot-name index)
+  (declare #.*optimize-speed*)
+  (etypecase index
+    (fixnum (if fsc-p
+		#'(lambda (class instance slotd)
+		    (declare (ignore slotd))
+		    (unless (fsc-instance-p instance) (error "not fsc"))
+		    (let ((value (%instance-ref (fsc-instance-slots instance) index)))
+		      (if (eq value *slot-unbound*)
+			  (slot-unbound class instance slot-name)
+			  value)))
+		#'(lambda (class instance slotd)
+		    (declare (ignore slotd))
+		    (unless (std-instance-p instance) (error "not std"))
+		    (let ((value (%instance-ref (std-instance-slots instance) index)))
+		      (if (eq value *slot-unbound*)
+			  (slot-unbound class instance slot-name)
+			  value)))))
+    (cons   #'(lambda (class instance slotd)
+		(declare (ignore slotd))
+		(let ((value (cdr index)))
+		  (if (eq value *slot-unbound*)
+		      (slot-unbound class instance slot-name)
+		      value))))))
+
+(defun make-optimized-std-setf-slot-value-using-class-method-function
+    (fsc-p slot-name index)
+  (declare #.*optimize-speed*)
+  (declare (ignore slot-name))
+  (etypecase index
+    (fixnum (if fsc-p
+		#'(lambda (nv class instance slotd)
+		    (declare (ignore class slotd))
+		    (setf (%instance-ref (fsc-instance-slots instance) index) nv))
+		#'(lambda (nv class instance slotd)
+		    (declare (ignore class slotd))
+		    (setf (%instance-ref (std-instance-slots instance) index) nv))))
+    (cons   #'(lambda (nv class instance slotd)
+		(declare (ignore class instance slotd))
+		(setf (cdr index) nv)))))
+
+(defun make-optimized-std-slot-boundp-using-class-method-function
+    (fsc-p slot-name index)
+  (declare #.*optimize-speed*)
+  (declare (ignore slot-name))
+  (etypecase index
+    (fixnum (if fsc-p
+		#'(lambda (class instance slotd)
+		    (declare (ignore class slotd))
+		    (not (eq *slot-unbound* 
+			     (%instance-ref (fsc-instance-slots instance) index))))
+		#'(lambda (class instance slotd)
+		    (declare (ignore class slotd))
+		    (not (eq *slot-unbound* 
+			     (%instance-ref (std-instance-slots instance) index))))))
+    (cons   #'(lambda (class instance slotd)
+		(declare (ignore class instance slotd))
+		(not (eq *slot-unbound* (cdr index)))))))
+
+(defun get-accessor-from-svuc-method-function (class slotd sdfun name)
+  (macrolet ((emf-funcall (emf &rest args)
+	       `(invoke-effective-method-function ,emf nil ,@args)))
+    (set-function-name
+     (case name
+       (reader #'(lambda (instance) (emf-funcall sdfun class instance slotd)))
+       (writer #'(lambda (nv instance) (emf-funcall sdfun nv class instance slotd)))
+       (boundp #'(lambda (instance) (emf-funcall sdfun class instance slotd))))
+     `(,name ,(class-name class) ,(slot-definition-name slotd)))))
+
+(defun make-internal-reader-method-function (class-name slot-name)
+  (list* ':method-spec `(internal-reader-method ,class-name ,slot-name)
+	 (make-method-function
+	  (lambda (instance)
+	    (let ((wrapper (cond ((std-instance-p instance) 
+				  (std-instance-wrapper instance))
+				 ((fsc-instance-p instance) 
+				  (fsc-instance-wrapper instance)))))
+	      (if wrapper
+		  (let* ((class (wrapper-class* wrapper))
+			 (index (or (instance-slot-index wrapper slot-name)
+				    (assq slot-name (wrapper-class-slots wrapper)))))
+		    (typecase index
+		      (fixnum 	
+		       (let ((value (%instance-ref (get-slots instance) index)))
+			 (if (eq value *slot-unbound*)
+			     (slot-unbound (class-of instance) instance slot-name)
+			     value)))
+		      (cons
+		       (let ((value (cdr index)))
+			 (if (eq value *slot-unbound*)
+			     (slot-unbound (class-of instance) instance slot-name)
+			     value)))
+		      (t
+		       (error "The wrapper for class ~S does not have the slot ~S"
+			      class slot-name))))
+		  (slot-value instance slot-name)))))))
+
+
+(defun make-std-reader-method-function (class-name slot-name)
+  (let* ((pv-table-symbol (gensym))
+	 (initargs (copy-tree
+		    (make-method-function
+		     (lambda (instance)
+		       (pv-binding1 (.pv. .calls.
+					  (symbol-value pv-table-symbol)
+					  (instance) (instance-slots))
+			 (instance-read-internal 
+			  .pv. instance-slots 1
+			  (slot-value instance slot-name))))))))
+    (setf (getf (getf initargs ':plist) ':slot-name-lists)
+	  (list (list nil slot-name)))
+    (setf (getf (getf initargs ':plist) ':pv-table-symbol) pv-table-symbol)
+    (list* ':method-spec `(reader-method ,class-name ,slot-name)
+	   initargs)))
+
+(defun make-std-writer-method-function (class-name slot-name)
+  (let* ((pv-table-symbol (gensym))
+	 (initargs (copy-tree
+		    (make-method-function
+		     (lambda (nv instance)
+		       (pv-binding1 (.pv. .calls.
+					  (symbol-value pv-table-symbol)
+					  (instance) (instance-slots))
+			 (instance-write-internal 
+			  .pv. instance-slots 1 nv
+			  (setf (slot-value instance slot-name) nv))))))))
+    (setf (getf (getf initargs ':plist) ':slot-name-lists)
+	  (list nil (list nil slot-name)))
+    (setf (getf (getf initargs ':plist) ':pv-table-symbol) pv-table-symbol)
+    (list* ':method-spec `(writer-method ,class-name ,slot-name)
+	   initargs)))
+
+(defun make-std-boundp-method-function (class-name slot-name)
+  (let* ((pv-table-symbol (gensym))
+	 (initargs (copy-tree
+		    (make-method-function
+		     (lambda (instance)
+		       (pv-binding1 (.pv. .calls.
+					  (symbol-value pv-table-symbol)
+					  (instance) (instance-slots))
+			  (instance-boundp-internal 
+			   .pv. instance-slots 1
+			   (slot-boundp instance slot-name))))))))
+    (setf (getf (getf initargs ':plist) ':slot-name-lists)
+	  (list (list nil slot-name)))
+    (setf (getf (getf initargs ':plist) ':pv-table-symbol) pv-table-symbol)
+    (list* ':method-spec `(boundp-method ,class-name ,slot-name)
+	   initargs)))
+
+(defun initialize-internal-slot-gfs (slot-name)
+  (let* ((name (slot-reader-symbol slot-name))
+	 (gf (ensure-generic-function name)))
+    (unless (generic-function-methods gf)
+      (add-reader-method *the-class-slot-object* gf slot-name)))
+  (let* ((name (slot-writer-symbol slot-name))
+	 (gf (ensure-generic-function name)))
+    (unless (generic-function-methods gf)
+      (add-writer-method *the-class-slot-object* gf slot-name)))
+  (when *optimize-slot-boundp*
+    (let* ((name (slot-boundp-symbol slot-name))
+	   (gf (ensure-generic-function name)))
+      (unless (generic-function-methods gf)
+	(add-boundp-method *the-class-slot-object* gf slot-name))))
+  nil)
-- 
GitLab