gcl.git - GNU Common Lisp

diff --git a/gcl/pcl/impl/cmu/README b/gcl/pcl/impl/cmu/README
new file mode 100644
index 000000000..240279387
--- /dev/null
+++ b/gcl/pcl/impl/cmu/README

@@ -0,0 +1,17 @@

+To install,

+

+put this version of PCL in cmucl's source directory, and name it pcl.

+rename the cmucl file tools/pclcom.lisp to tools/pclcom.lisp.original

+link the file impl/cmu/pclcom.lisp to cmucl/tools/pclcom.lisp

+link the file impl/cmu/pclload.lisp to pclload.lisp

+

+For example,

+

+cd cmucl17f

+mv pcl pcl.original

+<<install this PCL in the pcl directory>>

+cd tools

+mv pclcom.lisp pclcom.lisp.original

+ln -s ../pcl/impl/cmu/pclcom.lisp pclcom.lisp

+cd ../pcl

+ln -s impl/cmu/pclload.lisp pclload.lisp

diff --git a/gcl/pcl/impl/cmu/cmu-low.lisp b/gcl/pcl/impl/cmu/cmu-low.lisp
new file mode 100644
index 000000000..459c4453a
--- /dev/null
+++ b/gcl/pcl/impl/cmu/cmu-low.lisp

@@ -0,0 +1,217 @@

+;;;-*-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 is the CMU Lisp version of the file low.

+;;;

+

+(in-package :pcl)

+

+#+small

+(setq *optimize-speed*

+ '(optimize (speed 3) (safety 0) (debug 0.5) (ext:inhibit-warnings 3)))

+

+(defmacro dotimes ((var count &optional (result nil)) &body body)

+ `(lisp:dotimes (,var (the fixnum ,count) ,result)

+ (declare (fixnum ,var))

+ ,@body))

+

+;;; Just use our without-interrupts. We don't have the INTERRUPTS-ON/OFF local

+;;; macros spec'ed in low.lisp, but they aren't used.

+;;;

+(defmacro without-interrupts (&rest stuff)

+ `(sys:without-interrupts ,@stuff))

+

+(defun function-arglist (fcn)

+ "Returns the argument list of a compiled function, if possible."

+ (cond ((symbolp fcn)

+ (when (fboundp fcn)

+ (function-arglist (symbol-function fcn))))

+ ((eval:interpreted-function-p fcn)

+ (eval:interpreted-function-arglist fcn))

+ ((functionp fcn)

+ (let ((lambda-expr (function-lambda-expression fcn)))

+ (if lambda-expr

+ (cadr lambda-expr)

+ (let ((function (kernel:%closure-function fcn)))

+ (values (read-from-string

+ (kernel:%function-arglist function)))))))))

+

+

+;;; And returns the function, not the *name*.

+(defun set-function-name (fcn new-name)

+ "Set the name of a compiled function object."

+ (declare (special *boot-state* *the-class-standard-generic-function*))

+ (cond ((symbolp fcn)

+ (set-function-name (symbol-function fcn) new-name))

+ ((funcallable-instance-p fcn)

+ (if (if (eq *boot-state* 'complete)

+ (typep fcn 'generic-function)

+ (eq (class-of fcn) *the-class-standard-generic-function*))

+ (setf (kernel:%funcallable-instance-info fcn 1) new-name)

+ (typecase fcn

+ (kernel:byte-closure

+ (set-function-name (kernel:byte-closure-function fcn) new-name))

+ (kernel:byte-function

+ (setf (kernel:byte-function-name fcn) new-name))))

+ fcn)

+ ((eval:interpreted-function-p fcn)

+ (setf (eval:interpreted-function-name fcn) new-name)

+ fcn)

+ (t

+ (let ((header (kernel:%closure-function fcn)))

+ #+cmu17

+ (setf (c::%function-name header) new-name)

+ #-cmu17

+ (system:%primitive c::set-function-name header new-name))

+ fcn)))

+

+(in-package "C")

+

+(def-source-context pcl:defmethod (name &rest stuff)

+ (let ((arg-pos (position-if #'listp stuff)))

+ (if arg-pos

+ `(pcl:defmethod ,name ,@(subseq stuff 0 arg-pos)

+ ,(nth-value 2 (pcl::parse-specialized-lambda-list

+ (elt stuff arg-pos))))

+ `(pcl:defmethod ,name "<illegal syntax>"))))

+

+

+(in-package "PCL")

+

+;;;; STD-INSTANCE

+

+;;; Under CMU17 conditional, STD-INSTANCE-P is only used to discriminate

+;;; between functions (including FINs) and normal instances, so we can return

+;;; true on structures also. A few uses of (or std-instance-p fsc-instance-p)

+;;; are changed to pcl-instance-p.

+;;;

+(defmacro std-instance-p (x)

+ `(kernel:%instancep ,x))

+(defmacro pcl-instance-p (x)

+ `(typep (kernel:layout-of ,x) 'wrapper))

+

+

+;;; We define this as STANDARD-INSTANCE, since we're going to clobber the

+;;; layout with some standard-instance layout as soon as we make it, and we

+;;; want the accesor to still be type-correct.

+;;;

+(defstruct (standard-instance

+ (:predicate nil)

+ (:constructor %%allocate-instance--class--fn ())

+ (:alternate-metaclass kernel:instance lisp:standard-class

+ kernel:make-standard-class))

+ (slots nil))

+

+;;; Must immediately setf the std-instance-wrapper after calling this.

+(defmacro %%allocate-instance--class ()

+ `(ext:truly-the standard-instance (kernel:%make-instance 2)))

+

+;;; Both of these operations "work" on structures, which allows the above

+;;; weakening of std-instance-p.

+;;;

+(defmacro std-instance-slots (x) `(kernel:%instance-ref ,x 1))

+(defmacro std-instance-wrapper (x) `(kernel:%instance-layout ,x))

+

+(defmacro built-in-or-structure-wrapper (x) `(kernel:layout-of ,x))

+

+(defmacro get-wrapper (inst)

+ (ext:once-only ((wrapper `(wrapper-of ,inst)))

+ `(progn

+ (assert (typep ,wrapper 'wrapper) () "What kind of instance is this?")

+ ,wrapper)))

+

+(defmacro get-instance-wrapper-or-nil (inst)

+ (ext:once-only ((wrapper `(wrapper-of ,inst)))

+ `(if (typep ,wrapper 'wrapper)

+ ,wrapper

+ nil)))

+

+;;; get-slots harmless

+

+(defmacro get-slots-or-nil (inst)

+ (ext:once-only ((n-inst inst))

+ `(when (pcl-instance-p ,n-inst)

+ (if (std-instance-p ,n-inst)

+ (std-instance-slots ,n-inst)

+ (fsc-instance-slots ,n-inst)))))

+

+

+;;;; Structure-instance stuff:

+

+(pushnew :structure-wrapper *features*)

+

+(defun structure-functions-exist-p ()

+ t)

+

+(defun structure-instance-p (x)

+ (typep x 'lisp:structure-object))

+

+(defun structurep (x)

+ (typep x 'lisp:structure-object))

+

+(defun structure-type (x)

+ (lisp:class-name (kernel:layout-class (kernel:%instance-layout x))))

+

+

+(defun structure-type-p (type)

+ (and (symbolp type)

+ (let ((class (lisp:find-class type nil)))

+ (and class

+ (typep (kernel:layout-info (kernel:class-layout class))

+ 'kernel:defstruct-description)))))

+

+(defun get-structure-dd (type)

+ (kernel:layout-info (kernel:class-layout (lisp:find-class type))))

+

+(defun structure-type-included-type-name (type)

+ (let ((include (kernel::dd-include (get-structure-dd type))))

+ (if (consp include)

+ (car include)

+ include)))

+

+(defun structure-type-slot-description-list (type)

+ (nthcdr (length (let ((include (structure-type-included-type-name type)))

+ (and include (kernel:dd-slots (get-structure-dd include)))))

+ (kernel:dd-slots (get-structure-dd type))))

+

+(defun structure-slotd-name (slotd)

+ (kernel:dsd-name slotd))

+

+(defun structure-slotd-accessor-symbol (slotd)

+ (kernel:dsd-accessor slotd))

+

+(defun structure-slotd-reader-function (slotd)

+ (fdefinition (kernel:dsd-accessor slotd)))

+

+(defun structure-slotd-writer-function (slotd)

+ (unless (kernel:dsd-read-only slotd)

+ (fdefinition `(setf ,(kernel:dsd-accessor slotd)))))

+

+(defun structure-slotd-type (slotd)

+ (kernel:dsd-type slotd))

+

+(defun structure-slotd-init-form (slotd)

+ (kernel::dsd-default slotd))

diff --git a/gcl/pcl/impl/cmu/pclcom.lisp b/gcl/pcl/impl/cmu/pclcom.lisp
new file mode 100644
index 000000000..6be7d94e3
--- /dev/null
+++ b/gcl/pcl/impl/cmu/pclcom.lisp

@@ -0,0 +1,66 @@

+;; This is "target:tools/pclcom.lisp"

+

+(in-package "USER")

+

+(when (find-package "PCL")

+ (setf (compiler-macro-function 'make-instance) nil)

+ ;;

+ ;; Undefine all generic functions exported from Lisp so that bootstrapping

+ ;; doesn't get confused.

+ (let ((class (find-class 'generic-function nil)))

+ (when class

+ (do-external-symbols (sym "LISP")

+ (when (and (fboundp sym)

+ (typep (fdefinition sym) class))

+ (fmakunbound sym))

+ (let ((ssym `(setf ,sym)))

+ (when (and (fboundp ssym)

+ (typep (fdefinition ssym) class))

+ (fmakunbound ssym))))))

+

+ ;; Undefine all PCL classes, and clear CLASS-PCL-CLASS slots.

+ (let ((wot (find-symbol "*FIND-CLASS*" "PCL")))

+ (when (and wot (boundp wot))

+ (do-hash (name ignore (symbol-value wot))

+ (declare (ignore ignore))

+ (let ((class (find-class name nil)))

+ (cond ((not class))

+ ((typep class 'kernel::std-class)

+ (setf (kernel:class-cell-class

+ (kernel:find-class-cell name))

+ nil)

+ (setf (info type kind name) nil))

+ (t

+ (setf (kernel:class-pcl-class class) nil)))))))

+

+ (rename-package "PCL" "OLD-PCL")

+ (make-package "PCL"))

+

+(when (find-package "SLOT-ACCESSOR-NAME")

+ (rename-package "SLOT-ACCESSOR-NAME" "OLD-SLOT-ACCESSOR-NAME"))

+

+(setf c:*suppress-values-declaration* t)

+(pushnew :setf *features*)

+

+(setf (search-list "pcl:") '("target:pcl/"))

+

+(let ((obj (make-pathname :defaults "pcl:defsys"

+ :type (c:backend-fasl-file-type c:*backend*))))

+ (when (< (or (file-write-date obj) 0)

+ (file-write-date "pcl:defsys.lisp"))

+ (compile-file "pcl:defsys" :byte-compile t)))

+

+(load "pcl:defsys" :verbose t)

+

+(import 'kernel:funcallable-instance-p (find-package "PCL"))

+

+(with-compilation-unit

+ (:optimize '(optimize (debug #+small .5 #-small 2)

+ (speed 2) (safety #+small 0 #-small 2)

+ (inhibit-warnings 2))

+ :optimize-interface '(optimize-interface #+small (safety 1))

+ :context-declarations

+ '((:external (declare (optimize-interface (safety 2) (debug 1))))

+ ((:or :macro (:match "$EARLY-") (:match "$BOOT-"))

+ (declare (optimize (speed 0))))))

+ (pcl::compile-pcl))

diff --git a/gcl/pcl/impl/cmu/pclload.lisp b/gcl/pcl/impl/cmu/pclload.lisp
new file mode 100644
index 000000000..39fb098d6
--- /dev/null
+++ b/gcl/pcl/impl/cmu/pclload.lisp

@@ -0,0 +1,12 @@

+(in-package "PCL")

+(unless (find-package "SLOT-ACCESSOR-NAME")

+ (make-package "SLOT-ACCESSOR-NAME"))

+(rename-package "PCL" "PCL" '("OLD-PCL"))

+(rename-package "SLOT-ACCESSOR-NAME" "SLOT-ACCESSOR-NAME"

+ '("OLD-SLOT-ACCESSOR-NAME"))

+(import 'kernel:funcallable-instance-p)

+(load "target:pcl/defsys")

+(load-pcl)

+(rename-package "PCL" "PCL" '())

+(rename-package "SLOT-ACCESSOR-NAME" "SLOT-ACCESSOR-NAME" '())

+

diff --git a/gcl/pcl/impl/coral/coral-low.lisp b/gcl/pcl/impl/coral/coral-low.lisp
new file mode 100644
index 000000000..650dd7517
--- /dev/null
+++ b/gcl/pcl/impl/coral/coral-low.lisp

@@ -0,0 +1,63 @@

+;;;-*-Mode:LISP; Package:(PCL (LISP WALKER)); 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)

+

+#-:ccl-1.3

+(ccl::add-transform 'std-instance-p

+ :inline

+ #'(lambda (call)

+ (ccl::verify-arg-count call 1 1)

+ (let ((arg (cadr call)))

+ `(and (eq (ccl::%type-of ,arg) 'structure)

+ (eq (%svref ,arg 0) 'std-instance)))))

+

+(eval-when (eval compile load)

+ (proclaim '(inline std-instance-p)))

+

+(defun printing-random-thing-internal (thing stream)

+ (prin1 (ccl::%ptr-to-int thing) stream))

+

+(defun set-function-name-1 (function new-name uninterned-name)

+ (declare (ignore uninterned-name))

+ (cond ((ccl::lfunp function)

+ (ccl::lfun-name function new-name)))

+ function)

+

+

+(defun doctor-dfun-for-the-debugger (gf dfun)

+ #+:ccl-1.3

+ (let* ((gfspec (and (symbolp (generic-function-name gf))

+ (generic-function-name gf)))

+ (arglist (generic-function-pretty-arglist gf)))

+ (when gfspec

+ (setf (get gfspec 'ccl::%lambda-list)

+ (if (and arglist (listp arglist))

+ (format nil "~{~A~^ ~}" arglist)

+ (format nil "~:A" arglist)))))

+ dfun)

+

diff --git a/gcl/pcl/impl/franz/cpatch.lisp b/gcl/pcl/impl/franz/cpatch.lisp
new file mode 100644
index 000000000..23641de54
--- /dev/null
+++ b/gcl/pcl/impl/franz/cpatch.lisp

@@ -0,0 +1,32 @@

+;; -[Thu Feb 22 08:38:07 1990 by jkf]-

+;; cpatch.cl

+;; compiler patch for the fast clos

+;;

+;; copyright (c) 1990 Franz Inc.

+;;

+

+(in-package :comp)

+

+(def-quad-op tail-funcall qp-end-block

+ ;; u = (argcount function-object)

+ ;;

+ ;; does a tail call to the function-object given

+ ;; never returns

+ )

+

+(defun-in-runtime sys::copy-function (func))

+

+(in-package :hyperion)

+

+(def-quad-hyp r-tail-funcall comp::tail-funcall (u d quad)

+ ;; u = (argcount function)

+ ;;

+ (r-move-single-to-loc (treg-loc (car u)) *count-reg*)

+ (r-move-single-to-loc (treg-loc (cadr u)) *fcnin-reg*)

+ (re restore *zero-reg* *zero-reg*)

+ (re move.l `(d #.r-function-start-adj #.*fcnout-reg*) '#.*ctr2-reg*)

+ (re jmpl '(d 0 #.*ctr2-reg*) *zero-reg*)

+ (re nop))

+

+

+

diff --git a/gcl/pcl/impl/franz/excl-low.lisp b/gcl/pcl/impl/franz/excl-low.lisp
new file mode 100644
index 000000000..54c734b4d
--- /dev/null
+++ b/gcl/pcl/impl/franz/excl-low.lisp

@@ -0,0 +1,136 @@

+;;; -*- 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 is the EXCL (Franz) lisp version of the file portable-low.

+;;;

+;;; This is for version 1.1.2. Many of the special symbols now in the lisp

+;;; package (e.g. lisp::pointer-to-fixnum) will be in some other package in

+;;; a later release so this will need to be changed.

+;;;

+

+(in-package 'pcl)

+

+(defmacro without-interrupts (&body body)

+ `(let ((outer-interrupts excl::*without-interrupts*)

+ (excl::*without-interrupts* 0))

+ (macrolet ((interrupts-on ()

+ '(unless outer-interrupts

+ (setq excl::*without-interrupts* nil)))

+ (interrupts-off ()

+ '(setq excl::*without-interrupts* 0)))

+ ,.body)))

+

+(eval-when (compile load eval)

+ (unless (fboundp 'excl::sy_hash)

+ (setf (symbol-function 'excl::sy_hash)

+ (symbol-function 'excl::_sy_hash-value)))

+ )

+

+(defmacro memq (item list)

+ (let ((list-var (gensym))

+ (item-var (gensym)))

+ `(prog ((,list-var ,list)

+ (,item-var ,item))

+ start

+ (cond ((null ,list-var)

+ (return nil))

+ ((eq (car ,list-var) ,item-var)

+ (return ,list-var))

+ (t

+ (pop ,list-var)

+ (go start))))))

+

+(defun std-instance-p (x)

+ (and (excl::structurep x)

+ (locally

+ (declare #.*optimize-speed*)

+ (eq (svref x 0) 'std-instance))))

+

+(excl::defcmacro std-instance-p (x)

+ (once-only (x)

+ `(and (excl::structurep ,x)

+ (locally

+ (declare #.*optimize-speed*)

+ (eq (svref ,x 0) 'std-instance)))))

+

+(excl::defcmacro fast-method-call-p (x)

+ (once-only (x)

+ `(and (excl::structurep ,x)

+ (locally

+ (declare #.*optimize-speed*)

+ (eq (svref ,x 0) 'fast-method-call)))))

+

+(defmacro %std-instance-wrapper (x)

+ `(svref ,x 1))

+

+(defmacro %std-instance-slots (x)

+ `(svref ,x 2))

+

+(defun printing-random-thing-internal (thing stream)

+ (format stream "~O" (excl::pointer-to-fixnum thing)))

+

+#-vax

+(defun set-function-name-1 (fn new-name ignore)

+ (declare (ignore ignore))

+ (cond ((excl::function-object-p fn)

+ (setf (excl::fn_symdef fn) new-name))

+ (t nil))

+ fn)

+

+(defun function-arglist (f)

+ (excl::arglist f))

+

+(defun symbol-append (sym1 sym2 &optional (package *package*))

+ ;; This is a version of symbol-append from macros.cl

+ ;; It insures that all created symbols are of one case and that

+ ;; case is the current prefered case.

+ ;; This special version of symbol-append is not necessary if all you

+ ;; want to do is compile and run pcl in a case-insensitive-upper

+ ;; version of cl.

+ ;;

+ (let ((string (string-append sym1 sym2)))

+ (case excl::*current-case-mode*

+ ((:case-insensitive-lower :case-sensitive-lower)

+ (setq string (string-downcase string)))

+ ((:case-insensitive-upper :case-sensitive-upper)

+ (setq string (string-upcase string))))

+ (intern string package)))

+

+;;; Define inspector hooks for PCL object instances.

+

+(defun (:property pcl::std-instance :inspector-function) (object)

+ (let ((class (class-of object)))

+ (cons (inspect::make-field-def "class-of :lisp)

+ (mapcar #'(lambda (slot)

+ (inspect::make-field-def

+ (string (slot-definition-name slot))

+ #'(lambda (x)

+ (slot-value-using-class class x slot))

+ :lisp))

+ (slots-to-inspect class object)))))

+

+(defun (:property pcl::std-instance :inspector-type-function) (x)

+ (class-name (class-of x)))

diff --git a/gcl/pcl/impl/franz/quadlap.lisp b/gcl/pcl/impl/franz/quadlap.lisp
new file mode 100644
index 000000000..3d7507e1c
--- /dev/null
+++ b/gcl/pcl/impl/franz/quadlap.lisp

@@ -0,0 +1,619 @@

+;; -[Thu Mar 1 10:54:27 1990 by jkf]-

+;; pcl to quad translation

+;; $Header$

+;;

+;; copyright (c) 1990 Franz Inc.

+;;

+(in-package :compiler)

+

+

+

+

+(defvar *arg-to-treg* nil)

+(defvar *cvar-to-index* nil)

+(defvar *reg-array* nil)

+(defvar *closure-treg* nil)

+(defvar *nargs-treg* nil)

+

+(defvar *debug-sparc* nil)

+

+(defmacro pcl-make-lambda (&key required)

+ `(list 'lambda nil :unknown-type 0 compiler::.function-level.

+ ,required nil nil nil nil nil nil nil nil nil

+ nil 'compiler::none nil nil nil

+ nil nil nil nil nil nil 0 nil))

+

+(defmacro pcl-make-varrec (&key name loc contour-level)

+ `(list ,name nil 0 nil ,loc nil t compiler::.function-level. nil nil :unknown-type nil nil ,contour-level))

+

+(defmacro pcl-make-lap (&key lap constants cframe-size locals)

+ `(list nil ,constants ,lap nil nil ,cframe-size ,locals nil nil nil))

+

+

+(defstruct preg

+ ;; pseudo reg descritpor

+ treg ; associated treg

+ index ; :index if this is an index type reg

+ ; :vector if this is a vector type reg

+ )

+

+

+(defun pcl::excl-lap-closure-generator (closure-vars-names

+ arg-names

+ index-regs

+ vector-regs

+ fixnum-vector-regs

+ t-regs

+ lap-code)

+ (let ((function (pcl::excl-lap-closure-gen closure-vars-names

+ arg-names

+ index-regs

+ (append vector-regs fixnum-vector-regs)

+ t-regs

+ lap-code)))

+ #'(lambda (&rest closure-vals)

+ (insert-closure-vals function closure-vals))))

+

+

+(defun pcl::excl-lap-closure-gen

+ (closure-vars-names arg-names index-regs vector-regs t-regs lap-code)

+ (let ((*quads* nil)

+ (*treg-num* 0)

+ (*all-tregs* nil)

+ (*bb-count* 0)

+ *treg-bv-size*

+ *treg-vector*

+ (*next-catch-frame* 0)

+ (*max-catch-frame* -1)

+ *catch-labels*

+ *top-label*

+ *mv-treg*

+ *mv-treg-target*

+ *zero-treg*

+ *nil-treg*

+ *bbs* *bb* lap

+ ;; bbs

+ *cross-block-regs*

+ *const-tregs* *move-tregs*

+ *actuals*

+ *ignore-argcount*

+ *binds-specs*

+ *bvl-current-bv* ; for bitvector cacher

+ *bvl-used-bvs*

+ *bvl-index*

+ (*inhibit-call-count* t)

+

+ ; this fcn

+ *arg-to-treg*

+ *cvar-to-index*

+ *reg-array*

+ minargs

+ maxargs

+ *closure-treg*

+

+ node

+ otherargregs

+

+ *nargs-treg*

+ )

+

+ (if* *debug-sparc*

+ then (format t ">>** << Generating sparc lap code~%"))

+

+ (setq *nil-treg*

+ #+allegro-v4.0 (new-reg :global t)

+ #-allegro-v4.0 (new-reg)

+ *mv-treg* (new-reg)

+ *mv-treg-target* (list *mv-treg*)

+ *zero-treg* (comp::new-reg))

+

+ ; examine given args

+

+ (setq minargs 0 maxargs 0)

+ (let (requireds)

+ (dolist (arg arg-names)

+ (if* (eq '&rest arg)

+ then (setq maxargs nil)

+ else (if* (null arg)

+ then ; we want a name even though we won't use it

+ (setq arg (gensym)))

+ (incf minargs)

+ (incf maxargs)

+ (push (cons arg (new-reg)) *arg-to-treg*)

+ (push (pcl-make-varrec :name arg

+ :loc (cdr (car *arg-to-treg*))

+ :contour-level 0)

+ requireds)

+ ))

+ (setq node (pcl-make-lambda :required (nreverse requireds))))

+ (setq *arg-to-treg* (nreverse *arg-to-treg*))

+

+ ; build closure vector list

+ (let ((index -1))

+ (dolist (cvar closure-vars-names)

+ (push (cons cvar (incf index)) *cvar-to-index*)))

+

+ (let ((maxreg (max (apply #'max (cons -1 index-regs))

+ (apply #'max (cons -1 vector-regs))

+ (apply #'max (cons -1 t-regs)))))

+ (setq *reg-array* (make-array (1+ maxreg))))

+

+ (dolist (index index-regs)

+ (setf (svref *reg-array* index)

+ (make-preg :treg (new-reg)

+ :index :index)))

+

+ (dolist (vector vector-regs)

+ (setf (svref *reg-array* vector)

+ (make-preg :treg (new-reg)

+ :index :vector)))

+

+ (dolist (tr t-regs)

+ (setf (svref *reg-array* tr) (make-preg :treg (new-reg))))

+

+

+ (if* closure-vars-names

+ then (setq *closure-treg* (new-reg)))

+ (setq *nargs-treg* (new-reg))

+

+ ;; (md-allocate-global-tregs)

+

+ ; function entry

+ (qe nop :arg :first-block)

+ (qe entry)

+ (qe argcount :arg (list minargs maxargs))

+ (qe lambda :d (mapcar #'cdr *arg-to-treg*))

+ (qe register :arg :nargs :d (list *nargs-treg*))

+

+ (if* *closure-treg*

+ then ; put the first closure vector in *closure-treg*

+ (qe extract-closure-vec :d (list *closure-treg*))

+ (let ((offsetreg (new-reg)))

+ (qe const :arg (mdparam 'md-cons-car-adj) :d (list offsetreg))

+ (qe ref :u (list *closure-treg* offsetreg)

+ :d (list *closure-treg*)

+ :arg :long))

+ )

+

+ (excl-gen-quads lap-code)

+

+ (if* *debug-sparc*

+ then (do-quad-list (quad next *quads*)

+ (format t "~a~%" quad))

+

+ (format t "basic blocks~%"))

+

+ (setq *bbs* (qc-compute-basic-blocks *quads*))

+

+ (excl::target-class-case

+ ((:r :m) (setq *actuals* (qc-compute-actuals *bbs*))))

+

+ (qc-live-variable-analysis *bbs*)

+

+ (setq *treg-bv-size* (* 16 (truncate (+ *treg-num* 15) 16)))

+

+ (qc-build-treg-vector)

+

+

+ (let ((*dump-bbs* nil)

+ (r::*local-regs*

+ ; use the in registers that aren't in use

+ (append r::*local-regs*

+ (if* maxargs

+ then (nthcdr maxargs r::*in-regs* )))))

+ (unwind-protect

+ (progn

+ ; machine specific code generation

+ (multiple-value-bind (lap-code literals size-struct locals)

+ #+(target-class r m e)

+ (progn

+ #+allegro-v4.0

+ (md-codegen node *bbs*

+ nil otherargregs)

+ #-allegro-v4.0

+ (md-codegen node *bbs*

+ *nil-treg* *mv-treg* *zero-treg*

+ nil otherargregs))

+

+ #-(target-class r m e) (md-codegen node *bbs*)

+ (setq lap

+ (pcl-make-lap :lap lap-code

+ :constants literals

+ :cframe-size size-struct

+ :locals locals)))

+

+

+ lap)

+ (giveback-bvs)))

+

+ #+ignore

+ (progn (format t "sparc code pre optimization~%")

+ (dolist (instr (lap-lap lap))

+ (format t "> ~a~%" instr)))

+ (md-optimize lap) ; peephole optimize

+ (if* *debug-sparc*

+ then (format t "sparc code post optimization~%")

+ (dolist (instr (lap-lap lap))

+ (format t "> ~a~%" instr)))

+ (md-assemble lap)

+ (setq last-lap lap)

+

+ (nl-runtime-make-a-fcnobj lap)))

+

+(defun qe-slot-access (operand offset dest)

+ ;; access a slot in a structure

+ (let ((temp (new-reg)))

+ (qe const :arg offset :d (list temp))

+ (qe ref :u (list (get-treg-of operand) temp)

+ :d (list (get-treg-of dest))

+ :arg :long)))

+

+

+(defun get-treg-of (operand &optional res-operand)

+ ;; get the appropriate treg for the operand

+ (let ((prefer-treg (and res-operand (simple-get-treg-of res-operand))))

+ (if* (numberp operand)

+ then (let ((treg (new-reg)))

+ (qe const :arg operand :d (list treg))

+ treg)

+ elseif (consp operand)

+ then (ecase (car operand)

+ (:reg

+ (preg-treg (svref *reg-array* (cadr operand))))

+ (:arg

+ (let ((x (cdr (assoc (cadr operand) *arg-to-treg* :test #'eq))))

+ (if* (null x)

+ then (error "where is arg ~s" operand)

+ else x)))

+ (:cvar

+ (let ((res-treg (or prefer-treg (new-reg)))

+ (temp-treg (new-reg)))

+ (qe const :arg (+ (mdparam 'md-svector-data0-adj)

+ (* 4 (cdr (assoc (cadr operand)

+ *cvar-to-index*

+ :test #'eq))))

+ :d (list temp-treg))

+ (qe ref :u (list *closure-treg* temp-treg)

+ :d (list res-treg)

+ :arg :long)

+ res-treg))

+ (:constant

+ (let ((treg (or prefer-treg (new-reg))))

+ (qe const :arg (if* (fixnump (cadr operand))

+ then (* 8 (cadr operand)) ; md!!

+ else (cadr operand))

+ :d (list treg))

+ treg))

+ (:index-constant

+ ; operand invented by jkf to denote an index type constant

+ (let ((treg (or prefer-treg (new-reg))))

+ (qe const :arg (if* (fixnump (cadr operand))

+ then (* 4 (cadr operand)) ; md!!

+ else (cadr operand))

+ :d (list treg))

+ treg)))

+ else (error "bad operand: ~s" operand))))

+

+(defun simple-get-treg-of (operand)

+ ;; get the treg if it is so simple that we don't have to

+ ;; emit any instructions to access it.

+ ;; return nil if we can't do it.

+ (if* (numberp operand)

+ then nil

+ elseif (consp operand)

+ then (case (car operand)

+ (:reg

+ (preg-treg (svref *reg-array* (cadr operand))))

+ (:arg

+ (let ((x (cdr (assoc (cadr operand) *arg-to-treg* :test #'eq))))

+ (if* (null x)

+ then nil

+ else x))))

+

+ else nil))

+

+(defun index-p (operand)

+ ;; determine if the result of this operand is an index value

+ ;* it would be better if conversion between lisp values and

+ ; index values were made explicit in the lap code

+ (and (consp operand)

+ (or (and (eq :reg (car operand))

+ (eq :index (preg-index (svref *reg-array* (cadr operand)))))

+ (member (car operand)

+ '(:i+ :i- :ilogand :ilogxor :i1+)

+ :test #'eq))

+ t))

+

+(defun gen-index-treg (operand)

+ ;; return the non-index type operand in a index treg

+ (if* (and (consp operand)

+ (eq ':constant (car operand)))

+ then (get-treg-of `(:index-constant ,(cadr operand)))

+ else (let ((treg (get-treg-of operand))

+ (new-reg (new-reg))

+ (shift-reg (new-reg)))

+ (qe const :arg 1 :d (list shift-reg))

+ (qe lsr :u (list treg shift-reg) :d (list new-reg))

+ new-reg)))

+

+

+

+

+

+(defun vector-preg-p (operand)

+ (and (consp operand)

+ (eq :reg (car operand))

+ (eq :vector (preg-index (svref *reg-array* (cadr operand))))))

+

+

+

+(defun excl-gen-quads (laps)

+ ;; generate quads from the lap

+ (dolist (lap laps)

+ (if* *debug-sparc* then (format t ">> ~a~%" lap))

+ (block again

+ (let ((opcode (car lap))

+ (op1 (cadr lap))

+ (op2 (caddr lap)))

+ (case opcode

+ (:move

+ ; can be either simple (both args registers)

+ ; or one arg can be complex and the other simple

+ (case (car op2)

+ ((:iref :instance-ref)

+ ;; assume that this is a lisp store

+ ;;(warn "assuming lisp store in ~s" lap)

+ (let (op1-treg)

+ (if* (not (vector-preg-p (cadr op2)))

+ then ; must offset before store

+ (error "must use vector register in ~s" lap)

+ else (setq op1-treg (get-treg-of (cadr op2))))

+

+

+

+ (qe set :u (list op1-treg

+ (get-treg-of (caddr op2))

+ (get-treg-of op1))

+ :arg :lisp)

+ (return-from again)))

+ (:cdr

+ ;; it certainly is a lisp stoer

+ (let (op1-treg const-reg)

+ (setq op1-treg (get-treg-of (cadr op2)))

+ (setq const-reg (new-reg))

+ (qe const :arg (mdparam 'md-cons-cdr-adj)

+ :d (list const-reg))

+

+

+

+ (qe set :u (list op1-treg

+ const-reg

+ (get-treg-of op1))

+ :arg :lisp)

+ (return-from again))))

+

+ ; the 'to'address is simple, the from address may not be

+

+ (let ((index1 (index-p op1))

+ (index2 (index-p op2))

+ (vector1 (vector-preg-p op1))

+ (vector2 (vector-preg-p op2)))

+ (ecase (car op1)

+ ((:reg :cvar :arg :constant :lisp-symbol)

+ (qe move

+ :u (list (get-treg-of op1 op2))

+ :d (list (get-treg-of op2))))

+ (:std-wrapper

+ (qe-slot-access (cadr op1)

+ (+ (* 1 4)

+ (comp::mdparam 'md-svector-data0-adj))

+ op2))

+ (:std-slots

+ (qe-slot-access (cadr op1)

+ (+ (* 2 4)

+ (comp::mdparam 'md-svector-data0-adj))

+ op2))

+ (:fsc-wrapper

+ (qe-slot-access (cadr op1)

+ (+ (* (- 15 1) 4)

+ (comp::mdparam 'md-function-const0-adj))

+ op2))

+ (:fsc-slots

+ (qe-slot-access (cadr op1)

+ (+ (* (- 15 2) 4)

+ (comp::mdparam 'md-function-const0-adj))

+ op2))

+ ((:built-in-wrapper :structure-wrapper :built-in-or-structure-wrapper)

+ (qe call :arg 'pcl::built-in-or-structure-wrapper

+ :u (list (get-treg-of (cadr op1)))

+ :d (list (get-treg-of op2))))

+ (:other-wrapper

+ (warn "do other-wrapper"))

+ ((:i+ :i- :ilogand :ilogxor)

+ (qe arith :arg (cdr (assoc (car op1)

+ '((:i+ . :+)

+ (:i- . :-)

+ (:ilogand . :logand)

+ (:ilogxor . :logxor))

+ :test #'eq))

+ :u (list (get-treg-of (cadr op1))

+ (get-treg-of (caddr op1)))

+ :d (list (get-treg-of op2))))

+ (:i1+

+ (let ((const-reg (new-reg)))

+ (qe const :arg 4 ; an index value of 1

+ :d (list const-reg))

+ (qe arith :arg :+

+ :u (list const-reg

+ (get-treg-of (cadr op1)))

+ :d (list (get-treg-of op2)))))

+

+ ((:iref :cref :instance-ref)

+ (let (op1-treg)

+ (if* (not (vector-preg-p (cadr op1)))

+ then ; must offset before store

+ (error "must use vector register in ~s" lap)

+ else (setq op1-treg (get-treg-of (cadr op1))))

+

+ (qe ref :u (list op1-treg

+ (get-treg-of (caddr op1) op2))

+ :d (list (get-treg-of op2))

+ :arg :long)))

+ (:cdr

+ (let ((const-reg (new-reg)))

+ (qe const :arg (mdparam 'md-cons-cdr-adj)

+ :d (list const-reg))

+ (qe ref :arg :long

+ :u (list (get-treg-of (cadr op1))

+ const-reg)

+ :d (list (get-treg-of op2))))))

+ (if* (not (eq index1 index2))

+ then (let ((shiftamt (new-reg)))

+ (qe const :arg 1 :d (list shiftamt))

+ (if* (and index1 (not index2))

+ then ; converting from index to non-index

+ (qe lsl :u (list (get-treg-of op2) shiftamt)

+ :d (list (get-treg-of op2)))

+ elseif (and (not index1) index2)

+ ; converting to an index

+ then (qe lsr :u (list (get-treg-of op2) shiftamt)

+ :d (list (get-treg-of op2)))))

+ elseif (and vector2 (not vector1))

+ then ; add vector offset

+ (let ((tempreg (new-reg))

+ (vreg (get-treg-of op2)))

+ (qe const :arg (mdparam 'md-svector-data0-adj)

+ :d (list tempreg))

+ (qe arith :arg :+ :u (list vreg tempreg)

+ :d (list vreg))))))

+ (:fix=

+ (let (tr1 tr2)

+ (if* (index-p op1)

+ then (setq tr1 (get-treg-of op1))

+ (if* (not (index-p op2))

+ then (setq tr2 (gen-index-treg op2))

+ else (setq tr2 (get-treg-of op2)))

+ elseif (index-p op2)

+ then ; assert: op1 isn't an index treg

+ (setq tr1 (gen-index-treg op1))

+ (setq tr2 (get-treg-of op2))

+ else (setq tr1 (get-treg-of op1)

+ tr2 (get-treg-of op2)))

+

+

+

+ (qe bcc :u (list tr1 tr2)

+ :arg (cadddr lap)

+ :arg2 :eq )))

+ ((:eq :neq :fix=)

+ (if* (not (eq (index-p op1) (index-p op2)))

+ then (error "non matching operands indexwise in: ~s" lap))

+ (qe bcc :u (list (get-treg-of op1)

+ (get-treg-of op2))

+ :arg (cadddr lap)

+ :arg2 (cdr (assoc opcode '((:eq . :eq)

+ (:neq . :ne))

+ :test #'eq))))

+ (:izerop

+ (qe bcc :u (list (get-treg-of op1)

+ *zero-treg*)

+ :arg (caddr lap)

+ :arg2 :eq))

+ (:std-instance-p

+ (let ((treg (get-treg-of op1))

+ (tempreg (new-reg))

+ (temp2reg (new-reg))

+ (offsetreg (new-reg))

+ (nope (pc-genlab)))

+ (qe typecheck :u (list treg)

+ :arg nope

+ :arg2 '(not structure))

+ (qe const :arg 'pcl::std-instance :d (list tempreg))

+ (qe const :arg (mdparam 'md-svector-data0-adj)

+ :d (list offsetreg))

+ (qe ref :u (list treg offsetreg)

+ :d (list temp2reg)

+ :arg :long)

+ (qe bcc :arg2 :eq :u (list tempreg temp2reg)

+ :arg (caddr lap))

+ (qe label :arg nope)))

+

+ (:fsc-instance-p

+ (let ((treg (get-treg-of op1))

+ (nope (pc-genlab))

+ (offsetreg (new-reg))

+ (tempreg (new-reg))

+ (checkreg (new-reg)))

+ (qe typecheck :u (list treg)

+ :arg nope

+ :arg2 '(not compiled-function))

+ (qe const :arg (mdparam 'md-function-flags-adj)

+ :d (list offsetreg))

+ (qe ref :u (list treg offsetreg) :d (list tempreg)

+ :arg :ubyte)

+ (qe const :arg pcl::funcallable-instance-flag-bit

+ :d (list checkreg))

+ (qe bcc :u (list checkreg tempreg)

+ :arg (caddr lap)

+ :arg2 :bit-and)

+ (qe label :arg nope)))

+ (:built-in-instance-p

+ ; always true

+ (qe bra :arg (caddr lap)))

+ (:jmp

+ (qe tail-funcall :u (list *nargs-treg* (get-treg-of op1))))

+ (:structure-instance-p

+ ; always true

+ (qe bra :arg (caddr lap)))

+

+ (:return

+ (let (op-treg)

+ (if* (index-p op1)

+ then ; convert to lisp before returning

+ (let ((shiftamt (new-reg)))

+ (setq op-treg (new-reg))

+ (qe const :arg 1 :d (list shiftamt))

+ (qe lsl :u (list (get-treg-of op1) shiftamt)

+ :d (list op-treg)))

+ else (setq op-treg (get-treg-of op1)))

+

+ (qe move :u (list op-treg) :d *mv-treg-target*)

+ (qe return :u *mv-treg-target*)))

+

+ (:go

+ (qe bra :arg (cadr lap)))

+

+ (:label

+ (qe label :arg (cadr lap)))

+

+

+

+ (t (warn "ignoring ~s" lap)))))))

+

+

+(defun insert-closure-vals (function closure-vals)

+ ;; build a fucntion from the lap and insert

+ (let ((newfun (sys::copy-function function)))

+ (setf (excl::fn_closure newfun) (list (apply 'vector closure-vals)))

+ newfun))

+

+

+

+; test case:

+; (pcl::defclass foo () (a b c))

+; (pcl::defmethod barx ((a foo) b c) a )

+; (apply 'pcl::excl-lap-closure-generator pcl::*tcase*)

+;

+; to turn it on

+

+(if* (not (and (boundp 'user::noquad)

+ (symbol-value 'user::noquad)))

+ then (setq pcl::*make-lap-closure-generator*

+ 'pcl::excl-lap-closure-generator))

+

+

+

+

+

+

+

diff --git a/gcl/pcl/impl/gcl/README b/gcl/pcl/impl/gcl/README
new file mode 100644
index 000000000..7948b335a
--- /dev/null
+++ b/gcl/pcl/impl/gcl/README

@@ -0,0 +1,14 @@

+Includes changes for gcl version 2.0 by W. Schelter

+

+

+To compile

+

+ln -s impl/gcl/makefile.gcl makefile.gcl

+ln -s impl/gcl/sys-package.lisp sys-package.lisp

+ln -s impl/gcl/sys-proclaim.lisp sys-proclaim.lisp

+make -f makefile.gcl compile

+

+Then to make saved version

+

+make -f makefile.gcl saved_pcl

+

diff --git a/gcl/pcl/impl/gcl/gcl-low.lisp b/gcl/pcl/impl/gcl/gcl-low.lisp
new file mode 100644
index 000000000..66337d4a0
--- /dev/null
+++ b/gcl/pcl/impl/gcl/gcl-low.lisp

@@ -0,0 +1,309 @@

+(in-package "SI")

+(export '(%structure-name

+ %compiled-function-name

+ %set-compiled-function-name))

+(in-package 'pcl)

+(eval-when (compile eval load)

+(setq *EVAL-WHEN-COMPILE* t)

+)

+

+(defmacro memq (item list) `(member ,item ,list :test #'eq))

+(defmacro assq (item list) `(assoc ,item ,list :test #'eq))

+(defmacro posq (item list) `(position ,item ,list :test #'eq))

+

+(defmacro dotimes ((var form &optional (val nil)) &rest body &environment env)

+ (multiple-value-bind (doc decls bod)

+ (extract-declarations body env)

+ (declare (ignore doc))

+ (let ((limit (gensym))

+ (label (gensym)))

+ `(let ((,limit ,form)

+ (,var 0))

+ (declare (fixnum ,limit ,var))

+ ,@decls

+ (block nil

+ (tagbody

+ ,label

+ (when (>= ,var ,limit) (return-from nil ,val))

+ ,@bod

+ (setq ,var (the fixnum (1+ ,var)))

+ (go ,label)))))))

+

+(defun printing-random-thing-internal (thing stream)

+ (format stream "~O" (si:address thing)))

+

+(eval-when (compile load eval)

+(pushnew :turbo-closure *features*)

+(pushnew :turbo-closure-env-size *features*))

+)

+

+(defmacro %svref (vector index)

+ `(svref (the simple-vector ,vector) (the fixnum ,index)))

+

+(defsetf %svref (vector index) (new-value)

+ `(setf (svref (the simple-vector ,vector) (the fixnum ,index))

+ ,new-value))

+

+(si::freeze-defstruct 'pcl::std-instance)

+

+(si::freeze-defstruct 'method-call)

+(si::freeze-defstruct 'fast-method-call)

+

+(defvar *pcl-funcall* `(lambda (loc)

+ (compiler::wt-nl

+ "{object _funobj = " loc ";"

+ "if(type_of(_funobj)==t_cclosure && (_funobj->cc.cc_turbo))

+ (*(_funobj->cc.cc_self))(_funobj->cc.cc_turbo);

+ else if (type_of(_funobj)==t_cfun) (*(_funobj->cc.cc_self))();

+ else super_funcall_no_event(_funobj);}")))

+

+(setq compiler::*super-funcall* *pcl-funcall*)

+

+(defmacro fmc-funcall (fn pv-cell next-method-call &rest args)

+ `(funcall ,fn ,pv-cell ,next-method-call ,@args))

+

+(defun pcl::proclaim-defmethod (x y) y

+ (and (symbolp x)

+ (setf (get x 'compiler::proclaimed-closure ) t)))

+

+

+

+;#+turbo-closure-env-size

+(clines "

+static

+object cclosure_env_nthcdr (n,cc)

+int n; object cc;

+{ object env,*turbo;

+ if(n<0)return Cnil;

+ if(type_of(cc)!=t_cclosure)return Cnil;

+ if((turbo=cc->cc.cc_turbo)==NULL)

+ {env=cc->cc.cc_env;

+ while(n-->0)

+ {if(type_of(env)!=t_cons)return Cnil;

+ env=env->c.c_cdr;}

+ return env;}

+ else

+ {if(n>=fix(*(turbo-1)))return Cnil;

+ return turbo[n];}

+}")

+

+(defentry cclosure-env-nthcdr (int object) (object cclosure_env_nthcdr))

+;; This is the unsafe but fast version.

+(defentry %cclosure-env-nthcdr (int object) (object cclosure_env_nthcdr))

+

+(eval-when (compile eval load)

+(defparameter *gcl-function-inlines*

+ '( (%fboundp (t) compiler::boolean nil nil "(#0)->s.s_gfdef!=OBJNULL")

+ (%symbol-function (t) t nil nil "(#0)->s.s_gfdef")

+ (si:%structure-name (t) t nil nil "(#0)->str.str_def->str.str_self[0]")

+ (si:%compiled-function-name (t) t nil nil "(#0)->cf.cf_name")

+ (si:%set-compiled-function-name (t t) t t nil "((#0)->cf.cf_name)=(#1)")

+ (cclosurep (t) compiler::boolean nil nil "type_of(#0)==t_cclosure")

+ (sfun-p (t) compiler::boolean nil nil "type_of(#0)==t_sfun")

+ (%cclosure-env (t) t nil nil "(#0)->cc.cc_env")

+ (%set-cclosure-env (t t) t t nil "((#0)->cc.cc_env)=(#1)")

+ #+turbo-closure

+ (%cclosure-env-nthcdr (fixnum t) t nil nil "(#1)->cc.cc_turbo[#0]")

+

+ (logxor (fixnum fixnum) fixnum nil nil "((#0) ^ (#1))")))

+

+(defun make-function-inline (inline)

+ (setf (get (car inline) 'compiler::inline-always)

+ (list (if (fboundp 'compiler::flags)

+ (let ((opt (cdr inline)))

+ (list (first opt) (second opt)

+ (logior (if (fourth opt) 1 0) ; allocates-new-storage

+ (if (third opt) 2 0) ; side-effect

+ (if nil 4 0) ; constantp

+ (if (eq (car inline) 'logxor)

+ 8 0)) ;result type from args

+ (fifth opt)))

+ (cdr inline)))))

+)

+

+

+(defmacro define-inlines ()

+ `(progn

+ ,@(mapcan #'(lambda (inline)

+ (let ((name (intern (format nil "~S inline" (car inline))))

+ (vars (mapcar #'(lambda (type)

+ (declare (ignore type))

+ (gensym))

+ (cadr inline))))

+ `((eval-when (compile eval load)

+ (make-function-inline

+ ',(cons name (cdr inline))))

+ ,@(when (or (every #'(lambda (type) (eq type 't))

+ (cadr inline))

+ (char= #\% (aref (symbol-name (car inline)) 0)))

+ `((defun ,(car inline) ,vars

+ ,@(mapcan #'(lambda (var var-type)

+ (unless (eq var-type 't)

+ `((declare (type ,var-type ,var)))))

+ vars (cadr inline))

+ (the ,(caddr inline) (,name ,@vars)))

+ (make-function-inline ',inline))))))

+ *gcl-function-inlines*)))

+

+(define-inlines)

+

+(defsetf si:%compiled-function-name si:%set-compiled-function-name)

+(defsetf %cclosure-env %set-cclosure-env)

+

+(defun set-function-name-1 (fn new-name ignore)

+ (declare (ignore ignore))

+ (cond ((compiled-function-p fn)

+ (si::turbo-closure fn)

+ (when (symbolp new-name) (pcl::proclaim-defmethod new-name nil))

+ (setf (si:%compiled-function-name fn) new-name))

+ ((and (listp fn)

+ (eq (car fn) 'lambda-block))

+ (setf (cadr fn) new-name))

+ ((and (listp fn)

+ (eq (car fn) 'lambda))

+ (setf (car fn) 'lambda-block

+ (cdr fn) (cons new-name (cdr fn)))))

+ fn)

+

+

+(clines "

+

+

+

+object fSuse_fast_links();

+static

+object set_cclosure (result_cc,value_cc,available_size)

+ object result_cc,value_cc; int available_size;

+{

+ object result_env_tail,value_env_tail; int i;

+

+ /* If we are currently using fast linking, */

+ /* make sure to remove the link for result_cc. */

+ (VFUN_NARGS=2,fSuse_fast_links(sLnil,result_cc));

+

+/* use_fast_links(3,Cnil,result_cc); */

+

+ result_env_tail=result_cc->cc.cc_env;

+ value_env_tail=value_cc->cc.cc_env;

+ for(i=available_size;

+ result_env_tail!=Cnil && i>0;

+ result_env_tail=CMPcdr(result_env_tail), value_env_tail=CMPcdr(value_env_tail))

+ CMPcar(result_env_tail)=CMPcar(value_env_tail), i--;

+ result_cc->cc.cc_self=value_cc->cc.cc_self;

+ result_cc->cc.cc_data=value_cc->cc.cc_data;

+

+

+ return result_cc;

+}")

+

+(defentry %set-cclosure (object object int) (object set_cclosure))

+

+

+(defun structure-functions-exist-p ()

+ t)

+

+(si:define-compiler-macro structure-instance-p (x)

+ (once-only (x)

+ `(and (si:structurep ,x)

+ (not (eq (si:%structure-name ,x) 'std-instance)))))

+

+(defun structure-type (x)

+ (and (si:structurep x)

+ (si:%structure-name x)))

+

+(si:define-compiler-macro structure-type (x)

+ (once-only (x)

+ `(and (si:structurep ,x)

+ (si:%structure-name ,x))))

+

+(defun structure-type-p (type)

+ (or (not (null (gethash type *structure-table*)))

+ (let (#+akcl(s-data nil))

+ (and (symbolp type)

+ (setq s-data (get type 'si::s-data))

+

+ (null (si::s-data-type s-data)

+ )))))

+

+

+(defun structure-type-included-type-name (type)

+ (or (car (gethash type *structure-table*))

+ (si::s-data-included (get type 'si::s-data))

+ ))

+

+(defun structure-type-internal-slotds (type)

+ (si::s-data-slot-descriptions (get type 'si::s-data))

+ )

+

+(defun structure-type-slot-description-list (type)

+ (or (cdr (gethash type *structure-table*))

+ (mapcan #'(lambda (slotd)

+ (when (and slotd (car slotd))

+ (let ((offset (fifth slotd)))

+ (let ((reader #'(lambda (x)

+ (si:structure-ref1 x offset)

+ ))

+ (writer #'(lambda (v x)

+ (si:structure-set x type offset v))))

+ #+turbo-closure (si:turbo-closure reader)

+ #+turbo-closure (si:turbo-closure writer)

+ (let* ((reader-sym

+ (let ((*package* *the-pcl-package*))

+ (intern (format nil "~s SLOT~D" type offset))))

+ (writer-sym (get-setf-function-name reader-sym))

+ (slot-name (first slotd))

+ (read-only-p (fourth slotd)))

+ (setf (symbol-function reader-sym) reader)

+ (setf (symbol-function writer-sym) writer)

+ (do-standard-defsetf-1 reader-sym)

+ (list (list slot-name

+ reader-sym

+ (and (not read-only-p) writer))))))))

+ (let ((slotds (structure-type-internal-slotds type))

+ (inc (structure-type-included-type-name type)))

+ (if inc

+ (nthcdr (length (structure-type-internal-slotds inc))

+ slotds)

+ slotds)))))

+

+(defun structure-slotd-name (slotd)

+ (first slotd))

+

+(defun structure-slotd-accessor-symbol (slotd)

+ (second slotd))

+

+(defun structure-slotd-writer-function (slotd)

+ (third slotd))

+

+(defun renew-sys-files()

+ ;; packages:

+ (compiler::get-packages "sys-package.lisp")

+ (with-open-file (st "sys-package.lisp"

+ :direction :output

+ :if-exists :append)

+ (format st "(lisp::in-package \"SI\")

+(export '(%structure-name

+ %compiled-function-name

+ %set-compiled-function-name))

+(in-package \"PCL\")

+"))

+

+ ;; proclaims

+ (compiler::make-all-proclaims "*.fn")

+ (with-open-file (st "sys-proclaim.lisp"

+ :direction :output

+ :if-exists :append)

+ (format st "~%(IN-PACKAGE \"PCL\")~%")

+ (print

+ `(dolist (v ',

+

+ (sloop::sloop for v in-package "PCL"

+ when (get v 'compiler::proclaimed-closure)

+ collect v))

+ (setf (get v 'compiler::proclaimed-closure) t))

+ st)

+ (format st "~%")

+))

+

+

+

diff --git a/gcl/pcl/impl/gcl/gcl-patches.lisp b/gcl/pcl/impl/gcl/gcl-patches.lisp
new file mode 100644
index 000000000..9e666a6c1
--- /dev/null
+++ b/gcl/pcl/impl/gcl/gcl-patches.lisp

@@ -0,0 +1,225 @@

+;;;-*-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 "COMPILER")

+

+;; do evaluation of top level forms at compile time.

+(eval-when (compile eval load)

+(setq *EVAL-WHEN-COMPILE* t)

+)

+

+(pushnew :turbo-closure *features*)

+(pushnew :turbo-closure-env-size *features*)

+;; patch around compiler bug.

+

+

+(let ((rset "int Rset;

+"))

+ (unless (search rset compiler::*cmpinclude-string*)

+ (setq compiler::*cmpinclude-string*

+ (concatenate 'string rset compiler::*cmpinclude-string*))))

+

+(when (get 'si::basic-wrapper 'si::s-data)

+ (pushnew :new-kcl-wrapper *features*)

+ (pushnew :structure-wrapper *features*))

+

+

+

+

+#+akcl

+(progn

+

+(unless (fboundp 'real-c2lambda-expr-with-key)

+ (setf (symbol-function 'real-c2lambda-expr-with-key)

+ (symbol-function 'c2lambda-expr-with-key)))

+

+(defun c2lambda-expr-with-key (lambda-list body)

+ (declare (special *sup-used*))

+ (setq *sup-used* t)

+ (real-c2lambda-expr-with-key lambda-list body))

+

+

+;There is a bug in the implementation of *print-circle* that

+;causes some akcl debugging commands (including :bt and :bl)

+;to cause the following error when PCL is being used:

+;Unrecoverable error: value stack overflow.

+

+;When a CLOS object is printed, travel_push_object ends up

+;traversing almost the whole class structure, thereby overflowing

+;the value-stack.

+

+;from lsp/debug.lsp.

+;*print-circle* is badly implemented in kcl.

+;it has two separate problems that should be fixed:

+; 1. it traverses the printed object putting all objects found

+; on the value stack (rather than in a hash table or some

+; other structure; this is a problem because the size of the value stack

+; is fixed, and a potentially unbounded number of objects

+; need to be traversed), and

+; 2. it blindly traverses all slots of any

+; kind of structure including std-object structures.

+; This is safe, but not always necessary, and is very time-consuming

+; for CLOS objects (because it will always traverse every class).

+

+;For now, avoid using *print-circle* T when it will cause problems.

+

+

+

+(eval-when (compile eval )

+(defmacro si::f (op &rest args)

+ `(the fixnum (,op ,@ (mapcar #'(lambda (x) `(the fixnum ,x)) args) )))

+

+(defmacro si::fb (op &rest args)

+ `(,op ,@ (mapcar #'(lambda (x) `(the fixnum ,x)) args) ))

+)

+

+(defun si::display-env (n env)

+ (do ((v (reverse env) (cdr v)))

+ ((or (not (consp v)) (si::fb > (fill-pointer si::*display-string*) n)))

+ (or (and (consp (car v))

+ (listp (cdar v)))

+ (return))

+ (let ((*print-circle* (can-use-print-circle-p (cadar v))))

+ (format si::*display-string* "~s=~s~@[,~]" (caar v) (cadar v) (cdr v)))))

+

+(defun si::display-compiled-env ( plength ihs &aux

+ (base (si::ihs-vs ihs))

+ (end (min (si::ihs-vs (1+ ihs)) (si::vs-top))))

+ (format si::*display-string* "")

+ (do ((i base )

+ (v (get (si::ihs-fname ihs) 'si::debug) (cdr v)))

+ ((or (si::fb >= i end)(si::fb > (fill-pointer si::*display-string*) plength)))

+ (let ((*print-circle* (can-use-print-circle-p (si::vs i))))

+ (format si::*display-string* "~a~@[~d~]=~s~@[,~]"

+ (or (car v) 'si::loc) (if (not (car v)) (si::f - i base)) (si::vs i)

+ (si::fb < (setq i (si::f + i 1)) end)))))

+

+(clines "#define objnull_p(x) ((x==OBJNULL)?Ct:Cnil)")

+(defentry objnull-p (object) (object "objnull_p"))

+

+(defun can-use-print-circle-p (x)

+ (catch 'can-use-print-circle-p

+ (can-use-print-circle-p1 x nil)))

+

+(defun can-use-print-circle-p1 (x so-far)

+ (and (not (objnull-p x)) ; because of deficiencies in the compiler, maybe?

+ (if (member x so-far)

+ (throw 'can-use-print-circle-p t)

+ (let ((so-far (cons x so-far)))

+ (flet ((can-use-print-circle-p (x)

+ (can-use-print-circle-p1 x so-far)))

+ (typecase x

+ (vector (or (not (eq 't (array-element-type x)))

+ (every #'can-use-print-circle-p x)))

+ (cons (and (can-use-print-circle-p (car x))

+ (can-use-print-circle-p (cdr x))))

+ (array (or (not (eq 't (array-element-type x)))

+ (let* ((rank (array-rank x))

+ (dimensions (make-list rank)))

+ (dotimes (i rank)

+ (setf (nth i dimensions) (array-dimension x i)))

+ (or (member 0 dimensions)

+ (do ((cursor (make-list rank :initial-element 0)))

+ (nil)

+ (declare (:dynamic-extent cursor))

+ (unless (can-use-print-circle-p

+ (apply #'aref x cursor))

+ (return nil))

+ (when (si::increment-cursor cursor dimensions)

+ (return t)))))))

+ (t (or (not (si:structurep x))

+ (let* ((def (si:structure-def x))

+ (name (si::s-data-name def))

+ (len (si::s-data-length def))

+ (pfun (si::s-data-print-function def)))

+ (and (null pfun)

+ (dotimes (i len t)

+ (unless (can-use-print-circle-p

+ (si:structure-ref x name i))

+ (return nil)))))))))))))

+

+(defun si::apply-display-fun (display-fun n lis)

+ (let ((*print-length* si::*debug-print-level*)

+ (*print-level* si::*debug-print-level*)

+ (*print-pretty* nil)

+ (*PRINT-CASE* :downcase)

+ (*print-circle* nil)

+ )

+ (setf (fill-pointer si::*display-string*) 0)

+ (format si::*display-string* "{")

+ (funcall display-fun n lis)

+ (when (si::fb > (fill-pointer si::*display-string*) n)

+ (setf (fill-pointer si::*display-string*) n)

+ (format si::*display-string* "..."))

+

+ (format si::*display-string* "}")

+ )

+ si::*display-string*

+ )

+

+;The old definition of this had a bug:

+;sometimes it returned without calling mv-values.

+(defun si::next-stack-frame (ihs &aux line-info li i k na)

+ (cond ((si::fb < ihs si::*ihs-base*)

+ (si::mv-values nil nil nil nil nil))

+ ((let (fun)

+ ;; next lower visible ihs

+ (si::mv-setq (fun i) (si::get-next-visible-fun ihs))

+ (setq na fun)

+ (cond ((and (setq line-info (get fun 'si::line-info))

+ (do ((j (si::f + ihs 1) (si::f - j 1))

+ (form ))

+ ((<= j i) nil)

+ (setq form (si::ihs-fun j))

+ (cond ((setq li (si::get-line-of-form form line-info))

+ (return-from si::next-stack-frame

+ (si::mv-values

+ i fun li

+ ;; filename

+ (car (aref line-info 0))

+ ;;environment

+ (list (si::vs (setq k (si::ihs-vs j)))

+ (si::vs (1+ k))

+ (si::vs (+ k 2)))))))))))))

+ ((and (not (special-form-p na))

+ (not (get na 'si::dbl-invisible))

+ (fboundp na))

+ (si::mv-values i na nil nil

+ (if (si::ihs-not-interpreted-env i)

+ nil

+ (let ((i (si::ihs-vs i)))

+ (list (si::vs i) (si::vs (1+ i)) (si::vs (si::f + i 2)))))))

+ (t (si::mv-values nil nil nil nil nil))))

+)

+

+

+

+

+

+

+

diff --git a/gcl/pcl/impl/gcl/makefile.gcl b/gcl/pcl/impl/gcl/makefile.gcl
new file mode 100644
index 000000000..46a50beb5
--- /dev/null
+++ b/gcl/pcl/impl/gcl/makefile.gcl

@@ -0,0 +1,38 @@

+# makefile for making pcl -- W. Schelter.

+

+# Directions:

+# make -f makefile.gcl compile

+# make -f makefile.gcl saved_pcl

+

+

+LISP=gcl

+

+

+SETUP='(load "sys-package.lisp")' \

+ '(setq *features* (delete (quote kcl) *features*))'\

+ '(load "defsys.lisp")(push (quote kcl) *features*)' \

+ '(setq pcl::*default-pathname-extensions* (cons "lisp" "o"))' \

+ '(setq pcl::*pathname-extensions* (cons "lisp" "o"))' \

+ '(load "sys-proclaim.lisp")(compiler::emit-fn t)'

+

+compile:

+ echo ${SETUP} '(pcl::compile-pcl)' | ${LISP}

+

+saved_pcl:

+ echo ${SETUP} '(pcl::load-pcl)(si::save-system "saved_pcl")' | ${LISP}

+

+

+# remake the sys-package.lisp and sys-proclaim.lisp files

+# Those files may be empty on a first build.

+remake-sys-files:

+ echo ${SETUP} '(pcl::load-pcl)(in-package "PCL")(renew-sys-files)' | ${LISP}

+ cp sys-proclaim.lisp xxx

+ cat xxx | sed -e "s/COMPILER::CMP-ANON//g" > sys-proclaim.lisp

+ rm xxx

+

+

+tar:

+ make -f makefile.gcl tar1 DIR=`pwd`

+

+tar1:

+ (cd .. ; tar cvf - `basename ${DIR}` | gzip -c > `basename ${DIR}`.tgz)

diff --git a/gcl/pcl/impl/gcl/sys-package.lisp b/gcl/pcl/impl/gcl/sys-package.lisp
new file mode 100644
index 000000000..c04430e8c
--- /dev/null
+++ b/gcl/pcl/impl/gcl/sys-package.lisp

@@ -0,0 +1,149 @@

+

+

+;;; Definitions for package SLOT-ACCESSOR-NAME of type ESTABLISH

+(LISP::IN-PACKAGE "SLOT-ACCESSOR-NAME" :USE LISP::NIL :NICKNAMES

+ '("S-A-N"))

+

+;;; Definitions for package PCL of type ESTABLISH

+(LISP::IN-PACKAGE "PCL" :USE LISP::NIL)

+

+;;; Definitions for package ITERATE of type ESTABLISH

+(LISP::IN-PACKAGE "ITERATE" :USE LISP::NIL)

+

+;;; Definitions for package WALKER of type ESTABLISH

+(LISP::IN-PACKAGE "WALKER" :USE LISP::NIL)

+

+;;; Definitions for package SLOT-ACCESSOR-NAME of type EXPORT

+(LISP::IN-PACKAGE "SLOT-ACCESSOR-NAME" :USE 'LISP::NIL :NICKNAMES

+ '("S-A-N"))

+(LISP::IMPORT 'LISP::NIL)

+(LISP::EXPORT 'LISP::NIL)

+

+;;; Definitions for package PCL of type EXPORT

+(LISP::IN-PACKAGE "PCL" :USE '("LISP" "ITERATE" "WALKER"))

+(LISP::IMPORT 'LISP::NIL)

+(LISP::EXPORT

+ '(PCL::CLASS-PRECEDENCE-LIST PCL::SLOT-DEFINITION

+ PCL::COMPUTE-APPLICABLE-METHODS-USING-CLASSES

+ PCL::SLOT-DEFINITION-WRITERS PCL::CLASS-OF

+ PCL::NO-APPLICABLE-METHOD PCL::STANDARD-WRITER-METHOD

+ PCL::ENSURE-CLASS-USING-CLASS PCL::ENSURE-GENERIC-FUNCTION

+ PCL::FIND-METHOD-COMBINATION PCL::UPDATE-DEPENDENT

+ PCL::MAP-DEPENDENTS PCL::SLOT-MISSING PCL::SPECIALIZER

+ PCL::CALL-NEXT-METHOD PCL::ENSURE-GENERIC-FUNCTION-USING-CLASS

+ PCL::SLOT-MAKUNBOUND-USING-CLASS PCL::MAKE-INSTANCES-OBSOLETE

+ PCL::INTERN-EQL-SPECIALIZER PCL::REMOVE-DIRECT-SUBCLASS

+ PCL::METHOD-GENERIC-FUNCTION PCL::METHOD-QUALIFIERS

+ PCL::FUNCALLABLE-STANDARD-CLASS PCL::EXTRACT-LAMBDA-LIST

+ PCL::STANDARD-CLASS PCL::PRINT-OBJECT PCL::STRUCTURE-CLASS

+ PCL::COMPUTE-EFFECTIVE-SLOT-DEFINITION

+ PCL::GENERIC-FUNCTION-DECLARATIONS PCL::MAKE-INSTANCE

+ PCL::METHOD-LAMBDA-LIST PCL::DEFGENERIC

+ PCL::REMOVE-DIRECT-METHOD PCL::STANDARD-DIRECT-SLOT-DEFINITION

+ PCL::GENERIC-FUNCTION-METHODS PCL::VALIDATE-SUPERCLASS

+ PCL::REINITIALIZE-INSTANCE PCL::STANDARD-METHOD

+ PCL::STANDARD-ACCESSOR-METHOD

+ PCL::FUNCALLABLE-STANDARD-INSTANCE PCL::FUNCTION-KEYWORDS

+ PCL::STANDARD PCL::FIND-METHOD PCL::EXTRACT-SPECIALIZER-NAMES

+ PCL::INITIALIZE-INSTANCE PCL::GENERIC-FLET PCL::SLOT-UNBOUND

+ PCL::STANDARD-INSTANCE PCL::SLOT-DEFINITION-TYPE

+ PCL::COMPUTE-EFFECTIVE-METHOD PCL::ALLOCATE-INSTANCE

+ PCL::SYMBOL-MACROLET PCL::GENERIC-FUNCTION

+ PCL::GENERIC-FUNCTION-METHOD-COMBINATION

+ PCL::SPECIALIZER-DIRECT-METHODS PCL::ADD-DIRECT-SUBCLASS

+ PCL::WRITER-METHOD-CLASS PCL::SLOT-DEFINITION-INITARGS

+ PCL::METHOD-SPECIALIZERS PCL::GENERIC-FUNCTION-METHOD-CLASS

+ PCL::ADD-METHOD PCL::WITH-ACCESSORS

+ PCL::SLOT-DEFINITION-ALLOCATION

+ PCL::SLOT-DEFINITION-INITFUNCTION

+ PCL::SLOT-DEFINITION-LOCATION PCL::ADD-DIRECT-METHOD

+ PCL::SLOT-BOUNDP PCL::EQL-SPECIALIZER PCL::SHARED-INITIALIZE

+ PCL::STANDARD-GENERIC-FUNCTION

+ PCL::ACCESSOR-METHOD-SLOT-DEFINITION

+ PCL::SLOT-BOUNDP-USING-CLASS PCL::ADD-DEPENDENT

+ PCL::SPECIALIZER-DIRECT-GENERIC-FUNCTION

+ PCL::WITH-ADDED-METHODS PCL::COMPUTE-CLASS-PRECEDENCE-LIST

+ PCL::REMOVE-DEPENDENT PCL::NEXT-METHOD-P

+ PCL::GENERIC-FUNCTION-NAME PCL::SLOT-VALUE

+ PCL::EFFECTIVE-SLOT-DEFINITION PCL::CLASS-FINALIZED-P

+ PCL::COMPUTE-DISCRIMINATING-FUNCTION PCL::STANDARD-OBJECT

+ PCL::CLASS-DEFAULT-INITARGS PCL::CLASS-DIRECT-SLOTS

+ PCL::FUNCALLABLE-STANDARD-INSTANCE-ACCESS PCL::BUILT-IN-CLASS

+ PCL::NO-NEXT-METHOD PCL::SLOT-MAKUNBOUND

+ PCL::STANDARD-READER-METHOD PCL::GENERIC-FUNCTION-LAMBDA-LIST

+ PCL::GENERIC-FUNCTION-ARGUMENT-PRECEDENCE-ORDER

+ PCL::INVALID-METHOD-ERROR PCL::METHOD-COMBINATION-ERROR

+ PCL::SLOT-EXISTS-P PCL::FINALIZE-INHERITANCE

+ PCL::SLOT-DEFINITION-NAME

+ PCL::STANDARD-EFFECTIVE-SLOT-DEFINITION PCL::COMPUTE-SLOTS

+ PCL::CLASS-SLOTS PCL::EFFECTIVE-SLOT-DEFINITION-CLASS

+ PCL::STANDARD-INSTANCE-ACCESS PCL::WITH-SLOTS

+ PCL::DIRECT-SLOT-DEFINITION PCL::DEFINE-METHOD-COMBINATION

+ PCL::MAKE-METHOD-LAMBDA PCL::ENSURE-CLASS

+ PCL::DIRECT-SLOT-DEFINITION-CLASS PCL::METHOD-FUNCTION

+ PCL::STANDARD-SLOT-DEFINITION PCL::CHANGE-CLASS PCL::DEFMETHOD

+ PCL::UPDATE-INSTANCE-FOR-DIFFERENT-CLASS

+ PCL::UPDATE-INSTANCE-FOR-REDEFINED-CLASS

+ PCL::FORWARD-REFERENCED-CLASS PCL::SLOT-DEFINITION-INITFORM

+ PCL::REMOVE-METHOD PCL::READER-METHOD-CLASS PCL::CALL-METHOD

+ PCL::CLASS-PROTOTYPE PCL::CLASS-NAME PCL::FIND-CLASS

+ PCL::DEFCLASS PCL::COMPUTE-APPLICABLE-METHODS

+ PCL::SLOT-VALUE-USING-CLASS PCL::METHOD-COMBINATION

+ PCL::EQL-SPECIALIZER-INSTANCE PCL::GENERIC-LABELS PCL::METHOD

+ PCL::SLOT-DEFINITION-READERS

+ PCL::CLASS-DIRECT-DEFAULT-INITARGS

+ PCL::CLASS-DIRECT-SUBCLASSES PCL::CLASS-DIRECT-SUPERCLASSES

+ PCL::SET-FUNCALLABLE-INSTANCE-FUNCTION))

+

+;;; Definitions for package ITERATE of type EXPORT

+(LISP::IN-PACKAGE "ITERATE" :USE '("WALKER" "LISP"))

+(LISP::IMPORT 'LISP::NIL)

+(LISP::EXPORT

+ '(ITERATE::SUMMING ITERATE::MINIMIZING ITERATE::PLIST-ELEMENTS

+ ITERATE::ITERATE* ITERATE::MAXIMIZING ITERATE::LIST-TAILS

+ ITERATE::*ITERATE-WARNINGS* ITERATE::GATHERING

+ ITERATE::EACHTIME ITERATE::ELEMENTS ITERATE::GATHER

+ ITERATE::LIST-ELEMENTS ITERATE::WHILE ITERATE::ITERATE

+ ITERATE::UNTIL ITERATE::JOINING ITERATE::COLLECTING

+ ITERATE::WITH-GATHERING ITERATE::INTERVAL))

+

+;;; Definitions for package WALKER of type EXPORT

+(LISP::IN-PACKAGE "WALKER" :USE '("LISP"))

+(LISP::IMPORT 'LISP::NIL)

+(LISP::EXPORT

+ '(WALKER::DEFINE-WALKER-TEMPLATE WALKER::*VARIABLE-DECLARATIONS*

+ WALKER::NESTED-WALK-FORM WALKER::VARIABLE-DECLARATION

+ WALKER::WALK-FORM-EXPAND-MACROS-P WALKER::VARIABLE-LEXICAL-P

+ WALKER::VARIABLE-SPECIAL-P WALKER::WALK-FORM

+ WALKER::MACROEXPAND-ALL WALKER::VARIABLE-GLOBALLY-SPECIAL-P))

+

+;;; Definitions for package SLOT-ACCESSOR-NAME of type SHADOW

+(LISP::IN-PACKAGE "SLOT-ACCESSOR-NAME")

+(LISP::SHADOW 'LISP::NIL)

+(LISP::SHADOWING-IMPORT 'LISP::NIL)

+(LISP::IMPORT 'LISP::NIL)

+

+;;; Definitions for package PCL of type SHADOW

+(LISP::IN-PACKAGE "PCL")

+(LISP::SHADOW '(PCL::DOTIMES PCL::DOCUMENTATION))

+(LISP::SHADOWING-IMPORT 'LISP::NIL)

+(LISP::IMPORT

+ '(SYSTEM::STRUCTURE-REF SYSTEM::STRUCTURE-DEF SYSTEM::STRUCTUREP))

+

+;;; Definitions for package ITERATE of type SHADOW

+(LISP::IN-PACKAGE "ITERATE")

+(LISP::SHADOW 'LISP::NIL)

+(LISP::SHADOWING-IMPORT 'LISP::NIL)

+(LISP::IMPORT 'LISP::NIL)

+

+;;; Definitions for package WALKER of type SHADOW

+(LISP::IN-PACKAGE "WALKER")

+(LISP::SHADOW 'LISP::NIL)

+(LISP::SHADOWING-IMPORT 'LISP::NIL)

+(LISP::IMPORT 'LISP::NIL)

+

+(in-package 'SI)

+(export '(%structure-name

+ %compiled-function-name

+ %set-compiled-function-name))

+(in-package 'pcl)

diff --git a/gcl/pcl/impl/gcl/sys-proclaim.lisp b/gcl/pcl/impl/gcl/sys-proclaim.lisp
new file mode 100644
index 000000000..26f869897
--- /dev/null
+++ b/gcl/pcl/impl/gcl/sys-proclaim.lisp

@@ -0,0 +1,1448 @@

+

+(IN-PACKAGE "PCL")

+(PROCLAIM

+ '(FTYPE (FUNCTION (T) FIXNUM) ONE-INDEX-LIMIT-FN

+ N-N-ACCESSORS-LIMIT-FN CHECKING-LIMIT-FN PV-CACHE-LIMIT-FN

+ ARG-INFO-NUMBER-REQUIRED DEFAULT-LIMIT-FN CACHE-COUNT

+ CACHING-LIMIT-FN PV-TABLE-PV-SIZE EARLY-CLASS-SIZE

+ CPD-COUNT FAST-INSTANCE-BOUNDP-INDEX))

+(PROCLAIM '(FTYPE (FUNCTION (T) FIELD-TYPE) CACHE-FIELD))

+(PROCLAIM

+ '(FTYPE (FUNCTION (T) FUNCTION) CACHE-LIMIT-FN METHOD-CALL-FUNCTION

+ FAST-METHOD-CALL-FUNCTION))

+(PROCLAIM '(FTYPE (FUNCTION (FIXNUM) T) POWER-OF-TWO-CEILING))

+(PROCLAIM

+ '(FTYPE (FUNCTION (T) LIST) CACHE-OVERFLOW PV-TABLE-SLOT-NAME-LISTS

+ PV-TABLE-CALL-LIST))

+(PROCLAIM '(FTYPE (FUNCTION (T) (MEMBER NIL T)) CACHE-VALUEP))

+(PROCLAIM '(FTYPE (FUNCTION (T) SIMPLE-VECTOR) CACHE-VECTOR))

+(PROCLAIM

+ '(FTYPE (FUNCTION (T) (VALUES T T)) MAKE-CLASS-PREDICATE-NAME

+ MAKE-KEYWORD))

+(PROCLAIM '(FTYPE (FUNCTION (FIXNUM T) T) %CCLOSURE-ENV-NTHCDR))

+(PROCLAIM

+ '(FTYPE (FUNCTION (FIXNUM FIXNUM T) FIXNUM)

+ COMPUTE-PRIMARY-CACHE-LOCATION))

+(PROCLAIM '(FTYPE (FUNCTION (T) (INTEGER 1 256)) CACHE-NKEYS))

+(PROCLAIM '(FTYPE (FUNCTION (T) (INTEGER 1 512)) CACHE-LINE-SIZE))

+(PROCLAIM '(FTYPE (FUNCTION (T) (OR CACHE NULL)) PV-TABLE-CACHE))

+(PROCLAIM

+ '(FTYPE (FUNCTION (T T T) *)

+ GET-OPTIMIZED-STD-SLOT-VALUE-USING-CLASS-METHOD-FUNCTION

+ ITERATE::WALK-GATHERING-BODY CACHE-MISS-VALUES

+ MAKE-OPTIMIZED-STD-READER-METHOD-FUNCTION

+ OPTIMIZE-SLOT-VALUE-BY-CLASS-P ACCESSOR-VALUES1

+ EMIT-READER/WRITER EMIT-ONE-OR-N-INDEX-READER/WRITER

+ GENERATING-LISP EMIT-READER/WRITER-FUNCTION

+ EMIT-ONE-OR-N-INDEX-READER/WRITER-FUNCTION

+ WALKER::WALK-LET-IF SET-SLOT-VALUE CONVERT-METHODS

+ |(FAST-METHOD METHOD-LAMBDA-LIST (TRACED-METHOD))|

+ SLOT-VALUE-USING-CLASS-DFUN SLOT-BOUNDP-USING-CLASS-DFUN

+ |(FAST-METHOD METHOD-SPECIALIZERS (TRACED-METHOD))|

+ CHECK-METHOD-ARG-INFO

+ |(FAST-METHOD METHOD-QUALIFIERS (TRACED-METHOD))|

+ LOAD-LONG-DEFCOMBIN MAKE-FINAL-N-N-ACCESSOR-DFUN

+ |(FAST-METHOD ACCESSOR-METHOD-SLOT-NAME (TRACED-METHOD))|

+ MAKE-FINAL-CACHING-DFUN MAKE-FINAL-CONSTANT-VALUE-DFUN

+ GET-CLASS-SLOT-VALUE-1 ACCESSOR-VALUES-INTERNAL

+ MAKE-OPTIMIZED-STD-WRITER-METHOD-FUNCTION

+ MAKE-OPTIMIZED-STD-BOUNDP-METHOD-FUNCTION

+ ITERATE::EXPAND-INTO-LET WALKER::WALK-FORM-INTERNAL

+ ITERATE::RENAME-VARIABLES CONSTANT-VALUE-MISS CACHING-MISS

+ |(FAST-METHOD COMPUTE-DISCRIMINATING-FUNCTION (STANDARD-GENERIC-FUNCTION))|

+ CHECKING-MISS GET-OPTIMIZED-STD-ACCESSOR-METHOD-FUNCTION

+ |(FAST-METHOD FUNCTION-KEYWORDS (STANDARD-METHOD))|

+ |(FAST-METHOD METHOD-PRETTY-ARGLIST (STANDARD-METHOD))|

+ |(FAST-METHOD CLASS-PROTOTYPE (STD-CLASS))|

+ |(FAST-METHOD CLASS-PROTOTYPE (STRUCTURE-CLASS))|

+ |(FAST-METHOD MAKE-INSTANCES-OBSOLETE (SYMBOL))|

+ |(FAST-METHOD METHOD-FUNCTION (STANDARD-METHOD))|

+ |(FAST-METHOD COMPUTE-DISCRIMINATING-FUNCTION-ARGLIST-INFO (STANDARD-GENERIC-FUNCTION))|))

+(PROCLAIM

+ '(FTYPE (FUNCTION (T T T T T) *)

+ |(FAST-METHOD COMPUTE-EFFECTIVE-METHOD (GENERIC-FUNCTION LONG-METHOD-COMBINATION T))|

+ |(FAST-METHOD UPDATE-INSTANCE-FOR-DIFFERENT-CLASS (STANDARD-OBJECT STANDARD-OBJECT))|

+ |(FAST-METHOD SHARED-INITIALIZE (SLOT-OBJECT T))|

+ COMPUTE-DISCRIMINATING-FUNCTION-ARGLIST-INFO-INTERNAL

+ ADD-METHOD-DECLARATIONS WALK-METHOD-LAMBDA

+ MAKE-TWO-CLASS-ACCESSOR-DFUN

+ |(FAST-METHOD (SETF SLOT-ACCESSOR-FUNCTION) (T EFFECTIVE-SLOT-DEFINITION T))|

+ |(FAST-METHOD SHARED-INITIALIZE :AFTER (CLASS-EQ-SPECIALIZER T))|

+ |(FAST-METHOD SHARED-INITIALIZE :AFTER (EQL-SPECIALIZER T))|

+ |(FAST-METHOD SHARED-INITIALIZE :BEFORE (CLASS T))|

+ |(FAST-METHOD (SETF DOCUMENTATION) (T STANDARD-SLOT-DEFINITION))|

+ |(FAST-METHOD ADD-READER-METHOD (SLOT-CLASS T T))|

+ |(FAST-METHOD ADD-WRITER-METHOD (SLOT-CLASS T T))|

+ |(FAST-METHOD ADD-BOUNDP-METHOD (SLOT-CLASS T T))|

+ |(FAST-METHOD (SETF CLASS-SLOT-VALUE) (T STD-CLASS T))|

+ |(FAST-METHOD SLOT-VALUE-USING-CLASS (STD-CLASS STANDARD-OBJECT STANDARD-EFFECTIVE-SLOT-DEFINITION))|

+ |(FAST-METHOD SLOT-VALUE-USING-CLASS (STRUCTURE-CLASS STRUCTURE-OBJECT STRUCTURE-EFFECTIVE-SLOT-DEFINITION))|

+ |(FAST-METHOD SHARED-INITIALIZE :AFTER (STANDARD-SLOT-DEFINITION T))|

+ |(FAST-METHOD SHARED-INITIALIZE :BEFORE (STANDARD-METHOD T))|

+ |(FAST-METHOD SHARED-INITIALIZE :AFTER (STANDARD-ACCESSOR-METHOD T))|

+ |(FAST-METHOD SHARED-INITIALIZE :BEFORE (STANDARD-GENERIC-FUNCTION T))|))

+(PROCLAIM

+ '(FTYPE (FUNCTION (T T T T) *)

+ |(FAST-METHOD ALLOCATE-INSTANCE (STRUCTURE-CLASS))|

+ |(FAST-METHOD MAKE-INSTANCE (SYMBOL))|

+ |(FAST-METHOD DEFAULT-INITARGS (SLOT-CLASS T))|

+ |(FAST-METHOD INITIALIZE-INSTANCE (SLOT-OBJECT))|

+ |(FAST-METHOD DESCRIBE-OBJECT (T T))|

+ |(FAST-METHOD DESCRIBE-OBJECT (SLOT-OBJECT T))|

+ |(FAST-METHOD SLOTS-TO-INSPECT (SLOT-CLASS SLOT-OBJECT))|

+ |(FAST-METHOD DESCRIBE-OBJECT (STANDARD-GENERIC-FUNCTION T))|

+ |(FAST-METHOD DESCRIBE-OBJECT (CLASS T))|

+ |(FAST-METHOD COMPUTE-APPLICABLE-METHODS-USING-CLASSES (GENERIC-FUNCTION T))|

+ GET-ACCESSOR-FROM-SVUC-METHOD-FUNCTION

+ |(FAST-METHOD SLOT-ACCESSOR-FUNCTION (EFFECTIVE-SLOT-DEFINITION T))|

+ BOOTSTRAP-ACCESSOR-DEFINITION GET-ACCESSOR-METHOD-FUNCTION

+ EMIT-CHECKING-OR-CACHING EMIT-CHECKING-OR-CACHING-FUNCTION

+ SETF-SLOT-VALUE-USING-CLASS-DFUN LOAD-SHORT-DEFCOMBIN

+ INITIALIZE-INSTANCE-SIMPLE-FUNCTION

+ MAKE-SHARED-INITIALIZE-FORM-LIST

+ MAKE-ONE-CLASS-ACCESSOR-DFUN

+ MAKE-FINAL-ONE-INDEX-ACCESSOR-DFUN MAKE-FINAL-CHECKING-DFUN

+ ACCESSOR-VALUES SET-CLASS-SLOT-VALUE-1

+ GENERATE-DISCRIMINATION-NET REAL-MAKE-METHOD-LAMBDA

+ ORDER-SPECIALIZERS ACCESSOR-MISS

+ |(FAST-METHOD REINITIALIZE-INSTANCE :AFTER (SLOT-CLASS))|

+ |(FAST-METHOD DOCUMENTATION (STANDARD-SLOT-DEFINITION))|

+ |(FAST-METHOD COMPUTE-EFFECTIVE-SLOT-DEFINITION (SLOT-CLASS T))|

+ |(FAST-METHOD NO-APPLICABLE-METHOD (T))|

+ |(FAST-METHOD CHANGE-CLASS (T SYMBOL))|

+ |(FAST-METHOD CLASS-SLOT-VALUE (STD-CLASS T))|

+ |(FAST-METHOD LEGAL-QUALIFIERS-P (STANDARD-METHOD T))|

+ |(FAST-METHOD LEGAL-SPECIALIZERS-P (STANDARD-METHOD T))|))

+(PROCLAIM

+ '(FTYPE (FUNCTION (T T T T T T) *) MEMF-CODE-CONVERTER

+ CACHE-MISS-VALUES-INTERNAL

+ GENERATE-DISCRIMINATION-NET-INTERNAL

+ MAKE-LONG-METHOD-COMBINATION-FUNCTION

+ DO-SHORT-METHOD-COMBINATION

+ |(FAST-METHOD (SETF SLOT-VALUE-USING-CLASS) (T STRUCTURE-CLASS STRUCTURE-OBJECT STRUCTURE-EFFECTIVE-SLOT-DEFINITION))|))

+(PROCLAIM '(FTYPE (FUNCTION (T T T T T T *) *) REAL-MAKE-A-METHOD))

+(PROCLAIM

+ '(FTYPE (FUNCTION (T T T *) *) MAKE-ONE-INDEX-ACCESSOR-DFUN

+ WALKER::WALK-DECLARATIONS GET-SECONDARY-DISPATCH-FUNCTION))

+(PROCLAIM

+ '(FTYPE (FUNCTION (T T T T *) *)

+ MAKE-EFFECTIVE-METHOD-FUNCTION-SIMPLE1

+ ITERATE::RENAME-LET-BINDINGS))

+(PROCLAIM

+ '(FTYPE (FUNCTION (T T *) *) NESTED-WALK-FORM SLOT-VALUE-OR-DEFAULT

+ MAKE-EFFECTIVE-METHOD-FUNCTION

+ GET-EFFECTIVE-METHOD-FUNCTION MAKE-N-N-ACCESSOR-DFUN

+ MAKE-CHECKING-DFUN LOAD-DEFGENERIC TYPES-FROM-ARGUMENTS

+ MAKE-DEFAULT-INITARGS-FORM-LIST MAKE-FINAL-ACCESSOR-DFUN

+ MAKE-ACCESSOR-TABLE GET-SIMPLE-INITIALIZATION-FUNCTION

+ GET-COMPLEX-INITIALIZATION-FUNCTIONS

+ COMPUTE-SECONDARY-DISPATCH-FUNCTION))

+(PROCLAIM

+ '(FTYPE (FUNCTION (T T T T T T T) *)

+ |(FAST-METHOD UPDATE-INSTANCE-FOR-REDEFINED-CLASS (STANDARD-OBJECT T T T))|

+ ITERATE::ITERATE-TRANSFORM-BODY))

+(PROCLAIM

+ '(FTYPE (FUNCTION (T) NON-NEGATIVE-FIXNUM) CACHE-NLINES

+ CACHE-MAX-LOCATION CACHE-SIZE CACHE-MASK))

+(PROCLAIM '(FTYPE (FUNCTION (T STREAM T) T) PRINT-DFUN-INFO))

+(PROCLAIM

+ '(FTYPE (FUNCTION (T T T T) T)

+ |(FAST-METHOD ALLOCATE-INSTANCE (STANDARD-CLASS))|

+ |(FAST-METHOD VALIDATE-SUPERCLASS (FUNCALLABLE-STANDARD-CLASS STANDARD-CLASS))|

+ |(FAST-METHOD ALLOCATE-INSTANCE (FUNCALLABLE-STANDARD-CLASS))|

+ |(FAST-METHOD MAKE-READER-METHOD-FUNCTION (FUNCALLABLE-STANDARD-CLASS T))|

+ |(FAST-METHOD MAKE-WRITER-METHOD-FUNCTION (FUNCALLABLE-STANDARD-CLASS T))|

+ |(FAST-METHOD MAKE-INSTANCE (CLASS))|

+ |(FAST-METHOD REINITIALIZE-INSTANCE (SLOT-OBJECT))|

+ MAKE-EFFECTIVE-METHOD-FUNCTION1

+ MAKE-EFFECTIVE-METHOD-FUNCTION-INTERNAL

+ MAKE-EFFECTIVE-METHOD-FUNCTION-TYPE MEMF-TEST-CONVERTER

+ LOAD-PRECOMPILED-DFUN-CONSTRUCTOR TWO-CLASS-DFUN-INFO

+ WALKER::WALK-LET/LET* WALKER::WALK-PROG/PROG*

+ WALKER::WALK-DO/DO* WALKER::WALK-BINDINGS-2 OPTIMIZE-READER

+ OPTIMIZE-WRITER

+ |(FAST-METHOD SAME-SPECIALIZER-P (SPECIALIZER SPECIALIZER))|

+ EMIT-CHECKING-OR-CACHING-FUNCTION-PRELIMINARY

+ |(FAST-METHOD SAME-SPECIALIZER-P (CLASS CLASS))|

+ MAYBE-EXPAND-ACCESSOR-FORM

+ |(FAST-METHOD ADD-DIRECT-SUBCLASS (CLASS CLASS))|

+ INITIALIZE-INSTANCE-SIMPLE

+ |(FAST-METHOD SAME-SPECIALIZER-P (CLASS-EQ-SPECIALIZER CLASS-EQ-SPECIALIZER))|

+ GET-WRAPPERS-FROM-CLASSES

+ |(FAST-METHOD SAME-SPECIALIZER-P (EQL-SPECIALIZER EQL-SPECIALIZER))|

+ LOAD-PRECOMPILED-IIS-ENTRY FILL-CACHE-P ADJUST-CACHE

+ |(FAST-METHOD REMOVE-DIRECT-SUBCLASS (CLASS CLASS))|

+ EXPAND-CACHE EXPAND-SYMBOL-MACROLET-INTERNAL

+ |(FAST-METHOD ADD-DIRECT-METHOD (CLASS METHOD))|

+ BOOTSTRAP-SET-SLOT EXPAND-DEFCLASS

+ |(FAST-METHOD REMOVE-DIRECT-METHOD (CLASS METHOD))|

+ |(FAST-METHOD UPDATE-GF-DFUN (STD-CLASS T))|

+ |(FAST-METHOD ADD-DIRECT-METHOD (SPECIALIZER-WITH-OBJECT METHOD))|

+ |(FAST-METHOD REMOVE-DIRECT-METHOD (SPECIALIZER-WITH-OBJECT METHOD))|

+ |(FAST-METHOD SLOT-ACCESSOR-STD-P (EFFECTIVE-SLOT-DEFINITION T))|

+ WALKER::WALK-TEMPLATE

+ |(FAST-METHOD REINITIALIZE-INSTANCE :BEFORE (SLOT-CLASS))|

+ |(FAST-METHOD DOCUMENTATION (T))|

+ |(FAST-METHOD DOCUMENTATION (DOCUMENTATION-MIXIN))|

+ |(FAST-METHOD DIRECT-SLOT-DEFINITION-CLASS (STRUCTURE-CLASS T))|

+ |(FAST-METHOD DIRECT-SLOT-DEFINITION-CLASS (STD-CLASS T))|

+ |(FAST-METHOD EFFECTIVE-SLOT-DEFINITION-CLASS (STD-CLASS T))|

+ |(FAST-METHOD EFFECTIVE-SLOT-DEFINITION-CLASS (STRUCTURE-CLASS T))|

+ |(FAST-METHOD COMPUTE-EFFECTIVE-SLOT-DEFINITION-INITARGS (SLOT-CLASS T))|

+ |(FAST-METHOD COMPUTE-EFFECTIVE-SLOT-DEFINITION-INITARGS :AROUND (STRUCTURE-CLASS T))|

+ |(FAST-METHOD REMOVE-READER-METHOD (SLOT-CLASS T))|

+ |(FAST-METHOD REMOVE-WRITER-METHOD (SLOT-CLASS T))|

+ |(FAST-METHOD REMOVE-BOUNDP-METHOD (SLOT-CLASS T))|

+ |(FAST-METHOD MAKE-READER-METHOD-FUNCTION (SLOT-CLASS T))|

+ |(FAST-METHOD MAKE-WRITER-METHOD-FUNCTION (SLOT-CLASS T))|

+ |(FAST-METHOD MAKE-BOUNDP-METHOD-FUNCTION (SLOT-CLASS T))|

+ |(FAST-METHOD INFORM-TYPE-SYSTEM-ABOUT-CLASS (STD-CLASS T))|

+ |(FAST-METHOD COMPATIBLE-META-CLASS-CHANGE-P (T T))|

+ |(FAST-METHOD VALIDATE-SUPERCLASS (CLASS CLASS))|

+ |(FAST-METHOD CHANGE-CLASS (STANDARD-OBJECT STANDARD-CLASS))|

+ |(FAST-METHOD CHANGE-CLASS (STANDARD-OBJECT FUNCALLABLE-STANDARD-CLASS))|

+ |(FAST-METHOD VALIDATE-SUPERCLASS (CLASS BUILT-IN-CLASS))|

+ |(FAST-METHOD VALIDATE-SUPERCLASS (SLOT-CLASS FORWARD-REFERENCED-CLASS))|

+ |(FAST-METHOD ADD-DEPENDENT (DEPENDENT-UPDATE-MIXIN T))|

+ |(FAST-METHOD REMOVE-DEPENDENT (DEPENDENT-UPDATE-MIXIN T))|

+ |(FAST-METHOD MAP-DEPENDENTS (DEPENDENT-UPDATE-MIXIN T))|

+ |(FAST-METHOD PRINT-OBJECT (T T))|

+ |(FAST-METHOD PRINT-OBJECT (CLASS T))|

+ |(FAST-METHOD PRINT-OBJECT (SLOT-DEFINITION T))|

+ |(FAST-METHOD PRINT-OBJECT (STANDARD-METHOD-COMBINATION T))|

+ |(FAST-METHOD INFORM-TYPE-SYSTEM-ABOUT-CLASS (STRUCTURE-CLASS T))|

+ |(FAST-METHOD PRINT-OBJECT (STANDARD-METHOD T))|

+ |(FAST-METHOD PRINT-OBJECT (STANDARD-ACCESSOR-METHOD T))|

+ |(FAST-METHOD REINITIALIZE-INSTANCE (STANDARD-METHOD))|

+ |(FAST-METHOD LEGAL-DOCUMENTATION-P (STANDARD-METHOD T))|

+ |(FAST-METHOD LEGAL-LAMBDA-LIST-P (STANDARD-METHOD T))|

+ |(FAST-METHOD LEGAL-METHOD-FUNCTION-P (STANDARD-METHOD T))|

+ |(FAST-METHOD LEGAL-QUALIFIER-P (STANDARD-METHOD T))|

+ |(FAST-METHOD LEGAL-SLOT-NAME-P (STANDARD-METHOD T))|

+ |(FAST-METHOD LEGAL-SPECIALIZER-P (STANDARD-METHOD T))|

+ |(FAST-METHOD PRINT-OBJECT (GENERIC-FUNCTION T))|

+ |(FAST-METHOD INITIALIZE-INSTANCE :AFTER (STANDARD-GENERIC-FUNCTION))|

+ MAKE-DISPATCH-LAMBDA

+ |(FAST-METHOD REINITIALIZE-INSTANCE :AFTER (STANDARD-GENERIC-FUNCTION))|

+ |(FAST-METHOD COMPUTE-APPLICABLE-METHODS (GENERIC-FUNCTION T))|))

+(PROCLAIM

+ '(FTYPE (FUNCTION (T T T) T)

+ |(FAST-METHOD COMPUTE-CLASS-PRECEDENCE-LIST (SLOT-CLASS))|

+ CAN-OPTIMIZE-ACCESS

+ |(FAST-METHOD WRAPPER-FETCHER (FUNCALLABLE-STANDARD-CLASS))|

+ OPTIMIZE-SLOT-VALUE

+ |(FAST-METHOD SLOTS-FETCHER (FUNCALLABLE-STANDARD-CLASS))|

+ OPTIMIZE-SET-SLOT-VALUE

+ |(FAST-METHOD RAW-INSTANCE-ALLOCATOR (FUNCALLABLE-STANDARD-CLASS))|

+ DECLARE-STRUCTURE OPTIMIZE-SLOT-BOUNDP PRINT-CACHE

+ FIRST-FORM-TO-LISP ITERATE::OPTIMIZE-ITERATE-FORM

+ WRAP-METHOD-GROUP-SPECIFIER-BINDINGS MAKE-TOP-LEVEL-FORM

+ INVALIDATE-WRAPPER STANDARD-COMPUTE-EFFECTIVE-METHOD

+ MAKE-OPTIMIZED-STD-SLOT-VALUE-USING-CLASS-METHOD-FUNCTION

+ MAKE-OPTIMIZED-STD-SETF-SLOT-VALUE-USING-CLASS-METHOD-FUNCTION

+ MAKE-OPTIMIZED-STD-SLOT-BOUNDP-USING-CLASS-METHOD-FUNCTION

+ WALKER::RECONS ITERATE::OPTIMIZE-GATHERING-FORM

+ WALKER::WALK-MULTIPLE-VALUE-SETQ

+ |(FAST-METHOD CLASS-CONSTRUCTORS (SLOT-CLASS))|

+ |(FAST-METHOD CLASS-SLOT-CELLS (STD-CLASS))|

+ |(FAST-METHOD SPECIALIZER-CLASS (CLASS))|

+ |(FAST-METHOD SPECIALIZER-CLASS (EQL-SPECIALIZER))|

+ |(FAST-METHOD SPECIALIZER-DIRECT-METHODS (CLASS))|

+ |(FAST-METHOD SPECIALIZER-DIRECT-GENERIC-FUNCTIONS (CLASS))|

+ |(FAST-METHOD GENERIC-FUNCTION-PRETTY-ARGLIST (STANDARD-GENERIC-FUNCTION))|

+ |(FAST-METHOD SPECIALIZER-METHOD-TABLE (EQL-SPECIALIZER))|

+ |(FAST-METHOD SPECIALIZER-METHOD-TABLE (CLASS-EQ-SPECIALIZER))|

+ |(FAST-METHOD SPECIALIZER-DIRECT-METHODS (SPECIALIZER-WITH-OBJECT))|

+ |(FAST-METHOD SPECIALIZER-DIRECT-GENERIC-FUNCTIONS (SPECIALIZER-WITH-OBJECT))|

+ VARIABLE-DECLARATION

+ |(FAST-METHOD CLASS-PREDICATE-NAME (T))|

+ |(FAST-METHOD INITIALIZE-INTERNAL-SLOT-FUNCTIONS (EFFECTIVE-SLOT-DEFINITION))|

+ |(FAST-METHOD SLOT-DEFINITION-ALLOCATION (STRUCTURE-SLOT-DEFINITION))|

+ |(FAST-METHOD FINALIZE-INHERITANCE (STRUCTURE-CLASS))|

+ |(FAST-METHOD FINALIZE-INHERITANCE (STD-CLASS))|

+ |(FAST-METHOD COMPUTE-DEFAULT-INITARGS (SLOT-CLASS))|

+ |(FAST-METHOD CLASS-FINALIZED-P (PCL-CLASS))|

+ |(FAST-METHOD COMPUTE-SLOTS (STD-CLASS))|

+ |(FAST-METHOD COMPUTE-SLOTS :AROUND (STD-CLASS))|

+ |(FAST-METHOD COMPUTE-SLOTS (STRUCTURE-CLASS))|

+ |(FAST-METHOD COMPUTE-SLOTS :AROUND (STRUCTURE-CLASS))|

+ |(FAST-METHOD CLASS-DIRECT-DEFAULT-INITARGS (SLOT-CLASS))|

+ |(FAST-METHOD CLASS-DEFAULT-INITARGS (SLOT-CLASS))|

+ ITERATE::SIMPLE-EXPAND-GATHERING-FORM

+ ITERATE::RENAME-AND-CAPTURE-VARIABLES

+ ITERATE::VARIABLE-SAME-P GET-FUNCTION-GENERATOR

+ GET-NEW-FUNCTION-GENERATOR TRACE-METHOD-INTERNAL

+ ONE-INDEX-DFUN-INFO ONE-CLASS-DFUN-INFO MAP-ALL-ORDERS

+ NOTE-PV-TABLE-REFERENCE WALKER::RELIST-INTERNAL

+ MAKE-DFUN-CALL WALKER::WALK-TAGBODY-1 WALKER::WALK-LAMBDA

+ OPTIMIZE-GF-CALL-INTERNAL WALKER::WALK-COMPILER-LET

+ |(FAST-METHOD MAKE-INSTANCES-OBSOLETE (STD-CLASS))|

+ SKIP-FAST-SLOT-ACCESS-P WALKER::WALK-UNEXPECTED-DECLARE

+ WALKER::WALK-FLET WALKER::WALK-IF WALKER::WALK-LABELS

+ WALKER::WALK-LET WALKER::WALK-LET* WALKER::WALK-LOCALLY

+ |(FAST-METHOD CLASS-DIRECT-SLOTS (BUILT-IN-CLASS))|

+ WALKER::WALK-MACROLET

+ |(FAST-METHOD CLASS-SLOTS (BUILT-IN-CLASS))|

+ |(FAST-METHOD CLASS-DIRECT-DEFAULT-INITARGS (BUILT-IN-CLASS))|

+ FIX-SLOT-ACCESSORS

+ |(FAST-METHOD WRAPPER-FETCHER (STANDARD-CLASS))|

+ WALKER::WALK-MULTIPLE-VALUE-BIND

+ |(FAST-METHOD CLASS-DEFAULT-INITARGS (BUILT-IN-CLASS))|

+ WALKER::WALK-SETQ

+ |(FAST-METHOD SLOTS-FETCHER (STANDARD-CLASS))|

+ WALKER::WALK-SYMBOL-MACROLET

+ |(FAST-METHOD RAW-INSTANCE-ALLOCATOR (STANDARD-CLASS))|

+ EMIT-SLOT-READ-FORM WALKER::WALK-TAGBODY EMIT-BOUNDP-CHECK

+ WALKER::WALK-DO WALKER::WALK-DO* WALKER::WALK-PROG

+ WALKER::WALK-NAMED-LAMBDA WALKER::WALK-PROG*

+ EXPAND-DEFGENERIC EMIT-GREATER-THAN-1-DLAP EMIT-1-T-DLAP

+ MAKE-METHOD-INITARGS-FORM-INTERNAL ENTRY-IN-CACHE-P

+ CONVERT-TABLE MAKE-METHOD-SPEC TRACE-EMF-CALL-INTERNAL

+ FLUSH-CACHE-TRAP SET-FUNCTION-NAME-1 OBSOLETE-INSTANCE-TRAP

+ COMPUTE-PRECEDENCE PRINT-STD-INSTANCE

+ |SETF PCL METHOD-FUNCTION-GET| |SETF PCL PLIST-VALUE|

+ WALKER::WITH-AUGMENTED-ENVIRONMENT-INTERNAL

+ |(FAST-METHOD ACCESSOR-METHOD-CLASS (STANDARD-ACCESSOR-METHOD))|

+ |(FAST-METHOD ACCESSOR-METHOD-CLASS (STANDARD-WRITER-METHOD))|

+ INITIALIZE-INTERNAL-SLOT-GFS*

+ |(FAST-METHOD METHOD-QUALIFIERS (STANDARD-METHOD))|

+ SKIP-OPTIMIZE-SLOT-VALUE-BY-CLASS-P

+ |(FAST-METHOD GENERIC-FUNCTION-LAMBDA-LIST (GENERIC-FUNCTION))|

+ |(FAST-METHOD GF-FAST-METHOD-FUNCTION-P (STANDARD-GENERIC-FUNCTION))|

+ COMPUTE-EFFECTIVE-METHOD SORT-APPLICABLE-METHODS

+ SORT-METHODS))

+(PROCLAIM

+ '(FTYPE (FUNCTION (T T T T T) T)

+ |(FAST-METHOD SLOT-UNBOUND (T T T))|

+ |(FAST-METHOD FIND-METHOD-COMBINATION (GENERIC-FUNCTION (EQL STANDARD) T))|

+ |(FAST-METHOD COMPUTE-EFFECTIVE-METHOD (GENERIC-FUNCTION SHORT-METHOD-COMBINATION T))|

+ LOAD-FUNCTION-GENERATOR EXPAND-EMF-CALL-METHOD MAKE-FGEN

+ BOOTSTRAP-MAKE-SLOT-DEFINITIONS

+ BOOTSTRAP-ACCESSOR-DEFINITIONS1

+ MAKE-FINAL-ORDINARY-DFUN-INTERNAL

+ WALKER::WALK-TEMPLATE-HANDLE-REPEAT COMPUTE-PV-SLOT

+ WALKER::WALK-BINDINGS-1 OPTIMIZE-INSTANCE-ACCESS

+ OPTIMIZE-ACCESSOR-CALL MAKE-METHOD-INITARGS-FORM-INTERNAL1

+ UPDATE-SLOTS-IN-PV MAKE-PARAMETER-REFERENCES MAKE-EMF-CACHE

+ GET-MAKE-INSTANCE-FUNCTION-INTERNAL

+ |(FAST-METHOD (SETF SLOT-ACCESSOR-STD-P) (T EFFECTIVE-SLOT-DEFINITION T))|

+ MAKE-INSTANCE-FUNCTION-COMPLEX

+ |(FAST-METHOD ENSURE-CLASS-USING-CLASS (T NULL))|

+ MAKE-INSTANCE-FUNCTION-SIMPLE

+ |(FAST-METHOD ENSURE-CLASS-USING-CLASS (T PCL-CLASS))|

+ OPTIMIZE-GENERIC-FUNCTION-CALL

+ REAL-MAKE-METHOD-INITARGS-FORM

+ |(FAST-METHOD COMPUTE-SLOT-ACCESSOR-INFO (EFFECTIVE-SLOT-DEFINITION T T))|

+ |(FAST-METHOD SHARED-INITIALIZE :AFTER (STD-CLASS T))|

+ |(FAST-METHOD SHARED-INITIALIZE :AFTER (DOCUMENTATION-MIXIN T))|

+ |(FAST-METHOD (SETF DOCUMENTATION) (T T))|

+ |(FAST-METHOD SHARED-INITIALIZE :AFTER (STRUCTURE-CLASS T))|

+ |(FAST-METHOD (SETF DOCUMENTATION) (T DOCUMENTATION-MIXIN))|

+ |(FAST-METHOD READER-METHOD-CLASS (SLOT-CLASS T))|

+ |(FAST-METHOD WRITER-METHOD-CLASS (SLOT-CLASS T))|

+ |(FAST-METHOD SHARED-INITIALIZE :BEFORE (BUILT-IN-CLASS T))|

+ |(FAST-METHOD SLOT-BOUNDP-USING-CLASS (STD-CLASS STANDARD-OBJECT STANDARD-EFFECTIVE-SLOT-DEFINITION))|

+ |(FAST-METHOD SLOT-MAKUNBOUND-USING-CLASS (STD-CLASS STANDARD-OBJECT STANDARD-EFFECTIVE-SLOT-DEFINITION))|

+ |(FAST-METHOD SHARED-INITIALIZE :AFTER (STRUCTURE-SLOT-DEFINITION T))|

+ |(FAST-METHOD SLOT-BOUNDP-USING-CLASS (STRUCTURE-CLASS STRUCTURE-OBJECT STRUCTURE-EFFECTIVE-SLOT-DEFINITION))|

+ |(FAST-METHOD SLOT-MAKUNBOUND-USING-CLASS (STRUCTURE-CLASS STRUCTURE-OBJECT STRUCTURE-EFFECTIVE-SLOT-DEFINITION))|

+ |(FAST-METHOD SHARED-INITIALIZE :BEFORE (STANDARD-ACCESSOR-METHOD T))|

+ |(FAST-METHOD SHARED-INITIALIZE :AFTER (STANDARD-METHOD T))|

+ |(FAST-METHOD REMOVE-NAMED-METHOD (T T))|))

+(PROCLAIM

+ '(FTYPE (FUNCTION (T T *) T) MAKE-EFFECTIVE-METHOD-FUNCTION-SIMPLE

+ MAKE-EMF-FROM-METHOD EXPAND-EFFECTIVE-METHOD-FUNCTION

+ NAMED-OBJECT-PRINT-FUNCTION FIND-CLASS-FROM-CELL

+ FIND-CLASS-PREDICATE-FROM-CELL INITIALIZE-INFO

+ GET-EFFECTIVE-METHOD-FUNCTION1 GET-DECLARATION

+ GET-METHOD-FUNCTION-PV-CELL EMIT-MISS METHOD-FUNCTION-GET

+ PROBE-CACHE MAP-CACHE PRECOMPUTE-EFFECTIVE-METHODS

+ RECORD-DEFINITION WALKER::CONVERT-MACRO-TO-LAMBDA CPL-ERROR

+ REAL-ADD-METHOD

+ REAL-ENSURE-GF-USING-CLASS--GENERIC-FUNCTION

+ REAL-ENSURE-GF-USING-CLASS--NULL

+ COMPUTE-SECONDARY-DISPATCH-FUNCTION1

+ ENSURE-GENERIC-FUNCTION-USING-CLASS))

+(PROCLAIM

+ '(FTYPE (FUNCTION (T T T T T T) T) REAL-LOAD-DEFCLASS

+ WALKER::WALK-TEMPLATE-HANDLE-REPEAT-1

+ BOOTSTRAP-MAKE-SLOT-DEFINITION EMIT-SLOT-ACCESS

+ OPTIMIZE-GF-CALL SET-ARG-INFO1 LOAD-DEFCLASS

+ MAKE-EARLY-CLASS-DEFINITION

+ |(FAST-METHOD (SETF SLOT-VALUE-USING-CLASS) (T STD-CLASS STANDARD-OBJECT STANDARD-EFFECTIVE-SLOT-DEFINITION))|))

+(PROCLAIM

+ '(FTYPE (FUNCTION (T T T T T T T) T)

+ |(FAST-METHOD SLOT-MISSING (T T T T))| EXPAND-DEFMETHOD

+ LOAD-DEFMETHOD-INTERNAL))

+(PROCLAIM

+ '(FTYPE (FUNCTION (T T T FIXNUM) T) GET-CACHE

+ FILL-CACHE-FROM-CACHE-P))

+(PROCLAIM

+ '(FTYPE (FUNCTION (T T T T T *) T) EMIT-DLAP

+ GET-SECONDARY-DISPATCH-FUNCTION1))

+(PROCLAIM

+ '(FTYPE (FUNCTION (T T T *) T) CHECK-INITARGS-2-PLIST

+ CHECK-INITARGS-2-LIST WALKER::WALK-ARGLIST MAKE-EMF-CALL

+ CAN-OPTIMIZE-ACCESS1 EMIT-FETCH-WRAPPER FILL-CACHE

+ REAL-GET-METHOD CHECK-INITARGS-1 GET-METHOD))

+(PROCLAIM

+ '(FTYPE (FUNCTION (T T T T T T *) T) LOAD-DEFMETHOD

+ MAKE-DEFMETHOD-FORM MAKE-DEFMETHOD-FORM-INTERNAL

+ EARLY-MAKE-A-METHOD))

+(PROCLAIM

+ '(FTYPE (FUNCTION (T T T T *) T) FILL-DFUN-CACHE

+ EARLY-ADD-NAMED-METHOD REAL-ADD-NAMED-METHOD))

+(PROCLAIM

+ '(FTYPE (FUNCTION (T T T T T T T T) T)

+ GET-SECONDARY-DISPATCH-FUNCTION2))

+(PROCLAIM '(FTYPE (FUNCTION (T T FIXNUM) T) COMPUTE-STD-CPL-PHASE-3))

+(PROCLAIM

+ '(FTYPE (FUNCTION (T T T T T T T T T *) T)

+ BOOTSTRAP-INITIALIZE-CLASS))

+(PROCLAIM

+ '(FTYPE (FUNCTION NIL *) COUNT-ALL-DFUNS EMIT-N-N-READERS

+ EMIT-N-N-WRITERS))

+(PROCLAIM

+ '(FTYPE (FUNCTION (*) *) UNTRACE-METHOD LIST-LARGE-CACHES

+ UPDATE-MAKE-INSTANCE-FUNCTION-TABLE INVALID-METHOD-ERROR

+ METHOD-COMBINATION-ERROR))

+(PROCLAIM

+ '(FTYPE (FUNCTION NIL T) RENEW-SYS-FILES

+ GET-EFFECTIVE-METHOD-GENSYM SHOW-EMF-CALL-TRACE

+ BOOTSTRAP-META-BRAID BOOTSTRAP-BUILT-IN-CLASSES

+ LIST-ALL-DFUNS DEFAULT-METHOD-ONLY-DFUN-INFO

+ INITIALIZE-CHECKING-OR-CACHING-FUNCTION-LIST

+ CACHES-TO-ALLOCATE UPDATE-DISPATCH-DFUNS MAKE-CACHE

+ IN-THE-COMPILER-P STRUCTURE-FUNCTIONS-EXIST-P

+ ALLOCATE-FUNCALLABLE-INSTANCE-2 %%ALLOCATE-INSTANCE--CLASS

+ ALLOCATE-FUNCALLABLE-INSTANCE-1 DISPATCH-DFUN-INFO

+ INITIAL-DISPATCH-DFUN-INFO INITIAL-DFUN-INFO

+ NO-METHODS-DFUN-INFO SHOW-FREE-CACHE-VECTORS MAKE-CPD

+ MAKE-ARG-INFO SHOW-DFUN-CONSTRUCTORS))

+(PROCLAIM '(FTYPE (FUNCTION (FIXNUM T T) *) COMPUTE-CACHE-PARAMETERS))

+(PROCLAIM '(FTYPE (FUNCTION (FIXNUM T *) *) FIND-FREE-CACHE-LINE))

+(PROCLAIM

+ '(FTYPE (FUNCTION (*) T) |__si::MAKE-DFUN-INFO|

+ |__si::MAKE-NO-METHODS| |__si::MAKE-INITIAL|

+ |__si::MAKE-INITIAL-DISPATCH| |__si::MAKE-DISPATCH|

+ |__si::MAKE-DEFAULT-METHOD-ONLY|

+ |__si::MAKE-ACCESSOR-DFUN-INFO|

+ |__si::MAKE-ONE-INDEX-DFUN-INFO| MAKE-FAST-METHOD-CALL

+ |__si::MAKE-N-N| MAKE-FAST-INSTANCE-BOUNDP

+ |__si::MAKE-ONE-CLASS| |__si::MAKE-TWO-CLASS|

+ |__si::MAKE-ONE-INDEX| |__si::MAKE-CHECKING|

+ |__si::MAKE-ARG-INFO| FIX-EARLY-GENERIC-FUNCTIONS

+ STRING-APPEND |__si::MAKE-CACHING|

+ |__si::MAKE-CONSTANT-VALUE| FALSE

+ |STRUCTURE-OBJECT class constructor|

+ PV-WRAPPERS-FROM-PV-ARGS MAKE-PV-TABLE

+ |__si::MAKE-PV-TABLE| INTERN-PV-TABLE

+ CALLED-FIN-WITHOUT-FUNCTION |__si::MAKE-STD-INSTANCE|

+ MAKE-INITIALIZE-INFO |__si::MAKE-CACHE| MAKE-PROGN

+ WALKER::UNBOUND-LEXICAL-FUNCTION

+ |__si::MAKE-CLASS-PRECEDENCE-DESCRIPTION| MAKE-METHOD-CALL

+ TRUE USE-PACKAGE-PCL ZERO))

+(PROCLAIM

+ '(FTYPE (FUNCTION (T) *) TYPE-FROM-SPECIALIZER *NORMALIZE-TYPE

+ DEFAULT-CODE-CONVERTER CONVERT-TO-SYSTEM-TYPE

+ EMIT-CONSTANT-VALUE PCL-DESCRIBE GET-GENERIC-FUNCTION-INFO

+ EARLY-METHOD-FUNCTION

+ EARLY-METHOD-STANDARD-ACCESSOR-SLOT-NAME

+ SPECIALIZER-FROM-TYPE CLASS-EQ-TYPE STRUCTURE-WRAPPER

+ FIND-STRUCTURE-CLASS MAKE-DISPATCH-DFUN FIND-WRAPPER

+ PARSE-DEFMETHOD PROTOTYPES-FOR-MAKE-METHOD-LAMBDA

+ EMIT-ONE-CLASS-READER EMIT-ONE-CLASS-WRITER

+ EMIT-TWO-CLASS-READER EMIT-TWO-CLASS-WRITER

+ EMIT-ONE-INDEX-READERS EMIT-ONE-INDEX-WRITERS

+ NET-CODE-CONVERTER EMIT-IN-CHECKING-CACHE-P

+ COMPILE-IIS-FUNCTIONS ANALYZE-LAMBDA-LIST

+ COMPUTE-APPLICABLE-METHODS-EMF GET-DISPATCH-FUNCTION

+ GENERIC-FUNCTION-NAME-P MAKE-FINAL-DISPATCH-DFUN

+ STRUCTURE-SLOTD-INIT-FORM PARSE-METHOD-GROUP-SPECIFIER

+ METHOD-PROTOTYPE-FOR-GF EARLY-COLLECT-INHERITANCE))

+(PROCLAIM

+ '(FTYPE (FUNCTION (T FIXNUM *) T) GET-CACHE-FROM-CACHE

+ COMPUTE-PRIMARY-CACHE-LOCATION-FROM-LOCATION))

+(PROCLAIM

+ '(FTYPE (FUNCTION (T) T) COMPILE-LAMBDA-UNCOMPILED GF-LAMBDA-LIST

+ CACHING-CACHE CONSTANT-VALUE-CACHE COMPILE-LAMBDA-DEFERRED

+ FUNCALLABLE-INSTANCE-P SHOW-DFUN-COSTS

+ RESET-CLASS-INITIALIZE-INFO GET-CACHE-VECTOR

+ CONSTANT-SYMBOL-P FREE-CACHE-VECTOR

+ EARLY-METHOD-LAMBDA-LIST ARG-INFO-VALID-P DFUN-ARG-SYMBOL

+ EARLY-METHOD-CLASS EARLY-GF-P EARLY-GF-NAME

+ CACHING-DFUN-INFO COMPUTE-APPLICABLE-METHODS-EMF-STD-P

+ CONSTANT-VALUE-DFUN-INFO RESET-CLASS-INITIALIZE-INFO-1

+ FREE-CACHE PARSE-SPECIALIZERS RESET-INITIALIZE-INFO

+ EARLY-METHOD-QUALIFIERS PROCLAIM-INCOMPATIBLE-SUPERCLASSES

+ WRAPPER-OF EARLY-METHOD-STANDARD-ACCESSOR-P

+ FUNCTION-PRETTY-ARGLIST GET-MAKE-INSTANCE-FUNCTION

+ CHECK-WRAPPER-VALIDITY UNPARSE-SPECIALIZERS

+ %SYMBOL-FUNCTION FINAL-ACCESSOR-DFUN-TYPE

+ COMPLICATED-INSTANCE-CREATION-METHOD DEFAULT-STRUCTUREP

+ UPDATE-GF-INFO CACHE-OWNER DEFAULT-STRUCTURE-INSTANCE-P

+ DEFAULT-STRUCTURE-TYPE STRUCTURE-TYPE

+ COMPUTE-STD-CPL-PHASE-2 GET-PV-CELL-FOR-CLASS

+ STRUCTURE-TYPE-INCLUDED-TYPE-NAME

+ STRUCTURE-TYPE-SLOT-DESCRIPTION-LIST CACHE-P

+ STRUCTURE-SLOTD-NAME STRUCTURE-SLOTD-ACCESSOR-SYMBOL SFUN-P

+ DEFAULT-SECONDARY-DISPATCH-FUNCTION

+ STRUCTURE-SLOTD-WRITER-FUNCTION FIND-CYCLE-REASONS

+ EARLY-CLASS-DEFINITION ECD-SOURCE STRUCTURE-SLOTD-TYPE

+ FORMAT-CYCLE-REASONS ECD-METACLASS CPD-CLASS

+ EARLY-CLASS-PRECEDENCE-LIST

+ METHODS-CONTAIN-EQL-SPECIALIZER-P MAKE-TYPE-PREDICATE

+ CPD-SUPERS DEFAULT-TEST-CONVERTER EXPAND-LONG-DEFCOMBIN

+ INITIAL-P EARLY-CLASS-NAME-OF FORCE-CACHE-FLUSHES CPD-AFTER

+ EXPAND-SHORT-DEFCOMBIN MAKE-CALL-METHODS

+ DEFAULT-CONSTANT-CONVERTER EARLY-CLASS-SLOTDS

+ INITIAL-DISPATCH-P DISPATCH-P EARLY-SLOT-DEFINITION-NAME

+ SLOT-READER-SYMBOL GBOUNDP GMAKUNBOUND

+ EARLY-SLOT-DEFINITION-LOCATION WALKER::ENV-LOCK

+ DEFAULT-CONSTANTP MAKE-INITIAL-DFUN DEFAULT-METHOD-ONLY-P

+ FGEN-TEST EARLY-ACCESSOR-METHOD-SLOT-NAME

+ SLOT-WRITER-SYMBOL LOOKUP-FGEN WALKER::ENV-DECLARATIONS

+ ACCESSOR-DFUN-INFO-P WALKER::ENV-LEXICAL-VARIABLES

+ FGEN-GENERATOR FGEN-SYSTEM LIST-DFUN %FBOUNDP

+ SLOT-BOUNDP-SYMBOL ONE-INDEX-DFUN-INFO-P CCLOSUREP

+ MAP-ALL-GENERIC-FUNCTIONS FAST-METHOD-CALL-P

+ MAKE-STRUCTURE-SLOT-BOUNDP-FUNCTION N-N-P

+ EARLY-CLASS-DIRECT-SUBCLASSES FAST-INSTANCE-BOUNDP-P

+ MAKE-FUNCTION-INLINE METHOD-FUNCTION-PV-TABLE

+ LIST-LARGE-CACHE METHOD-FUNCTION-METHOD STORE-FGEN

+ CLASS-PRECEDENCE-DESCRIPTION-P ONE-CLASS-P

+ INFORM-TYPE-SYSTEM-ABOUT-STD-CLASS

+ UNENCAPSULATED-FDEFINITION

+ MAKE-DEFAULT-METHOD-GROUP-DESCRIPTION

+ METHOD-FUNCTION-NEEDS-NEXT-METHODS-P DFUN-INFO-P

+ MAKE-OPTIMIZED-STRUCTURE-SLOT-VALUE-USING-CLASS-METHOD-FUNCTION

+ FTYPE-DECLARATION-FROM-LAMBDA-LIST NO-METHODS-P

+ WALKER::ENV-WALK-FUNCTION FGEN-GENSYMS

+ WALKER::GET-IMPLEMENTATION-DEPENDENT-WALKER-TEMPLATE

+ TWO-CLASS-P COUNT-DFUN ARG-INFO-LAMBDA-LIST

+ MAKE-INITFUNCTION ARG-INFO-PRECEDENCE

+ MAKE-OPTIMIZED-STRUCTURE-SETF-SLOT-VALUE-USING-CLASS-METHOD-FUNCTION

+ ARG-INFO-METATYPES ITERATE::VARIABLES-FROM-LET

+ FGEN-GENERATOR-LAMBDA WALKER::ENV-WALK-FORM

+ ARG-INFO-NUMBER-OPTIONAL

+ MAKE-OPTIMIZED-STRUCTURE-SLOT-BOUNDP-USING-CLASS-METHOD-FUNCTION

+ ARG-INFO-KEY/REST-P INITIALIZE-INFO-P ONE-INDEX-P

+ ECD-CLASS-NAME ARG-INFO-KEYWORDS COPY-CACHE

+ GF-INFO-SIMPLE-ACCESSOR-TYPE COMPUTE-LINE-SIZE

+ GF-PRECOMPUTE-DFUN-AND-EMF-P CANONICAL-SLOT-NAME

+ GF-INFO-STATIC-C-A-M-EMF WALKER::GET-WALKER-TEMPLATE

+ CHECKING-P EARLY-CLASS-SLOTS GF-INFO-C-A-M-EMF-STD-P

+ STRUCTURE-TYPE-INTERNAL-SLOTDS GF-INFO-FAST-MF-P

+ UNDEFMETHOD-1 EARLY-COLLECT-CPL EARLY-COLLECT-SLOTS

+ ARG-INFO-P METHOD-LL->GENERIC-FUNCTION-LL

+ FAST-METHOD-CALL-ARG-INFO EARLY-COLLECT-DEFAULT-INITARGS

+ ARG-INFO-NKEYS ECD-SUPERCLASS-NAMES GF-DFUN-CACHE

+ GF-DFUN-INFO METHOD-CALL-P STRUCTURE-SLOT-BOUNDP

+ FUNCTION-RETURNING-NIL ITERATE::SEQUENCE-ACCESSOR

+ ACCESSOR-DFUN-INFO-ACCESSOR-TYPE ECD-CANONICAL-SLOTS

+ EVAL-FORM ONE-INDEX-DFUN-INFO-INDEX ECD-OTHER-INITARGS

+ SLOT-INITARGS-FROM-STRUCTURE-SLOTD TYPE-CLASS

+ ONE-CLASS-WRAPPER0 EXTRACT-PARAMETERS CLASS-PREDICATE

+ EXTRACT-REQUIRED-PARAMETERS MAKE-CLASS-EQ-PREDICATE

+ TWO-CLASS-WRAPPER1 MAKE-EQL-PREDICATE CHECKING-FUNCTION

+ BOOTSTRAP-ACCESSOR-DEFINITIONS INITIALIZE-INFO-KEY

+ BOOTSTRAP-CLASS-PREDICATES GET-BUILT-IN-CLASS-SYMBOL

+ INITIALIZE-INFO-WRAPPER GET-BUILT-IN-WRAPPER-SYMBOL

+ DO-STANDARD-DEFSETF-1 CACHING-P GFS-OF-TYPE

+ LEGAL-CLASS-NAME-P STRUCTURE-TYPE-P CONSTANT-VALUE-P

+ USE-DEFAULT-METHOD-ONLY-DFUN-P

+ INITIALIZE-INFO-CACHED-COMBINED-INITARGS-FORM-LIST

+ WRAPPER-FIELD NEXT-WRAPPER-FIELD SETFBOUNDP

+ GET-SETF-FUNCTION-NAME USE-CACHING-DFUN-P

+ MAKE-PV-TYPE-DECLARATION MAKE-CALLS-TYPE-DECLARATION

+ MAP-SPECIALIZERS SLOT-VECTOR-SYMBOL MAKE-PERMUTATION-VECTOR

+ VARIABLE-GLOBALLY-SPECIAL-P STRUCTURE-OBJECT-P

+ EXPAND-MAKE-INSTANCE-FORM MAKE-CONSTANT-FUNCTION

+ FUNCTION-RETURNING-T SORT-SLOTS SORT-CALLS SYMBOL-PKG-NAME

+ CLASS-HAS-A-FORWARD-REFERENCED-SUPERCLASS-P

+ INITIALIZE-INFO-BOUND-SLOTS INITIALIZE-INFO-CACHED-VALID-P

+ GET-MAKE-INSTANCE-FUNCTIONS

+ INITIALIZE-INFO-CACHED-RI-VALID-P

+ INITIALIZE-INFO-CACHED-INITARGS-FORM-LIST

+ INITIALIZE-INFO-CACHED-NEW-KEYS UPDATE-C-A-M-GF-INFO

+ INITIALIZE-INFO-CACHED-DEFAULT-INITARGS-FUNCTION

+ UPDATE-GF-SIMPLE-ACCESSOR-TYPE UPDATE-GFS-OF-CLASS

+ INITIALIZE-INFO-CACHED-SHARED-INITIALIZE-T-FUNCTION

+ DO-STANDARD-DEFSETFS-FOR-DEFCLASS STANDARD-SVUC-METHOD

+ INITIALIZE-INFO-CACHED-SHARED-INITIALIZE-NIL-FUNCTION

+ %CCLOSURE-ENV STRUCTURE-SVUC-METHOD

+ INITIALIZE-INFO-CACHED-CONSTANTS CLASS-OF

+ METHOD-FUNCTION-PLIST

+ INITIALIZE-INFO-CACHED-COMBINED-INITIALIZE-FUNCTION

+ INITIALIZE-INFO-CACHED-MAKE-INSTANCE-FUNCTION

+ INITIALIZE-INFO-CACHED-MAKE-INSTANCE-FUNCTION-SYMBOL

+ INTERNED-SYMBOL-P GDEFINITION UPDATE-CLASS-CAN-PRECEDE-P

+ %STD-INSTANCE-WRAPPER %STD-INSTANCE-SLOTS PV-TABLEP

+ STD-INSTANCE-P COMPUTE-MCASE-PARAMETERS COMPUTE-CLASS-SLOTS

+ MAKE-PV-TABLE-TYPE-DECLARATION INTERN-EQL-SPECIALIZER

+ NET-TEST-CONVERTER MAKE-INSTANCE-FUNCTION-SYMBOL

+ UPDATE-ALL-C-A-M-GF-INFO UPDATE-PV-TABLE-CACHE-INFO

+ DFUN-INFO-CACHE EXTRACT-LAMBDA-LIST NO-METHODS-CACHE

+ ARG-INFO-APPLYP CACHING-DFUN-COST INITIAL-CACHE

+ SYSTEM:%STRUCTURE-NAME INITIAL-DISPATCH-CACHE

+ SYSTEM:%COMPILED-FUNCTION-NAME CHECK-CACHE DISPATCH-CACHE

+ CLASS-FROM-TYPE DEFAULT-METHOD-ONLY-CACHE DNET-METHODS-P

+ ACCESSOR-DFUN-INFO-CACHE METHOD-FUNCTION-FROM-FAST-FUNCTION

+ ONE-INDEX-DFUN-INFO-CACHE ONE-INDEX-DFUN-INFO-ACCESSOR-TYPE

+ METHOD-CALL-CALL-METHOD-ARGS KEYWORD-SPEC-NAME N-N-CACHE

+ GENERIC-CLOBBERS-FUNCTION N-N-ACCESSOR-TYPE

+ FAST-METHOD-CALL-PV-CELL WRAPPER-FOR-STRUCTURE

+ ONE-CLASS-CACHE EXTRACT-SPECIALIZER-NAMES

+ FAST-METHOD-CALL-NEXT-METHOD-CALL ONE-CLASS-ACCESSOR-TYPE

+ ONE-CLASS-INDEX BUILT-IN-WRAPPER-OF TWO-CLASS-CACHE

+ BUILT-IN-OR-STRUCTURE-WRAPPER1 TWO-CLASS-ACCESSOR-TYPE

+ TWO-CLASS-INDEX GET-MAKE-INSTANCE-FUNCTION-SYMBOL

+ ALLOCATE-CACHE-VECTOR TWO-CLASS-WRAPPER0

+ FLUSH-CACHE-VECTOR-INTERNAL ONE-INDEX-CACHE

+ EARLY-CLASS-NAME ONE-INDEX-ACCESSOR-TYPE ONE-INDEX-INDEX

+ INTERN-FUNCTION-NAME CHECKING-CACHE))

+(PROCLAIM

+ '(FTYPE (FUNCTION (T *) *) COERCE-TO-CLASS GET-METHOD-FUNCTION

+ GET-FUNCTION GET-FUNCTION1 PARSE-METHOD-OR-SPEC

+ EXTRACT-DECLARATIONS GET-DFUN-CONSTRUCTOR MAP-ALL-CLASSES

+ MAKE-CACHING-DFUN MAKE-METHOD-FUNCTION-INTERNAL

+ PARSE-SPECIALIZED-LAMBDA-LIST MAKE-METHOD-LAMBDA-INTERNAL

+ MAKE-CONSTANT-VALUE-DFUN MAKE-FINAL-DFUN-INTERNAL

+ COMPILE-LAMBDA WALK-FORM MACROEXPAND-ALL ENSURE-CLASS

+ ENSURE-GENERIC-FUNCTION DISPATCH-DFUN-COST))

+(PROCLAIM '(FTYPE (FUNCTION (T T *) (VALUES T T)) SYMBOL-APPEND))

+(PROCLAIM

+ '(FTYPE (FUNCTION (T *) T) CAPITALIZE-WORDS

+ INITIALIZE-INTERNAL-SLOT-GFS FIND-CLASS

+ MAKE-TYPE-PREDICATE-NAME SET-DFUN TRACE-METHOD

+ FIND-CLASS-CELL MAKE-FINAL-DFUN PV-TABLE-LOOKUP-PV-ARGS

+ USE-DISPATCH-DFUN-P WALKER::RELIST* WALKER::RELIST

+ FIND-CLASS-PREDICATE EARLY-METHOD-SPECIALIZERS

+ USE-CONSTANT-VALUE-DFUN-P MAKE-EARLY-GF

+ ALLOCATE-FUNCALLABLE-INSTANCE SET-ARG-INFO

+ INITIALIZE-METHOD-FUNCTION UPDATE-DFUN MAKE-SPECIALIZABLE

+ ALLOCATE-STRUCTURE-INSTANCE ALLOCATE-STANDARD-INSTANCE

+ WALKER::WALKER-ENVIRONMENT-BIND-1

+ ITERATE::FUNCTION-LAMBDA-P ITERATE::MAYBE-WARN

+ MAKE-WRAPPER))

+(PROCLAIM

+ '(FTYPE (FUNCTION (T T) *) SLOT-BOUNDP SLOT-VALUE SAUT-CLASS

+ SPECIALIZER-APPLICABLE-USING-TYPE-P COMPUTE-TEST

+ GET-NEW-FUNCTION-GENERATOR-INTERNAL COMPUTE-CODE

+ CLASS-APPLICABLE-USING-CLASS-P SAUT-AND SAUT-NOT

+ SAUT-PROTOTYPE DESTRUCTURE ENSURE-CLASS-VALUES

+ MAKE-DIRECT-SLOTD SLOT-MAKUNBOUND

+ MAKE-INSTANCE-FUNCTION-TRAP

+ GENERATE-FAST-CLASS-SLOT-ACCESS-P MUTATE-SLOTS-AND-CALLS

+ INVOKE-EMF EMIT-DEFAULT-ONLY-FUNCTION SPLIT-DECLARATIONS

+ EMIT-DEFAULT-ONLY SLOT-NAME-LISTS-FROM-SLOTS EMIT-CHECKING

+ UPDATE-SLOT-VALUE-GF-INFO EMIT-CACHING SDFUN-FOR-CACHING

+ SLOT-UNBOUND-INTERNAL MAKE-INSTANCE-1 SET-FUNCTION-NAME

+ COMPUTE-STD-CPL-PHASE-1 FORM-LIST-TO-LISP

+ FIND-SUPERCLASS-CHAIN SAUT-CLASS-EQ

+ COMPUTE-APPLICABLE-METHODS-USING-TYPES

+ CHECK-INITARGS-VALUES SAUT-EQL INSURE-DFUN *SUBTYPEP

+ ITERATE::PARSE-DECLARATIONS INITIAL-DFUN))

+(PROCLAIM

+ '(FTYPE (FUNCTION (T T) T) ADD-METHOD DO-SATISFIES-DEFTYPE

+ MEMF-CONSTANT-CONVERTER COMPUTE-CONSTANTS

+ CLASS-CAN-PRECEDE-P SAUT-NOT-CLASS SAUT-NOT-CLASS-EQ

+ SAUT-NOT-PROTOTYPE GF-MAKE-FUNCTION-FROM-EMF SAUT-NOT-EQL

+ SUPERCLASSES-COMPATIBLE-P CLASSES-HAVE-COMMON-SUBCLASS-P

+ DESCRIBE-PACKAGE PRINTING-RANDOM-THING-INTERNAL

+ MAKE-CLASS-PREDICATE METHOD-FUNCTION-RETURNING-NIL

+ METHOD-FUNCTION-RETURNING-T VARIABLE-CLASS MAKE-PLIST

+ REMTAIL DESTRUCTURE-INTERNAL ACCESSOR-MISS-FUNCTION

+ UPDATE-INITIALIZE-INFO-INTERNAL N-N-DFUN-INFO MAKE-CAXR

+ MAKE-CDXR CHECKING-DFUN-INFO

+ FUNCALLABLE-STANDARD-INSTANCE-ACCESS MAKE-PV-TABLE-INTERNAL

+ FIND-SLOT-DEFINITION WALKER::WALK-REPEAT-EVAL

+ WALKER::NOTE-DECLARATION MAKE-DFUN-LAMBDA-LIST

+ WALKER::NOTE-LEXICAL-BINDING MAKE-DLAP-LAMBDA-LIST

+ ADD-DIRECT-SUBCLASSES COMPUTE-PV MAKE-DFUN-ARG-LIST

+ COMPUTE-CALLS MAKE-FAST-METHOD-CALL-LAMBDA-LIST

+ UPDATE-ALL-PV-TABLE-CACHES UPDATE-CLASS

+ MAP-PV-TABLE-REFERENCES-OF ADD-SLOT-ACCESSORS

+ WALKER::ENVIRONMENT-FUNCTION REMOVE-DIRECT-SUBCLASSES

+ REMOVE-SLOT-ACCESSORS SYMBOL-LESSP SYMBOL-OR-CONS-LESSP

+ |SETF PCL FIND-CLASS| |SETF PCL FIND-CLASS-PREDICATE|

+ PV-WRAPPERS-FROM-ALL-ARGS PV-TABLE-LOOKUP

+ PROCLAIM-DEFGENERIC UPDATE-CPL LIST-EQ UPDATE-SLOTS

+ COMPUTE-APPLICABLE-METHODS-FUNCTION VARIABLE-LEXICAL-P

+ VARIABLE-SPECIAL-P UPDATE-INITS UPDATE-STD-OR-STR-METHODS

+ SET-STANDARD-SVUC-METHOD EMIT-1-NIL-DLAP PLIST-VALUE

+ SET-STRUCTURE-SVUC-METHOD

+ EMIT-1-WRAPPER-COMPUTE-PRIMARY-CACHE-LOCATION

+ MEC-ALL-CLASSES-INTERNAL

+ EMIT-N-WRAPPER-COMPUTE-PRIMARY-CACHE-LOCATION

+ MEC-ALL-CLASSES %SET-CCLOSURE-ENV MEC-ALL-CLASS-LISTS

+ REDEFINE-FUNCTION METHODS-CONVERTER COMPUTE-LAYOUT NO-SLOT

+ PV-WRAPPERS-FROM-ALL-WRAPPERS NET-CONSTANT-CONVERTER

+ AUGMENT-TYPE CHANGE-CLASS-INTERNAL VALUE-FOR-CACHING

+ |SETF PCL METHOD-FUNCTION-PLIST| GET-KEY-ARG GET-KEY-ARG1

+ SET-METHODS SET-FUNCTION-PRETTY-ARGLIST

+ FIND-STANDARD-II-METHOD MAKE-EARLY-ACCESSOR

+ DOCTOR-DFUN-FOR-THE-DEBUGGER COMPUTE-STD-CPL

+ |SETF PCL GDEFINITION| MAKE-DISCRIMINATING-FUNCTION-ARGLIST

+ ADD-FORMS CPL-INCONSISTENT-ERROR

+ REDIRECT-EARLY-FUNCTION-INTERNAL ADD-TO-CVECTOR

+ BOOTSTRAP-SLOT-INDEX QUALIFIER-CHECK-RUNTIME

+ CPL-FORWARD-REFERENCED-CLASS-ERROR REAL-REMOVE-METHOD

+ WALKER::ENVIRONMENT-MACRO CANONICALIZE-SLOT-SPECIFICATION

+ CANONICALIZE-DEFCLASS-OPTION SET-WRAPPER

+ DEAL-WITH-ARGUMENTS-OPTION PARSE-QUALIFIER-PATTERN

+ SWAP-WRAPPERS-AND-SLOTS ITERATE::MV-SETQ

+ MAKE-UNORDERED-METHODS-EMF CLASS-MIGHT-PRECEDE-P

+ ITERATE::EXTRACT-SPECIAL-BINDINGS

+ WALKER::VARIABLE-SYMBOL-MACRO-P RAISE-METATYPE

+ SLOT-EXISTS-P PROCLAIM-DEFMETHOD STANDARD-INSTANCE-ACCESS

+ REMOVE-METHOD

+ SET-FUNCALLABLE-INSTANCE-FUNCTION

+ SYSTEM:%SET-COMPILED-FUNCTION-NAME FDEFINE-CAREFULLY

+ MAKE-INTERNAL-READER-METHOD-FUNCTION

+ MAKE-STD-READER-METHOD-FUNCTION

+ MAKE-STD-WRITER-METHOD-FUNCTION

+ ITERATE::SIMPLE-EXPAND-ITERATE-FORM

+ MAKE-STD-BOUNDP-METHOD-FUNCTION))

+(PROCLAIM '(FTYPE (FUNCTION NIL FIXNUM) GET-WRAPPER-CACHE-NUMBER))

+(IN-PACKAGE "PCL")

+

+(DOLIST (V '(|(FAST-WRITER-METHOD SLOT-OBJECT DIRECT-METHODS)|

+ |(FAST-WRITER-METHOD SLOT-OBJECT SLOTS)|

+ |(FAST-WRITER-METHOD SLOT-CLASS SLOTS)|

+ |(FAST-WRITER-METHOD SLOT-OBJECT DIRECT-SLOTS)|

+ |(FAST-WRITER-METHOD SLOT-CLASS DIRECT-SLOTS)|

+ |(FAST-WRITER-METHOD SLOT-OBJECT FROM-DEFCLASS-P)|

+ |(FAST-WRITER-METHOD SLOT-OBJECT METHODS)|

+ |(FAST-WRITER-METHOD STANDARD-GENERIC-FUNCTION METHODS)|

+ |(FAST-WRITER-METHOD SLOT-OBJECT OPTIONS)|

+ |(FAST-WRITER-METHOD SLOT-OBJECT DIRECT-SUBCLASSES)|

+ |(FAST-WRITER-METHOD SLOT-OBJECT DIRECT-SUPERCLASSES)|

+ ADD-READER-METHOD

+ SHORT-COMBINATION-IDENTITY-WITH-ONE-ARGUMENT

+ REMOVE-READER-METHOD |LISP::T class predicate|

+ EQL-SPECIALIZER-P |(SETF GENERIC-FUNCTION-NAME)|

+ OBJECT-PLIST SLOT-DEFINITION-DEFSTRUCT-ACCESSOR-SYMBOL

+ |PCL::STANDARD-OBJECT class predicate|

+ |PCL::STANDARD-SLOT-DEFINITION class predicate|

+ |PCL::STANDARD-DIRECT-SLOT-DEFINITION class predicate|

+ |PCL::STANDARD-EFFECTIVE-SLOT-DEFINITION class predicate|

+ |PCL::STANDARD-METHOD-COMBINATION class predicate|

+ |(FAST-READER-METHOD SLOT-OBJECT METHOD)|

+ |PCL::BUILT-IN-CLASS class predicate| SPECIALIZER-TYPE

+ |LISP::RATIO class predicate|

+ |LISP::RATIONAL class predicate| GF-DFUN-STATE

+ |(SETF GENERIC-FUNCTION-METHOD-CLASS)|

+ |(FAST-READER-METHOD SLOT-OBJECT DEFSTRUCT-ACCESSOR-SYMBOL)|

+ |(FAST-READER-METHOD STRUCTURE-SLOT-DEFINITION DEFSTRUCT-ACCESSOR-SYMBOL)|

+ |(SETF GENERIC-FUNCTION-METHOD-COMBINATION)|

+ CLASS-DEFSTRUCT-CONSTRUCTOR

+ |(FAST-READER-METHOD SLOT-OBJECT SOURCE)|

+ |(FAST-READER-METHOD DEFINITION-SOURCE-MIXIN SOURCE)|

+ METHOD-FAST-FUNCTION |(SETF GENERIC-FUNCTION-METHODS)|

+ |(SETF GF-PRETTY-ARGLIST)|

+ |(FAST-READER-METHOD SLOT-OBJECT INITIALIZE-INFO)|

+ |(FAST-READER-METHOD SLOT-CLASS INITIALIZE-INFO)|

+ |(FAST-READER-METHOD SLOT-OBJECT ARG-INFO)|

+ |(FAST-READER-METHOD STANDARD-GENERIC-FUNCTION ARG-INFO)|

+ SPECIALIZERP EXACT-CLASS-SPECIALIZER-P

+ |(FAST-READER-METHOD SLOT-OBJECT WRAPPER)|

+ |(FAST-READER-METHOD PCL-CLASS WRAPPER)|

+ |(FAST-READER-METHOD SLOT-OBJECT INITARGS)|

+ |(FAST-READER-METHOD SLOT-DEFINITION INITARGS)|

+ |(FAST-READER-METHOD SHORT-METHOD-COMBINATION OPERATOR)|

+ |(FAST-READER-METHOD SLOT-OBJECT OPERATOR)|

+ |(FAST-READER-METHOD SLOT-OBJECT DEFSTRUCT-CONSTRUCTOR)|

+ |(FAST-READER-METHOD STRUCTURE-CLASS DEFSTRUCT-CONSTRUCTOR)|

+ |LISP::CHARACTER class predicate|

+ COMPATIBLE-META-CLASS-CHANGE-P

+ |LISP::SEQUENCE class predicate|

+ |(FAST-READER-METHOD SLOT-OBJECT CLASS-EQ-SPECIALIZER)|

+ |(FAST-READER-METHOD CLASS CLASS-EQ-SPECIALIZER)|

+ |(BOUNDP READER-FUNCTION)| |(BOUNDP PREDICATE-NAME)|

+ |(BOUNDP READERS)| UPDATE-GF-DFUN

+ |(BOUNDP CLASS-PRECEDENCE-LIST)|

+ |(BOUNDP ACCESSOR-FLAGS)| |(BOUNDP LOCATION)|

+ |(BOUNDP DOCUMENTATION)| SPECIALIZER-OBJECT

+ |(BOUNDP INCOMPATIBLE-SUPERCLASS-LIST)|

+ ACCESSOR-METHOD-SLOT-NAME |(BOUNDP SPECIALIZERS)|

+ |(BOUNDP IDENTITY-WITH-ONE-ARGUMENT)|

+ |(FAST-BOUNDP-METHOD SLOT-OBJECT DEFSTRUCT-ACCESSOR-SYMBOL)|

+ SPECIALIZER-CLASS |(BOUNDP PRETTY-ARGLIST)|

+ |PCL::PCL-CLASS class predicate|

+ |PCL::STD-CLASS class predicate|

+ |(BOUNDP DEFSTRUCT-FORM)|

+ |(SETF SLOT-DEFINITION-DEFSTRUCT-ACCESSOR-SYMBOL)|

+ CLASS-EQ-SPECIALIZER-P

+ |(FAST-BOUNDP-METHOD SLOT-OBJECT SOURCE)| SLOTS-FETCHER

+ |(SETF SLOT-ACCESSOR-STD-P)| REMOVE-WRITER-METHOD

+ |(BOUNDP WRITER-FUNCTION)| |(BOUNDP INITFUNCTION)|

+ |(FAST-BOUNDP-METHOD SLOT-OBJECT INITIALIZE-INFO)|

+ |(FAST-BOUNDP-METHOD SLOT-OBJECT ARG-INFO)|

+ STRUCTURE-CLASS-P |(BOUNDP WRITERS)|

+ |(BOUNDP INITFORM)|

+ |(FAST-BOUNDP-METHOD SLOT-OBJECT WRAPPER)|

+ |(FAST-BOUNDP-METHOD SLOT-OBJECT INITARGS)|

+ |LISP::BIT-VECTOR class predicate|

+ |(FAST-BOUNDP-METHOD SLOT-OBJECT DEFSTRUCT-CONSTRUCTOR)|

+ UPDATE-CONSTRUCTORS |(BOUNDP SLOT-NAME)|

+ |(SETF SLOT-DEFINITION-INITARGS)| |(BOUNDP ALLOCATION)|

+ |(FAST-BOUNDP-METHOD SLOT-OBJECT CLASS-EQ-SPECIALIZER)|

+ DOCUMENTATION |(BOUNDP FUNCTION)|

+ |(BOUNDP GENERIC-FUNCTION)| |(BOUNDP LAMBDA-LIST)|

+ METHOD-PRETTY-ARGLIST |(BOUNDP SLOT-DEFINITION)|

+ |LISP::ARRAY class predicate|

+ |(BOUNDP CAN-PRECEDE-LIST)| |(BOUNDP PROTOTYPE)|

+ CLASS-EQ-SPECIALIZER INFORM-TYPE-SYSTEM-ABOUT-CLASS

+ |PCL::DEFINITION-SOURCE-MIXIN class predicate|

+ |(BOUNDP DFUN-STATE)| |(BOUNDP FROM-DEFCLASS-P)|

+ |(READER METHOD)|

+ |(CALL STANDARD-COMPUTE-EFFECTIVE-METHOD)|

+ |(BOUNDP FAST-FUNCTION)|

+ |LISP::COMPLEX class predicate| |(BOUNDP METHOD-CLASS)|

+ |(READER SOURCE)| |(BOUNDP INTERNAL-WRITER-FUNCTION)|

+ |(BOUNDP INTERNAL-READER-FUNCTION)|

+ |(BOUNDP METHOD-COMBINATION)| ACCESSOR-METHOD-CLASS

+ |(BOUNDP DIRECT-SLOTS)| |(BOUNDP DIRECT-METHODS)|

+ |(BOUNDP BOUNDP-FUNCTION)| |(BOUNDP DIRECT-SUBCLASSES)|

+ |(BOUNDP DIRECT-SUPERCLASSES)| |(BOUNDP METHODS)|

+ |(BOUNDP OPTIONS)| |(WRITER METHOD)|

+ |PCL::DEPENDENT-UPDATE-MIXIN class predicate|

+ GENERIC-FUNCTION-PRETTY-ARGLIST |(WRITER SOURCE)|

+ |(FAST-METHOD SLOTS-TO-INSPECT (SLOT-CLASS SLOT-OBJECT))|

+ |(FAST-METHOD SPECIALIZER-DIRECT-GENERIC-FUNCTIONS (SPECIALIZER-WITH-OBJECT))|

+ |(FAST-METHOD SPECIALIZER-DIRECT-METHODS (SPECIALIZER-WITH-OBJECT))|

+ |(FAST-METHOD UPDATE-INSTANCE-FOR-DIFFERENT-CLASS (STANDARD-OBJECT STANDARD-OBJECT))|

+ |(FAST-METHOD REINITIALIZE-INSTANCE (SLOT-OBJECT))|

+ |(FAST-METHOD INITIALIZE-INSTANCE (SLOT-OBJECT))|

+ |(FAST-METHOD SPECIALIZER-CLASS (EQL-SPECIALIZER))|

+ |(FAST-METHOD SAME-SPECIALIZER-P (EQL-SPECIALIZER EQL-SPECIALIZER))|

+ |(FAST-METHOD SAME-SPECIALIZER-P (CLASS-EQ-SPECIALIZER CLASS-EQ-SPECIALIZER))|

+ |(FAST-METHOD SAME-SPECIALIZER-P (SPECIALIZER SPECIALIZER))|

+ |(FAST-METHOD SPECIALIZER-METHOD-TABLE (CLASS-EQ-SPECIALIZER))|

+ |(FAST-METHOD SPECIALIZER-METHOD-TABLE (EQL-SPECIALIZER))|

+ MAKE-BOUNDP-METHOD-FUNCTION

+ |LISP::STRING class predicate|

+ |(FAST-METHOD (SETF DOCUMENTATION) (T DOCUMENTATION-MIXIN))|

+ |(FAST-METHOD DOCUMENTATION (DOCUMENTATION-MIXIN))|

+ |PCL::METAOBJECT class predicate|

+ |(FAST-METHOD ACCESSOR-METHOD-SLOT-NAME (TRACED-METHOD))|

+ |(FAST-METHOD METHOD-QUALIFIERS (TRACED-METHOD))|

+ |(FAST-METHOD METHOD-SPECIALIZERS (TRACED-METHOD))|

+ |(FAST-METHOD METHOD-LAMBDA-LIST (TRACED-METHOD))|

+ |(FAST-METHOD METHOD-PRETTY-ARGLIST (STANDARD-METHOD))|

+ |(FAST-METHOD GENERIC-FUNCTION-PRETTY-ARGLIST (STANDARD-GENERIC-FUNCTION))|

+ |(FAST-METHOD FUNCTION-KEYWORDS (STANDARD-METHOD))|

+ |(FAST-METHOD COMPUTE-DISCRIMINATING-FUNCTION (STANDARD-GENERIC-FUNCTION))|

+ |(FAST-METHOD REINITIALIZE-INSTANCE :AFTER (STANDARD-GENERIC-FUNCTION))|

+ |(FAST-METHOD INITIALIZE-INSTANCE :AFTER (STANDARD-GENERIC-FUNCTION))|

+ |(FAST-METHOD GF-FAST-METHOD-FUNCTION-P (STANDARD-GENERIC-FUNCTION))|

+ |(FAST-METHOD GENERIC-FUNCTION-LAMBDA-LIST (GENERIC-FUNCTION))|

+ |(FAST-METHOD COMPUTE-DISCRIMINATING-FUNCTION-ARGLIST-INFO (STANDARD-GENERIC-FUNCTION))|

+ |(FAST-METHOD METHOD-QUALIFIERS (STANDARD-METHOD))|

+ |(FAST-METHOD REINITIALIZE-INSTANCE (STANDARD-METHOD))|

+ |(FAST-METHOD ACCESSOR-METHOD-CLASS (STANDARD-WRITER-METHOD))|

+ |(FAST-METHOD ACCESSOR-METHOD-CLASS (STANDARD-ACCESSOR-METHOD))|

+ |(FAST-METHOD METHOD-FUNCTION (STANDARD-METHOD))|

+ |(FAST-METHOD CHANGE-CLASS (T SYMBOL))|

+ |(FAST-METHOD MAKE-INSTANCES-OBSOLETE (SYMBOL))|

+ |(FAST-METHOD REMOVE-DIRECT-METHOD (SPECIALIZER-WITH-OBJECT METHOD))|

+ |(FAST-METHOD ADD-DIRECT-METHOD (SPECIALIZER-WITH-OBJECT METHOD))|

+ |(FAST-METHOD REMOVE-DIRECT-METHOD (CLASS METHOD))|

+ |(FAST-METHOD ADD-DIRECT-METHOD (CLASS METHOD))|

+ |(FAST-METHOD (SETF DOCUMENTATION) (T STANDARD-SLOT-DEFINITION))|

+ |(FAST-METHOD DOCUMENTATION (STANDARD-SLOT-DEFINITION))|

+ |(FAST-METHOD SLOT-DEFINITION-ALLOCATION (STRUCTURE-SLOT-DEFINITION))|

+ |(FAST-METHOD INITIALIZE-INTERNAL-SLOT-FUNCTIONS (EFFECTIVE-SLOT-DEFINITION))|

+ |(FAST-METHOD MAKE-INSTANCE (SYMBOL))|

+ |(FAST-METHOD SLOT-MAKUNBOUND-USING-CLASS (STRUCTURE-CLASS STRUCTURE-OBJECT STRUCTURE-EFFECTIVE-SLOT-DEFINITION))|

+ |(FAST-METHOD SLOT-BOUNDP-USING-CLASS (STRUCTURE-CLASS STRUCTURE-OBJECT STRUCTURE-EFFECTIVE-SLOT-DEFINITION))|

+ |(FAST-METHOD (SETF SLOT-VALUE-USING-CLASS) (T STRUCTURE-CLASS STRUCTURE-OBJECT STRUCTURE-EFFECTIVE-SLOT-DEFINITION))|

+ |(FAST-METHOD SLOT-VALUE-USING-CLASS (STRUCTURE-CLASS STRUCTURE-OBJECT STRUCTURE-EFFECTIVE-SLOT-DEFINITION))|

+ |(FAST-METHOD SLOT-MAKUNBOUND-USING-CLASS (STD-CLASS STANDARD-OBJECT STANDARD-EFFECTIVE-SLOT-DEFINITION))|

+ |(FAST-METHOD SLOT-BOUNDP-USING-CLASS (STD-CLASS STANDARD-OBJECT STANDARD-EFFECTIVE-SLOT-DEFINITION))|

+ |(FAST-METHOD (SETF SLOT-VALUE-USING-CLASS) (T STD-CLASS STANDARD-OBJECT STANDARD-EFFECTIVE-SLOT-DEFINITION))|

+ |(FAST-METHOD SLOT-VALUE-USING-CLASS (STD-CLASS STANDARD-OBJECT STANDARD-EFFECTIVE-SLOT-DEFINITION))|

+ |(FAST-METHOD SPECIALIZER-CLASS (CLASS))|

+ |(FAST-METHOD SAME-SPECIALIZER-P (CLASS CLASS))|

+ |(FAST-METHOD ALLOCATE-INSTANCE (FUNCALLABLE-STANDARD-CLASS))|

+ |(FAST-METHOD VALIDATE-SUPERCLASS (FUNCALLABLE-STANDARD-CLASS STANDARD-CLASS))|

+ |(FAST-METHOD RAW-INSTANCE-ALLOCATOR (FUNCALLABLE-STANDARD-CLASS))|

+ |(FAST-METHOD SLOTS-FETCHER (FUNCALLABLE-STANDARD-CLASS))|

+ |(FAST-METHOD WRAPPER-FETCHER (FUNCALLABLE-STANDARD-CLASS))|

+ |(FAST-METHOD COMPUTE-CLASS-PRECEDENCE-LIST (SLOT-CLASS))|

+ |(FAST-METHOD VALIDATE-SUPERCLASS (SLOT-CLASS FORWARD-REFERENCED-CLASS))|

+ |(FAST-METHOD VALIDATE-SUPERCLASS (CLASS BUILT-IN-CLASS))|

+ |(FAST-METHOD CLASS-DEFAULT-INITARGS (BUILT-IN-CLASS))|

+ |(FAST-METHOD CLASS-DIRECT-DEFAULT-INITARGS (BUILT-IN-CLASS))|

+ |(FAST-METHOD CLASS-SLOTS (BUILT-IN-CLASS))|

+ |(FAST-METHOD CLASS-DIRECT-SLOTS (BUILT-IN-CLASS))|

+ |(FAST-METHOD CHANGE-CLASS (STANDARD-OBJECT FUNCALLABLE-STANDARD-CLASS))|

+ |(FAST-METHOD CHANGE-CLASS (STANDARD-OBJECT STANDARD-CLASS))|

+ |(FAST-METHOD MAKE-INSTANCES-OBSOLETE (STD-CLASS))|

+ |(FAST-METHOD VALIDATE-SUPERCLASS (CLASS CLASS))|

+ |(FAST-METHOD COMPUTE-SLOTS :AROUND (STRUCTURE-CLASS))|

+ |(FAST-METHOD COMPUTE-SLOTS (STRUCTURE-CLASS))|

+ |(FAST-METHOD COMPUTE-SLOTS :AROUND (STD-CLASS))|

+ |(FAST-METHOD COMPUTE-SLOTS (STD-CLASS))|

+ |(FAST-METHOD COMPUTE-DEFAULT-INITARGS (SLOT-CLASS))|

+ |(FAST-METHOD FINALIZE-INHERITANCE (STD-CLASS))|

+ |(FAST-METHOD FINALIZE-INHERITANCE (STRUCTURE-CLASS))|

+ |(FAST-METHOD REINITIALIZE-INSTANCE :AFTER (SLOT-CLASS))|

+ |(FAST-METHOD REINITIALIZE-INSTANCE :BEFORE (SLOT-CLASS))|

+ |(FAST-METHOD ENSURE-CLASS-USING-CLASS (T PCL-CLASS))|

+ |(FAST-METHOD SPECIALIZER-DIRECT-GENERIC-FUNCTIONS (CLASS))|

+ |(FAST-METHOD SPECIALIZER-DIRECT-METHODS (CLASS))|

+ |(FAST-METHOD REMOVE-DIRECT-SUBCLASS (CLASS CLASS))|

+ |(FAST-METHOD ADD-DIRECT-SUBCLASS (CLASS CLASS))|

+ |(FAST-METHOD CLASS-SLOT-CELLS (STD-CLASS))|

+ |(FAST-METHOD CLASS-CONSTRUCTORS (SLOT-CLASS))|

+ |(FAST-METHOD CLASS-DEFAULT-INITARGS (SLOT-CLASS))|

+ |(FAST-METHOD CLASS-DIRECT-DEFAULT-INITARGS (SLOT-CLASS))|

+ |(FAST-METHOD CLASS-PROTOTYPE (STRUCTURE-CLASS))|

+ |(FAST-METHOD CLASS-PROTOTYPE (STD-CLASS))|

+ |(FAST-METHOD CLASS-FINALIZED-P (PCL-CLASS))|

+ |(FAST-METHOD MAKE-INSTANCE (CLASS))|

+ |(FAST-METHOD ALLOCATE-INSTANCE (STRUCTURE-CLASS))|

+ |(FAST-METHOD ALLOCATE-INSTANCE (STANDARD-CLASS))|

+ |(FAST-METHOD RAW-INSTANCE-ALLOCATOR (STANDARD-CLASS))|

+ |(FAST-METHOD SLOTS-FETCHER (STANDARD-CLASS))|

+ |(FAST-METHOD WRAPPER-FETCHER (STANDARD-CLASS))|

+ CLASS-PREDICATE-NAME

+ |PCL::STRUCTURE-OBJECT class predicate|

+ |PCL::STRUCTURE-SLOT-DEFINITION class predicate|

+ |PCL::STRUCTURE-DIRECT-SLOT-DEFINITION class predicate|

+ |PCL::STRUCTURE-EFFECTIVE-SLOT-DEFINITION class predicate|

+ |LISP::SYMBOL class predicate| CLASSP

+ |PCL::EFFECTIVE-SLOT-DEFINITION class predicate|

+ |(COMBINED-METHOD SHARED-INITIALIZE)|

+ LEGAL-QUALIFIERS-P ADD-BOUNDP-METHOD

+ LEGAL-LAMBDA-LIST-P |LISP::VECTOR class predicate|

+ |SETF PCL GENERIC-FUNCTION-NAME|

+ |(READER READER-FUNCTION)| |(READER PREDICATE-NAME)|

+ |(READER READERS)| DESCRIBE-OBJECT

+ |(READER CLASS-PRECEDENCE-LIST)|

+ |(READER ACCESSOR-FLAGS)| |(READER LOCATION)|

+ |(READER DOCUMENTATION)| CLASS-INITIALIZE-INFO

+ |(SETF CLASS-SLOT-VALUE)| MAKE-WRITER-METHOD-FUNCTION

+ |SETF PCL GF-DFUN-STATE|

+ |(READER INCOMPATIBLE-SUPERCLASS-LIST)|

+ |(READER SPECIALIZERS)|

+ |(READER IDENTITY-WITH-ONE-ARGUMENT)|

+ |(SETF CLASS-INITIALIZE-INFO)|

+ |(READER PRETTY-ARGLIST)| |(READER DEFSTRUCT-FORM)|

+ |SETF PCL SLOT-DEFINITION-NAME| |SETF PCL CLASS-NAME|

+ |(WRITER READER-FUNCTION)|

+ |(SETF CLASS-DEFSTRUCT-CONSTRUCTOR)|

+ |(WRITER PREDICATE-NAME)| |(WRITER READERS)|

+ |(READER WRITER-FUNCTION)| |(READER INITFUNCTION)|

+ INITIALIZE-INTERNAL-SLOT-FUNCTIONS

+ |SETF PCL SLOT-DEFINITION-TYPE|

+ |(WRITER CLASS-PRECEDENCE-LIST)| |(READER WRITERS)|

+ |(WRITER ACCESSOR-FLAGS)| |(READER INITFORM)|

+ METHOD-COMBINATION-P |(WRITER LOCATION)|

+ |(WRITER DOCUMENTATION)|

+ |(CALL REAL-ENSURE-GF-USING-CLASS--GENERIC-FUNCTION)|

+ |SETF PCL GENERIC-FUNCTION-METHODS|

+ |SETF PCL GENERIC-FUNCTION-METHOD-COMBINATION|

+ |SETF PCL METHOD-GENERIC-FUNCTION| |(READER SLOT-NAME)|

+ |(WRITER INCOMPATIBLE-SUPERCLASS-LIST)|

+ |SETF PCL SLOT-ACCESSOR-STD-P|

+ |(CALL REAL-MAKE-METHOD-INITARGS-FORM)|

+ |(READER ALLOCATION)| |(WRITER SPECIALIZERS)|

+ |(CALL REAL-ENSURE-GF-USING-CLASS--NULL)|

+ |(WRITER IDENTITY-WITH-ONE-ARGUMENT)|

+ |(SETF METHOD-GENERIC-FUNCTION)|

+ |(WRITER PRETTY-ARGLIST)| LEGAL-SPECIALIZERS-P

+ |SETF PCL OBJECT-PLIST| |LISP::FLOAT class predicate|

+ |(WRITER DEFSTRUCT-FORM)| |(READER FUNCTION)|

+ |(READER GENERIC-FUNCTION)| |(READER LAMBDA-LIST)|

+ |(READER SLOT-DEFINITION)|

+ |PCL::CLASS-PROTOTYPE-SPECIALIZER class predicate|

+ |SETF PCL SLOT-DEFINITION-INITFORM|

+ |SETF PCL CLASS-DEFSTRUCT-FORM|

+ |(READER CAN-PRECEDE-LIST)|

+ |SETF PCL GENERIC-FUNCTION-METHOD-CLASS|

+ |(READER PROTOTYPE)| |(WRITER WRITER-FUNCTION)|

+ |(WRITER INITFUNCTION)| |(WRITER WRITERS)|

+ SLOT-ACCESSOR-STD-P |(WRITER INITFORM)|

+ |(READER DFUN-STATE)| |(READER FROM-DEFCLASS-P)|

+ |SETF PCL GF-PRETTY-ARGLIST|

+ |SETF PCL SLOT-ACCESSOR-FUNCTION|

+ |SETF PCL SLOT-DEFINITION-LOCATION|

+ |SETF PCL SLOT-DEFINITION-READER-FUNCTION|

+ |SETF PCL SLOT-DEFINITION-WRITER-FUNCTION|

+ |SETF PCL SLOT-DEFINITION-BOUNDP-FUNCTION|

+ |SETF PCL SLOT-DEFINITION-INTERNAL-READER-FUNCTION|

+ |SETF PCL SLOT-DEFINITION-INTERNAL-WRITER-FUNCTION|

+ |SETF PCL SLOT-DEFINITION-ALLOCATION|

+ |SETF PCL SLOT-DEFINITION-INITFUNCTION|

+ |(WRITER SLOT-NAME)| |(BOUNDP NAME)|

+ |(WRITER ALLOCATION)| |(READER FAST-FUNCTION)|

+ |(READER METHOD-CLASS)| |(SETF OBJECT-PLIST)|

+ |(READER INTERNAL-WRITER-FUNCTION)|

+ |(READER INTERNAL-READER-FUNCTION)|

+ |(READER METHOD-COMBINATION)|

+ METHOD-COMBINATION-OPTIONS |(READER DIRECT-SLOTS)|

+ |(READER DIRECT-METHODS)|

+ |SETF PCL SLOT-DEFINITION-READERS|

+ |(READER BOUNDP-FUNCTION)| |(WRITER FUNCTION)|

+ |(WRITER GENERIC-FUNCTION)|

+ |(READER DIRECT-SUBCLASSES)|

+ |(READER DIRECT-SUPERCLASSES)| |SETF PCL DOCUMENTATION|

+ |(WRITER LAMBDA-LIST)| |LISP::LIST class predicate|

+ FUNCALLABLE-STANDARD-CLASS-P

+ |(FAST-WRITER-METHOD SLOT-OBJECT METHOD)|

+ |(BOUNDP CLASS)| |(WRITER SLOT-DEFINITION)|

+ |(READER METHODS)| |(READER OPTIONS)|

+ |(WRITER CAN-PRECEDE-LIST)|

+ |SETF PCL SLOT-DEFINITION-CLASS|

+ |SETF PCL SLOT-VALUE-USING-CLASS|

+ |(FAST-WRITER-METHOD SLOT-OBJECT DEFSTRUCT-ACCESSOR-SYMBOL)|

+ |(FAST-WRITER-METHOD STRUCTURE-SLOT-DEFINITION DEFSTRUCT-ACCESSOR-SYMBOL)|

+ |(WRITER PROTOTYPE)| |(BOUNDP OBJECT)| |(BOUNDP TYPE)|

+ CLASS-CAN-PRECEDE-LIST |SETF PCL CLASS-DIRECT-SLOTS|

+ |SETF PCL CLASS-SLOTS| SLOT-ACCESSOR-FUNCTION

+ |(BOUNDP PLIST)|

+ |SETF PCL CLASS-INCOMPATIBLE-SUPERCLASS-LIST|

+ |SETF PCL SLOT-DEFINITION-WRITERS|

+ |(FAST-WRITER-METHOD SLOT-OBJECT SOURCE)|

+ |(WRITER DFUN-STATE)| |(WRITER FROM-DEFCLASS-P)|

+ |(BOUNDP SLOTS)| SLOT-CLASS-P

+ MAKE-READER-METHOD-FUNCTION LEGAL-METHOD-FUNCTION-P

+ |(FAST-WRITER-METHOD SLOT-OBJECT INITIALIZE-INFO)|

+ |(FAST-WRITER-METHOD SLOT-CLASS INITIALIZE-INFO)|

+ |(FAST-WRITER-METHOD SLOT-OBJECT ARG-INFO)|

+ |PCL::PLIST-MIXIN class predicate|

+ |(WRITER FAST-FUNCTION)| |(WRITER METHOD-CLASS)|

+ |(FAST-WRITER-METHOD SLOT-OBJECT WRAPPER)|

+ |(WRITER INTERNAL-WRITER-FUNCTION)|

+ |(WRITER INTERNAL-READER-FUNCTION)|

+ |(WRITER METHOD-COMBINATION)| GET-METHOD

+ |(WRITER DIRECT-SLOTS)| |(WRITER DIRECT-METHODS)|

+ |(FAST-WRITER-METHOD SLOT-OBJECT INITARGS)|

+ |(FAST-WRITER-METHOD SLOT-DEFINITION INITARGS)|

+ |(FAST-WRITER-METHOD SLOT-OBJECT OPERATOR)|

+ |(FAST-WRITER-METHOD SLOT-OBJECT DEFSTRUCT-CONSTRUCTOR)|

+ |(FAST-WRITER-METHOD STRUCTURE-CLASS DEFSTRUCT-CONSTRUCTOR)|

+ |(WRITER BOUNDP-FUNCTION)| |(WRITER DIRECT-SUBCLASSES)|

+ |(WRITER DIRECT-SUPERCLASSES)|

+ |(FAST-WRITER-METHOD SLOT-OBJECT CLASS-EQ-SPECIALIZER)|

+ |(WRITER METHODS)| |(WRITER OPTIONS)|

+ SHORT-METHOD-COMBINATION-P GF-ARG-INFO

+ SPECIALIZER-METHOD-TABLE MAKE-METHOD-INITARGS-FORM

+ CLASS-DEFSTRUCT-FORM |LISP::INTEGER class predicate|

+ |(FAST-READER-METHOD SLOT-OBJECT PREDICATE-NAME)|

+ |(FAST-READER-METHOD CLASS PREDICATE-NAME)|

+ |(FAST-READER-METHOD CLASS NAME)|

+ |(FAST-READER-METHOD SLOT-DEFINITION NAME)|

+ |(FAST-READER-METHOD SLOT-OBJECT SLOT-NAME)|

+ |(FAST-READER-METHOD STANDARD-ACCESSOR-METHOD SLOT-NAME)|

+ |(FAST-READER-METHOD SLOT-OBJECT DFUN-STATE)|

+ |(FAST-READER-METHOD STANDARD-GENERIC-FUNCTION DFUN-STATE)|

+ |(FAST-READER-METHOD SLOT-OBJECT NAME)|

+ |(FAST-READER-METHOD STANDARD-GENERIC-FUNCTION NAME)|

+ GF-PRETTY-ARGLIST SAME-SPECIALIZER-P

+ SLOT-DEFINITION-BOUNDP-FUNCTION

+ SLOT-DEFINITION-WRITER-FUNCTION

+ SLOT-DEFINITION-READER-FUNCTION

+ SLOT-DEFINITION-INTERNAL-WRITER-FUNCTION

+ SLOT-DEFINITION-INTERNAL-READER-FUNCTION

+ |(FAST-READER-METHOD SLOT-OBJECT CLASS)|

+ |(FAST-READER-METHOD SLOT-DEFINITION CLASS)|

+ |(FAST-READER-METHOD SLOT-OBJECT ACCESSOR-FLAGS)|

+ |(FAST-READER-METHOD SLOT-OBJECT METHOD-CLASS)|

+ |(FAST-READER-METHOD STANDARD-GENERIC-FUNCTION METHOD-CLASS)|

+ |(FAST-READER-METHOD TRACED-METHOD GENERIC-FUNCTION)|

+ |(FAST-READER-METHOD TRACED-METHOD FUNCTION)|

+ |(FAST-READER-METHOD LONG-METHOD-COMBINATION FUNCTION)|

+ |(FAST-READER-METHOD SLOT-OBJECT INITFUNCTION)|

+ |(FAST-READER-METHOD SLOT-DEFINITION INITFUNCTION)|

+ |(FAST-READER-METHOD SLOT-OBJECT ALLOCATION)|

+ |(FAST-READER-METHOD STANDARD-SLOT-DEFINITION ALLOCATION)|

+ |(FAST-READER-METHOD SLOT-OBJECT INTERNAL-WRITER-FUNCTION)|

+ |(FAST-READER-METHOD STRUCTURE-SLOT-DEFINITION INTERNAL-WRITER-FUNCTION)|

+ |(FAST-READER-METHOD SLOT-OBJECT INTERNAL-READER-FUNCTION)|

+ |(FAST-READER-METHOD STRUCTURE-SLOT-DEFINITION INTERNAL-READER-FUNCTION)|

+ |(FAST-READER-METHOD SLOT-OBJECT BOUNDP-FUNCTION)|

+ |(FAST-READER-METHOD EFFECTIVE-SLOT-DEFINITION BOUNDP-FUNCTION)|

+ |(FAST-READER-METHOD SLOT-OBJECT WRITER-FUNCTION)|

+ |(FAST-READER-METHOD EFFECTIVE-SLOT-DEFINITION WRITER-FUNCTION)|

+ |(FAST-READER-METHOD SLOT-OBJECT READER-FUNCTION)|

+ |(FAST-READER-METHOD EFFECTIVE-SLOT-DEFINITION READER-FUNCTION)|

+ |(FAST-READER-METHOD SLOT-OBJECT LOCATION)|

+ |(FAST-READER-METHOD STANDARD-EFFECTIVE-SLOT-DEFINITION LOCATION)|

+ |(FAST-READER-METHOD SLOT-OBJECT FAST-FUNCTION)|

+ |(FAST-READER-METHOD STANDARD-METHOD FAST-FUNCTION)|

+ |(FAST-READER-METHOD SLOT-OBJECT FUNCTION)|

+ |(FAST-READER-METHOD SLOT-OBJECT GENERIC-FUNCTION)|

+ |(FAST-READER-METHOD STANDARD-METHOD GENERIC-FUNCTION)|

+ |(FAST-READER-METHOD SLOT-OBJECT SLOT-DEFINITION)|

+ |(FAST-READER-METHOD STANDARD-ACCESSOR-METHOD SLOT-DEFINITION)|

+ |(FAST-READER-METHOD SLOT-OBJECT METHOD-COMBINATION)|

+ |(FAST-READER-METHOD STANDARD-GENERIC-FUNCTION METHOD-COMBINATION)|

+ |(FAST-READER-METHOD SLOT-OBJECT DOCUMENTATION)|

+ |(FAST-READER-METHOD STANDARD-METHOD-COMBINATION DOCUMENTATION)|

+ |(FAST-READER-METHOD SLOT-OBJECT WRITERS)|

+ |(FAST-READER-METHOD SLOT-DEFINITION WRITERS)|

+ |(FAST-READER-METHOD SLOT-OBJECT READERS)|

+ |(FAST-READER-METHOD SLOT-DEFINITION READERS)|

+ |(FAST-READER-METHOD SLOT-OBJECT SPECIALIZERS)|

+ |(FAST-READER-METHOD STANDARD-METHOD SPECIALIZERS)|

+ |(FAST-READER-METHOD SHORT-METHOD-COMBINATION IDENTITY-WITH-ONE-ARGUMENT)|

+ |(FAST-READER-METHOD SLOT-OBJECT IDENTITY-WITH-ONE-ARGUMENT)|

+ |(FAST-READER-METHOD SPECIALIZER TYPE)|

+ |(FAST-READER-METHOD SLOT-OBJECT PROTOTYPE)|

+ |(FAST-READER-METHOD PCL-CLASS PROTOTYPE)|

+ |(FAST-READER-METHOD CLASS-EQ-SPECIALIZER OBJECT)|

+ |(FAST-READER-METHOD CLASS-PROTOTYPE-SPECIALIZER OBJECT)|

+ |(FAST-READER-METHOD SLOT-OBJECT OBJECT)|

+ |(FAST-READER-METHOD EQL-SPECIALIZER OBJECT)|

+ |(FAST-READER-METHOD SLOT-DEFINITION TYPE)|

+ |(FAST-READER-METHOD SLOT-OBJECT TYPE)|

+ |(FAST-READER-METHOD STANDARD-METHOD-COMBINATION TYPE)|

+ |(FAST-READER-METHOD SLOT-OBJECT DEFSTRUCT-FORM)|

+ |(FAST-READER-METHOD STRUCTURE-CLASS DEFSTRUCT-FORM)|

+ |(FAST-READER-METHOD SLOT-OBJECT INITFORM)|

+ |(FAST-READER-METHOD SLOT-DEFINITION INITFORM)|

+ |(FAST-READER-METHOD SLOT-OBJECT PLIST)|

+ |(FAST-READER-METHOD PLIST-MIXIN PLIST)|

+ |(FAST-READER-METHOD SLOT-OBJECT INCOMPATIBLE-SUPERCLASS-LIST)|

+ |(FAST-READER-METHOD PCL-CLASS INCOMPATIBLE-SUPERCLASS-LIST)|

+ |(FAST-READER-METHOD SLOT-OBJECT CAN-PRECEDE-LIST)|

+ |(FAST-READER-METHOD PCL-CLASS CAN-PRECEDE-LIST)|

+ |(FAST-READER-METHOD SLOT-OBJECT CLASS-PRECEDENCE-LIST)|

+ |(FAST-READER-METHOD PCL-CLASS CLASS-PRECEDENCE-LIST)|

+ |(FAST-READER-METHOD SLOT-OBJECT LAMBDA-LIST)|

+ |(FAST-READER-METHOD STANDARD-METHOD LAMBDA-LIST)|

+ |(FAST-READER-METHOD SLOT-OBJECT PRETTY-ARGLIST)|

+ |(FAST-READER-METHOD STANDARD-GENERIC-FUNCTION PRETTY-ARGLIST)|

+ |(FAST-READER-METHOD SLOT-OBJECT DIRECT-METHODS)|

+ |(FAST-READER-METHOD SLOT-OBJECT SLOTS)|

+ |(FAST-READER-METHOD SLOT-CLASS SLOTS)|

+ |(FAST-READER-METHOD SLOT-OBJECT DIRECT-SLOTS)|

+ |(FAST-READER-METHOD SLOT-CLASS DIRECT-SLOTS)|

+ |(FAST-READER-METHOD SLOT-OBJECT FROM-DEFCLASS-P)|

+ |(FAST-READER-METHOD SLOT-OBJECT METHODS)|

+ |(FAST-READER-METHOD STANDARD-GENERIC-FUNCTION METHODS)|

+ |(FAST-READER-METHOD SLOT-OBJECT OPTIONS)|

+ |(FAST-READER-METHOD STANDARD-METHOD-COMBINATION OPTIONS)|

+ |(FAST-READER-METHOD SLOT-OBJECT DIRECT-SUBCLASSES)|

+ |(FAST-READER-METHOD CLASS DIRECT-SUBCLASSES)|

+ |(FAST-READER-METHOD SLOT-OBJECT DIRECT-SUPERCLASSES)|

+ |(FAST-READER-METHOD CLASS DIRECT-SUPERCLASSES)|

+ SLOT-DEFINITION-CLASS EQL-SPECIALIZER-OBJECT

+ |PCL::DIRECT-SLOT-DEFINITION class predicate|

+ CLASS-CONSTRUCTORS |(BOUNDP WRAPPER)| SLOTS-TO-INSPECT

+ |(FAST-BOUNDP-METHOD SLOT-OBJECT PREDICATE-NAME)|

+ |(FAST-BOUNDP-METHOD SLOT-OBJECT SLOT-NAME)|

+ |(FAST-BOUNDP-METHOD SLOT-OBJECT DFUN-STATE)|

+ |(FAST-BOUNDP-METHOD SLOT-OBJECT NAME)|

+ |(BOUNDP DEFSTRUCT-ACCESSOR-SYMBOL)|

+ SPECIALIZER-DIRECT-GENERIC-FUNCTIONS

+ |(BOUNDP CLASS-EQ-SPECIALIZER)|

+ |(SETF SLOT-DEFINITION-NAME)| ADD-WRITER-METHOD

+ |(FAST-BOUNDP-METHOD SLOT-OBJECT CLASS)|

+ |(FAST-BOUNDP-METHOD SLOT-OBJECT ACCESSOR-FLAGS)|

+ |(FAST-BOUNDP-METHOD SLOT-OBJECT METHOD-CLASS)|

+ |(FAST-BOUNDP-METHOD SLOT-OBJECT INITFUNCTION)|

+ |(FAST-BOUNDP-METHOD SLOT-OBJECT ALLOCATION)|

+ |(FAST-BOUNDP-METHOD SLOT-OBJECT INTERNAL-WRITER-FUNCTION)|

+ |(FAST-BOUNDP-METHOD SLOT-OBJECT INTERNAL-READER-FUNCTION)|

+ |(FAST-BOUNDP-METHOD SLOT-OBJECT BOUNDP-FUNCTION)|

+ |(FAST-BOUNDP-METHOD SLOT-OBJECT WRITER-FUNCTION)|

+ |(FAST-BOUNDP-METHOD SLOT-OBJECT READER-FUNCTION)|

+ |(FAST-BOUNDP-METHOD SLOT-OBJECT LOCATION)|

+ |(FAST-BOUNDP-METHOD SLOT-OBJECT FAST-FUNCTION)|

+ |(FAST-BOUNDP-METHOD SLOT-OBJECT FUNCTION)|

+ |(FAST-BOUNDP-METHOD SLOT-OBJECT GENERIC-FUNCTION)|

+ |(FAST-BOUNDP-METHOD SLOT-OBJECT SLOT-DEFINITION)|

+ |(FAST-BOUNDP-METHOD SLOT-OBJECT METHOD-COMBINATION)|

+ |(FAST-BOUNDP-METHOD SLOT-OBJECT DOCUMENTATION)|

+ |(BOUNDP OPERATOR)| |(BOUNDP ARG-INFO)|

+ |(FAST-BOUNDP-METHOD SLOT-OBJECT WRITERS)|

+ |(FAST-BOUNDP-METHOD SLOT-OBJECT READERS)|

+ |(FAST-BOUNDP-METHOD SLOT-OBJECT SPECIALIZERS)|

+ |(FAST-BOUNDP-METHOD SLOT-OBJECT PROTOTYPE)|

+ |(FAST-BOUNDP-METHOD SLOT-OBJECT OBJECT)|

+ |(FAST-BOUNDP-METHOD SLOT-OBJECT TYPE)|

+ |(FAST-BOUNDP-METHOD SLOT-OBJECT DEFSTRUCT-FORM)|

+ |(FAST-BOUNDP-METHOD SLOT-OBJECT INITFORM)|

+ |(SETF SLOT-VALUE-USING-CLASS)|

+ |(SETF SLOT-DEFINITION-CLASS)|

+ |(SETF SLOT-ACCESSOR-FUNCTION)|

+ |(SETF SLOT-DEFINITION-INITFUNCTION)|

+ |(SETF SLOT-DEFINITION-ALLOCATION)|

+ |(SETF SLOT-DEFINITION-INTERNAL-WRITER-FUNCTION)|

+ |(SETF SLOT-DEFINITION-INTERNAL-READER-FUNCTION)|

+ |(SETF SLOT-DEFINITION-BOUNDP-FUNCTION)|

+ |(SETF SLOT-DEFINITION-WRITER-FUNCTION)|

+ |(SETF SLOT-DEFINITION-READER-FUNCTION)|

+ |(SETF SLOT-DEFINITION-LOCATION)|

+ |(BOUNDP DEFSTRUCT-CONSTRUCTOR)|

+ |(FAST-BOUNDP-METHOD SLOT-OBJECT PLIST)|

+ |(FAST-BOUNDP-METHOD SLOT-OBJECT INCOMPATIBLE-SUPERCLASS-LIST)|

+ |(FAST-BOUNDP-METHOD SLOT-OBJECT CAN-PRECEDE-LIST)|

+ |(FAST-BOUNDP-METHOD SLOT-OBJECT CLASS-PRECEDENCE-LIST)|

+ |(FAST-BOUNDP-METHOD SLOT-OBJECT LAMBDA-LIST)|

+ |(FAST-BOUNDP-METHOD SLOT-OBJECT PRETTY-ARGLIST)|

+ |(SETF SLOT-DEFINITION-WRITERS)|

+ |(SETF SLOT-DEFINITION-READERS)|

+ |(SETF SLOT-DEFINITION-TYPE)|

+ |(SETF SLOT-DEFINITION-INITFORM)|

+ |(BOUNDP INITIALIZE-INFO)|

+ |(FAST-BOUNDP-METHOD SLOT-OBJECT DIRECT-METHODS)|

+ |(FAST-BOUNDP-METHOD SLOT-OBJECT SLOTS)|

+ |(FAST-BOUNDP-METHOD SLOT-OBJECT DIRECT-SLOTS)|

+ |(FAST-BOUNDP-METHOD SLOT-OBJECT FROM-DEFCLASS-P)|

+ |(FAST-BOUNDP-METHOD SLOT-OBJECT METHODS)|

+ |(FAST-BOUNDP-METHOD SLOT-OBJECT OPTIONS)|

+ |(FAST-BOUNDP-METHOD SLOT-OBJECT DIRECT-SUBCLASSES)|

+ |(FAST-BOUNDP-METHOD SLOT-OBJECT DIRECT-SUPERCLASSES)|

+ |(FAST-INTERNAL-READER-METHOD STANDARD-GENERIC-FUNCTION ARG-INFO)|

+ |(BOUNDP INITARGS)| LONG-METHOD-COMBINATION-FUNCTION

+ GENERIC-FUNCTION-P

+ |PCL::SLOT-DEFINITION class predicate|

+ |LISP::NULL class predicate| |(READER NAME)|

+ |(READER CLASS)|

+ |(FAST-METHOD DESCRIBE-OBJECT (CLASS T))|

+ |(FAST-METHOD DESCRIBE-OBJECT (STANDARD-GENERIC-FUNCTION T))|

+ |(FAST-METHOD DESCRIBE-OBJECT (SLOT-OBJECT T))|

+ |(FAST-METHOD DESCRIBE-OBJECT (T T))|

+ |(FAST-METHOD COMPUTE-EFFECTIVE-METHOD (GENERIC-FUNCTION LONG-METHOD-COMBINATION T))|

+ |(FAST-METHOD COMPUTE-EFFECTIVE-METHOD (GENERIC-FUNCTION SHORT-METHOD-COMBINATION T))|

+ |(FAST-METHOD FIND-METHOD-COMBINATION (GENERIC-FUNCTION (EQL STANDARD) T))|

+ |(FAST-METHOD UPDATE-GF-DFUN (STD-CLASS T))|

+ |(FAST-METHOD COMPUTE-APPLICABLE-METHODS-USING-CLASSES (GENERIC-FUNCTION T))|

+ |(FAST-METHOD COMPUTE-APPLICABLE-METHODS (GENERIC-FUNCTION T))|

+ |(FAST-METHOD REMOVE-NAMED-METHOD (T T))|

+ |(FAST-METHOD SHARED-INITIALIZE :BEFORE (STANDARD-GENERIC-FUNCTION T))|

+ |(FAST-METHOD PRINT-OBJECT (GENERIC-FUNCTION T))|

+ |(FAST-METHOD SHARED-INITIALIZE :AFTER (STANDARD-ACCESSOR-METHOD T))|

+ |(FAST-METHOD SHARED-INITIALIZE :AFTER (STANDARD-METHOD T))|

+ |(FAST-METHOD SHARED-INITIALIZE :BEFORE (STANDARD-ACCESSOR-METHOD T))|

+ |(FAST-METHOD SHARED-INITIALIZE :BEFORE (STANDARD-METHOD T))|

+ |(FAST-METHOD LEGAL-SPECIALIZER-P (STANDARD-METHOD T))|

+ |(FAST-METHOD LEGAL-SPECIALIZERS-P (STANDARD-METHOD T))|

+ |(FAST-METHOD LEGAL-SLOT-NAME-P (STANDARD-METHOD T))|

+ |(FAST-METHOD LEGAL-QUALIFIER-P (STANDARD-METHOD T))|

+ |(FAST-METHOD LEGAL-QUALIFIERS-P (STANDARD-METHOD T))|

+ |(FAST-METHOD LEGAL-METHOD-FUNCTION-P (STANDARD-METHOD T))|

+ |(FAST-METHOD LEGAL-LAMBDA-LIST-P (STANDARD-METHOD T))|

+ |(FAST-METHOD LEGAL-DOCUMENTATION-P (STANDARD-METHOD T))|

+ |(FAST-METHOD PRINT-OBJECT (STANDARD-ACCESSOR-METHOD T))|

+ |(FAST-METHOD PRINT-OBJECT (STANDARD-METHOD T))|

+ |(FAST-METHOD INFORM-TYPE-SYSTEM-ABOUT-CLASS (STRUCTURE-CLASS T))|

+ |(FAST-METHOD SHARED-INITIALIZE :AFTER (STRUCTURE-SLOT-DEFINITION T))|

+ |(FAST-METHOD SHARED-INITIALIZE :AFTER (STANDARD-SLOT-DEFINITION T))|

+ |(FAST-METHOD PRINT-OBJECT (STANDARD-METHOD-COMBINATION T))|

+ |(FAST-METHOD PRINT-OBJECT (SLOT-DEFINITION T))|

+ |(FAST-METHOD PRINT-OBJECT (CLASS T))|

+ |(FAST-METHOD PRINT-OBJECT (T T))|

+ |(FAST-METHOD MAKE-WRITER-METHOD-FUNCTION (FUNCALLABLE-STANDARD-CLASS T))|

+ |(FAST-METHOD MAKE-READER-METHOD-FUNCTION (FUNCALLABLE-STANDARD-CLASS T))|

+ |(FAST-METHOD MAP-DEPENDENTS (DEPENDENT-UPDATE-MIXIN T))|

+ |(FAST-METHOD REMOVE-DEPENDENT (DEPENDENT-UPDATE-MIXIN T))|

+ |(FAST-METHOD ADD-DEPENDENT (DEPENDENT-UPDATE-MIXIN T))|

+ |(FAST-METHOD SHARED-INITIALIZE :BEFORE (BUILT-IN-CLASS T))|

+ |(FAST-METHOD COMPATIBLE-META-CLASS-CHANGE-P (T T))|

+ |(FAST-METHOD INFORM-TYPE-SYSTEM-ABOUT-CLASS (STD-CLASS T))|

+ |(FAST-METHOD MAKE-BOUNDP-METHOD-FUNCTION (SLOT-CLASS T))|

+ |(FAST-METHOD MAKE-WRITER-METHOD-FUNCTION (SLOT-CLASS T))|

+ |(FAST-METHOD MAKE-READER-METHOD-FUNCTION (SLOT-CLASS T))|

+ |(FAST-METHOD REMOVE-BOUNDP-METHOD (SLOT-CLASS T))|

+ |(FAST-METHOD REMOVE-WRITER-METHOD (SLOT-CLASS T))|

+ |(FAST-METHOD REMOVE-READER-METHOD (SLOT-CLASS T))|

+ |(FAST-METHOD ADD-BOUNDP-METHOD (SLOT-CLASS T T))|

+ |(FAST-METHOD ADD-WRITER-METHOD (SLOT-CLASS T T))|

+ |(FAST-METHOD WRITER-METHOD-CLASS (SLOT-CLASS T))|

+ |(FAST-METHOD ADD-READER-METHOD (SLOT-CLASS T T))|

+ |(FAST-METHOD READER-METHOD-CLASS (SLOT-CLASS T))|

+ |(FAST-METHOD COMPUTE-EFFECTIVE-SLOT-DEFINITION-INITARGS :AROUND (STRUCTURE-CLASS T))|

+ |(FAST-METHOD COMPUTE-EFFECTIVE-SLOT-DEFINITION-INITARGS (SLOT-CLASS T))|

+ |(FAST-METHOD EFFECTIVE-SLOT-DEFINITION-CLASS (STRUCTURE-CLASS T))|

+ |(FAST-METHOD EFFECTIVE-SLOT-DEFINITION-CLASS (STD-CLASS T))|

+ |(FAST-METHOD COMPUTE-EFFECTIVE-SLOT-DEFINITION (SLOT-CLASS T))|

+ |(FAST-METHOD DIRECT-SLOT-DEFINITION-CLASS (STD-CLASS T))|

+ |(FAST-METHOD DIRECT-SLOT-DEFINITION-CLASS (STRUCTURE-CLASS T))|

+ |(FAST-METHOD SHARED-INITIALIZE :AFTER (STRUCTURE-CLASS T))|

+ |(FAST-METHOD SHARED-INITIALIZE :BEFORE (CLASS T))|

+ |(FAST-METHOD SHARED-INITIALIZE :AFTER (STD-CLASS T))|

+ |(FAST-METHOD SHARED-INITIALIZE :AFTER (EQL-SPECIALIZER T))|

+ |(FAST-METHOD SHARED-INITIALIZE :AFTER (CLASS-EQ-SPECIALIZER T))|

+ |(FAST-METHOD (SETF DOCUMENTATION) (T T))|

+ |(FAST-METHOD SHARED-INITIALIZE :AFTER (DOCUMENTATION-MIXIN T))|

+ |(FAST-METHOD COMPUTE-SLOT-ACCESSOR-INFO (EFFECTIVE-SLOT-DEFINITION T T))|

+ |(FAST-METHOD (SETF SLOT-ACCESSOR-STD-P) (T EFFECTIVE-SLOT-DEFINITION T))|

+ |(FAST-METHOD SLOT-ACCESSOR-STD-P (EFFECTIVE-SLOT-DEFINITION T))|

+ |(FAST-METHOD (SETF SLOT-ACCESSOR-FUNCTION) (T EFFECTIVE-SLOT-DEFINITION T))|

+ |(FAST-METHOD SLOT-ACCESSOR-FUNCTION (EFFECTIVE-SLOT-DEFINITION T))|

+ |(FAST-METHOD SHARED-INITIALIZE (SLOT-OBJECT T))|

+ |(FAST-METHOD UPDATE-INSTANCE-FOR-REDEFINED-CLASS (STANDARD-OBJECT T T T))|

+ |(FAST-METHOD DEFAULT-INITARGS (SLOT-CLASS T))|

+ |(FAST-METHOD SLOT-UNBOUND (T T T))|

+ |(FAST-METHOD SLOT-MISSING (T T T T))|

+ |(FAST-METHOD (SETF CLASS-SLOT-VALUE) (T STD-CLASS T))|

+ |(FAST-METHOD CLASS-SLOT-VALUE (STD-CLASS T))|

+ LEGAL-SLOT-NAME-P |(READER OBJECT)| |(READER TYPE)|

+ CLASS-WRAPPER |(READER PLIST)|

+ |(FAST-METHOD CLASS-PREDICATE-NAME (T))|

+ |(FAST-METHOD DOCUMENTATION (T))|

+ |(FAST-METHOD NO-APPLICABLE-METHOD (T))|

+ |(READER SLOTS)| |(WRITER NAME)| DEFINITION-SOURCE

+ |PCL::SLOT-OBJECT class predicate| DEFAULT-INITARGS

+ |(WRITER CLASS)| CLASS-SLOT-VALUE |(WRITER OBJECT)|

+ |(WRITER TYPE)|

+ |(FAST-METHOD ENSURE-CLASS-USING-CLASS (T NULL))|

+ |(WRITER PLIST)| |(WRITER SLOTS)|

+ |PCL::DOCUMENTATION-MIXIN class predicate|

+ FORWARD-REFERENCED-CLASS-P GF-FAST-METHOD-FUNCTION-P

+ LEGAL-QUALIFIER-P METHOD-P

+ |PCL::SPECIALIZER-WITH-OBJECT class predicate|

+ CLASS-SLOT-CELLS

+ |(COMBINED-METHOD INITIALIZE-INSTANCE)|

+ |(COMBINED-METHOD REINITIALIZE-INSTANCE)|

+ STANDARD-ACCESSOR-METHOD-P |(SETF CLASS-NAME)|

+ STANDARD-GENERIC-FUNCTION-P STANDARD-READER-METHOD-P

+ STANDARD-METHOD-P |(READER WRAPPER)|

+ |(READER DEFSTRUCT-ACCESSOR-SYMBOL)|

+ |(READER CLASS-EQ-SPECIALIZER)|

+ COMPUTE-EFFECTIVE-SLOT-DEFINITION-INITARGS

+ COMPUTE-DEFAULT-INITARGS |(SETF CLASS-DEFSTRUCT-FORM)|

+ |(CALL REAL-MAKE-METHOD-LAMBDA)|

+ |(SETF CLASS-INCOMPATIBLE-SUPERCLASS-LIST)|

+ |SETF PCL CLASS-SLOT-VALUE| |(SETF CLASS-SLOTS)|

+ |(SETF CLASS-DIRECT-SLOTS)| |(READER OPERATOR)|

+ |(CALL REAL-GET-METHOD)| |(CALL REAL-REMOVE-METHOD)|

+ |(CALL REAL-ADD-METHOD)| |(READER ARG-INFO)|

+ METHOD-COMBINATION-TYPE

+ |(READER DEFSTRUCT-CONSTRUCTOR)|

+ |(INTERNAL-READER-METHOD STANDARD-GENERIC-FUNCTION ARG-INFO)|

+ |(READER INITIALIZE-INFO)| |(WRITER WRAPPER)|

+ STANDARD-CLASS-P |LISP::NUMBER class predicate|

+ LEGAL-SPECIALIZER-P

+ |PCL::LONG-METHOD-COMBINATION class predicate|

+ |(WRITER DEFSTRUCT-ACCESSOR-SYMBOL)|

+ COMPUTE-SLOT-ACCESSOR-INFO |(READER INITARGS)|

+ |(WRITER CLASS-EQ-SPECIALIZER)|

+ STANDARD-BOUNDP-METHOD-P |(SETF DOCUMENTATION)|

+ RAW-INSTANCE-ALLOCATOR

+ |SETF PCL SLOT-DEFINITION-DEFSTRUCT-ACCESSOR-SYMBOL|

+ |SETF PCL CLASS-INITIALIZE-INFO| |(WRITER OPERATOR)|

+ |(WRITER ARG-INFO)|

+ COMPUTE-DISCRIMINATING-FUNCTION-ARGLIST-INFO

+ STANDARD-WRITER-METHOD-P

+ CLASS-INCOMPATIBLE-SUPERCLASS-LIST

+ |(WRITER DEFSTRUCT-CONSTRUCTOR)|

+ |PCL::TRACED-METHOD class predicate| WRAPPER-FETCHER

+ MAKE-A-METHOD |(WRITER INITIALIZE-INFO)|

+ METHOD-COMBINATION-DOCUMENTATION

+ |SETF PCL SLOT-DEFINITION-INITARGS|

+ REMOVE-BOUNDP-METHOD ADD-NAMED-METHOD

+ |LISP::CONS class predicate| |(WRITER INITARGS)|

+ |SETF PCL CLASS-DEFSTRUCT-CONSTRUCTOR|

+ |(BOUNDP METHOD)|

+ |(FAST-WRITER-METHOD SLOT-OBJECT PREDICATE-NAME)|

+ |(FAST-WRITER-METHOD CLASS NAME)|

+ |(FAST-WRITER-METHOD SLOT-DEFINITION NAME)|

+ |(FAST-WRITER-METHOD SLOT-OBJECT SLOT-NAME)|

+ |(FAST-WRITER-METHOD SLOT-OBJECT DFUN-STATE)|

+ |(FAST-WRITER-METHOD STANDARD-GENERIC-FUNCTION DFUN-STATE)|

+ |(FAST-WRITER-METHOD SLOT-OBJECT NAME)|

+ |(FAST-WRITER-METHOD STANDARD-GENERIC-FUNCTION NAME)|

+ |(BOUNDP SOURCE)| |(SETF GF-DFUN-STATE)|

+ SHORT-COMBINATION-OPERATOR

+ |(FAST-WRITER-METHOD SLOT-OBJECT CLASS)|

+ |(FAST-WRITER-METHOD SLOT-DEFINITION CLASS)|

+ |(FAST-WRITER-METHOD SLOT-OBJECT ACCESSOR-FLAGS)|

+ |(FAST-WRITER-METHOD SLOT-OBJECT METHOD-CLASS)|

+ |(FAST-WRITER-METHOD STANDARD-GENERIC-FUNCTION METHOD-CLASS)|

+ |(FAST-WRITER-METHOD TRACED-METHOD GENERIC-FUNCTION)|

+ |(FAST-WRITER-METHOD SLOT-OBJECT INITFUNCTION)|

+ |(FAST-WRITER-METHOD SLOT-DEFINITION INITFUNCTION)|

+ |(FAST-WRITER-METHOD SLOT-OBJECT ALLOCATION)|

+ |(FAST-WRITER-METHOD STANDARD-SLOT-DEFINITION ALLOCATION)|

+ |(FAST-WRITER-METHOD SLOT-OBJECT INTERNAL-WRITER-FUNCTION)|

+ |(FAST-WRITER-METHOD STRUCTURE-SLOT-DEFINITION INTERNAL-WRITER-FUNCTION)|

+ |(FAST-WRITER-METHOD SLOT-OBJECT INTERNAL-READER-FUNCTION)|

+ |(FAST-WRITER-METHOD STRUCTURE-SLOT-DEFINITION INTERNAL-READER-FUNCTION)|

+ |(FAST-WRITER-METHOD SLOT-OBJECT BOUNDP-FUNCTION)|

+ |(FAST-WRITER-METHOD EFFECTIVE-SLOT-DEFINITION BOUNDP-FUNCTION)|

+ |(FAST-WRITER-METHOD SLOT-OBJECT WRITER-FUNCTION)|

+ |(FAST-WRITER-METHOD EFFECTIVE-SLOT-DEFINITION WRITER-FUNCTION)|

+ |(FAST-WRITER-METHOD SLOT-OBJECT READER-FUNCTION)|

+ |(FAST-WRITER-METHOD EFFECTIVE-SLOT-DEFINITION READER-FUNCTION)|

+ |(FAST-WRITER-METHOD SLOT-OBJECT LOCATION)|

+ |(FAST-WRITER-METHOD STANDARD-EFFECTIVE-SLOT-DEFINITION LOCATION)|

+ |(FAST-WRITER-METHOD SLOT-OBJECT FAST-FUNCTION)|

+ |(FAST-WRITER-METHOD SLOT-OBJECT FUNCTION)|

+ |(FAST-WRITER-METHOD SLOT-OBJECT GENERIC-FUNCTION)|

+ |(FAST-WRITER-METHOD STANDARD-METHOD GENERIC-FUNCTION)|

+ |(FAST-WRITER-METHOD SLOT-OBJECT SLOT-DEFINITION)|

+ |(FAST-WRITER-METHOD SLOT-OBJECT METHOD-COMBINATION)|

+ |(FAST-WRITER-METHOD STANDARD-GENERIC-FUNCTION METHOD-COMBINATION)|

+ |(FAST-WRITER-METHOD SLOT-OBJECT DOCUMENTATION)|

+ |(FAST-WRITER-METHOD SLOT-OBJECT WRITERS)|

+ |(FAST-WRITER-METHOD SLOT-DEFINITION WRITERS)|

+ |(FAST-WRITER-METHOD SLOT-OBJECT READERS)|

+ |(FAST-WRITER-METHOD SLOT-DEFINITION READERS)|

+ |(FAST-WRITER-METHOD SLOT-OBJECT SPECIALIZERS)|

+ |(FAST-WRITER-METHOD SLOT-OBJECT IDENTITY-WITH-ONE-ARGUMENT)|

+ |(FAST-WRITER-METHOD SLOT-OBJECT PROTOTYPE)|

+ |(FAST-WRITER-METHOD SLOT-OBJECT OBJECT)|

+ |(FAST-WRITER-METHOD SLOT-DEFINITION TYPE)|

+ |(FAST-WRITER-METHOD SLOT-OBJECT TYPE)|

+ REMOVE-NAMED-METHOD

+ |(FAST-WRITER-METHOD SLOT-OBJECT DEFSTRUCT-FORM)|

+ |(FAST-WRITER-METHOD STRUCTURE-CLASS DEFSTRUCT-FORM)|

+ |(FAST-WRITER-METHOD SLOT-OBJECT INITFORM)|

+ |(FAST-WRITER-METHOD SLOT-DEFINITION INITFORM)|

+ |(FAST-WRITER-METHOD SLOT-OBJECT PLIST)|

+ |(FAST-WRITER-METHOD PLIST-MIXIN PLIST)|

+ |(FAST-WRITER-METHOD SLOT-OBJECT INCOMPATIBLE-SUPERCLASS-LIST)|

+ |(FAST-WRITER-METHOD PCL-CLASS INCOMPATIBLE-SUPERCLASS-LIST)|

+ |(FAST-WRITER-METHOD SLOT-OBJECT CAN-PRECEDE-LIST)|

+ |(FAST-WRITER-METHOD SLOT-OBJECT CLASS-PRECEDENCE-LIST)|

+ |(FAST-WRITER-METHOD SLOT-OBJECT LAMBDA-LIST)|

+ |(FAST-WRITER-METHOD SLOT-OBJECT PRETTY-ARGLIST)|

+ |(FAST-WRITER-METHOD STANDARD-GENERIC-FUNCTION PRETTY-ARGLIST)|

+ LEGAL-DOCUMENTATION-P CLASS-DIRECT-SUPERCLASSES

+ CLASS-DIRECT-SUBCLASSES CLASS-DIRECT-DEFAULT-INITARGS

+ SLOT-DEFINITION-READERS SLOT-VALUE-USING-CLASS

+ COMPUTE-APPLICABLE-METHODS CLASS-NAME CLASS-PROTOTYPE

+ READER-METHOD-CLASS REMOVE-METHOD

+ SLOT-DEFINITION-INITFORM

+ UPDATE-INSTANCE-FOR-REDEFINED-CLASS

+ UPDATE-INSTANCE-FOR-DIFFERENT-CLASS CHANGE-CLASS

+ METHOD-FUNCTION DIRECT-SLOT-DEFINITION-CLASS

+ MAKE-METHOD-LAMBDA EFFECTIVE-SLOT-DEFINITION-CLASS

+ CLASS-SLOTS COMPUTE-SLOTS SLOT-DEFINITION-NAME

+ FINALIZE-INHERITANCE GENERIC-FUNCTION-LAMBDA-LIST

+ CLASS-DIRECT-SLOTS CLASS-DEFAULT-INITARGS

+ COMPUTE-DISCRIMINATING-FUNCTION CLASS-FINALIZED-P

+ GENERIC-FUNCTION-NAME REMOVE-DEPENDENT

+ COMPUTE-CLASS-PRECEDENCE-LIST ADD-DEPENDENT

+ SLOT-BOUNDP-USING-CLASS ACCESSOR-METHOD-SLOT-DEFINITION

+ SHARED-INITIALIZE ADD-DIRECT-METHOD

+ SLOT-DEFINITION-LOCATION SLOT-DEFINITION-INITFUNCTION

+ SLOT-DEFINITION-ALLOCATION ADD-METHOD

+ GENERIC-FUNCTION-METHOD-CLASS METHOD-SPECIALIZERS

+ SLOT-DEFINITION-INITARGS WRITER-METHOD-CLASS

+ ADD-DIRECT-SUBCLASS SPECIALIZER-DIRECT-METHODS

+ GENERIC-FUNCTION-METHOD-COMBINATION ALLOCATE-INSTANCE

+ COMPUTE-EFFECTIVE-METHOD SLOT-DEFINITION-TYPE

+ SLOT-UNBOUND INITIALIZE-INSTANCE FUNCTION-KEYWORDS

+ REINITIALIZE-INSTANCE VALIDATE-SUPERCLASS

+ GENERIC-FUNCTION-METHODS REMOVE-DIRECT-METHOD

+ METHOD-LAMBDA-LIST MAKE-INSTANCE

+ COMPUTE-EFFECTIVE-SLOT-DEFINITION PRINT-OBJECT

+ METHOD-QUALIFIERS METHOD-GENERIC-FUNCTION

+ REMOVE-DIRECT-SUBCLASS MAKE-INSTANCES-OBSOLETE

+ SLOT-MAKUNBOUND-USING-CLASS

+ ENSURE-GENERIC-FUNCTION-USING-CLASS SLOT-MISSING

+ MAP-DEPENDENTS UPDATE-DEPENDENT FIND-METHOD-COMBINATION

+ ENSURE-CLASS-USING-CLASS NO-APPLICABLE-METHOD

+ SLOT-DEFINITION-WRITERS

+ COMPUTE-APPLICABLE-METHODS-USING-CLASSES

+ CLASS-PRECEDENCE-LIST))

+ (SETF (GET V 'COMPILER::PROCLAIMED-CLOSURE) T))

diff --git a/gcl/pcl/impl/gold-hill/gold-low.lisp b/gcl/pcl/impl/gold-hill/gold-low.lisp
new file mode 100644
index 000000000..ee47b6f21
--- /dev/null
+++ b/gcl/pcl/impl/gold-hill/gold-low.lisp

@@ -0,0 +1,51 @@

+;;;-*-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)

+

+;;; fix a bug in gcl macro-expander (or->cond->or->cond->...)

+(setf (get 'cond 'lisp::macro-expander) nil)

+

+;;; fix another bug in gcl3_0 case macro-expander

+(defun lisp::eqv (a b) (eql a b))

+

+(defun printing-random-thing-internal (thing stream)

+ (multiple-value-bind (offaddr baseaddr)

+ (sys:%pointer thing)

+ (princ baseaddr stream)

+ (princ ", " stream)

+ (princ offaddr stream)))

+

+;;;

+;;; This allows the compiler to compile a file with many "DEFMETHODS"

+;;; in succession.

+;;;

+(dolist (x '(defmethod defgeneric defclass precompile-random-code-segments))

+ (setf (get x 'gcl::compile-separately) t))

+

diff --git a/gcl/pcl/impl/gold-hill/gold-patches.lisp b/gcl/pcl/impl/gold-hill/gold-patches.lisp
new file mode 100644
index 000000000..9f6f4e7d8
--- /dev/null
+++ b/gcl/pcl/impl/gold-hill/gold-patches.lisp

@@ -0,0 +1,168 @@

+;;; -*- Mode:Lisp; Package:USER; Base:10; Syntax:Common-lisp -*-

+

+(in-package 'user)

+

+(setq c::optimize-speed 3)

+(setq c::optimize-safety 0)

+(setq c::optimize-space 0)

+

+(remprop 'macroexpand 'c::fdesc)

+(remprop 'macroexpand-1 'c::fdesc)

+

+

+;;; this is here to fix the printer so it will find the print

+;;; functions on structures that have 'em.

+

+(in-package 'lisp)

+

+(defun %write-structure (struct output-stream print-vars level)

+ (let* ((name (svref struct 0))

+ (pfun (or (let ((temp (get name 'structure-descriptor)))

+ (and temp (dd-print-function temp)))

+ (get name :print-function))))

+ (declare (symbol name))

+ (cond

+ (pfun

+ (funcall pfun struct output-stream level))

+ ((and (pv-level print-vars) (>= level (pv-level print-vars)))

+ (write-char #\# output-stream))

+ ((and (pv-circle print-vars)

+ (%write-circle struct output-stream (pv-circle print-vars))))

+ (t

+ (let ((pv-length (pv-length print-vars))

+ (pv-pretty (pv-pretty print-vars)))

+ (when pv-pretty

+ (pp-push-level pv-pretty))

+ (incf level)

+ (write-string "#s(" output-stream)

+ (cond

+ ((and pv-length (>= 0 pv-length))

+ (write-string "..."))

+ (t

+ (%write-symbol name output-stream print-vars)

+ (do ((i 0 (1+ i))

+ (n 0)

+ (slots (dd-slots (get name 'structure-descriptor))

+ (rest slots)))

+ ((endp slots))

+ (declare (fixnum i n) (list slots))

+ (when pv-pretty

+ (pp-insert-break pv-pretty *structure-keyword-slot-spec* t))

+ (write-char #\space output-stream)

+ (when (and pv-length (>= (incf n) pv-length))

+ (write-string "..." output-stream)

+ (return))

+ (write-char #\: output-stream)

+ (%write-symbol-name

+ (symbol-name (dsd-name (first slots))) output-stream print-vars)

+ (when pv-pretty

+ (pp-insert-break pv-pretty *structure-data-slot-spec* nil))

+ (write-char #\space output-stream)

+ (when (and pv-length (>= (incf n) pv-length))

+ (write-string "..." output-stream)

+ (return))

+ (%write-object

+ (svref struct (dsd-index (first slots)))

+ output-stream print-vars level))))

+ (write-char #\) output-stream)

+ (when pv-pretty

+ (pp-pop-level pv-pretty)))))))

+

+(eval-when (eval) (compile '%write-structure))

+

+;;;

+;;; Apparently, whoever implemented the TIME macro didn't consider that

+;;; someone might want to use it in a non-null lexical environment. Of

+;;; course this fix is a loser since it binds a whole mess of variables

+;;; around the evaluation of form, but it will do for now.

+;;;

+(in-package 'lisp)

+

+(DEFmacro TIME (FORM)

+ `(LET (IGNORE START FINISH S-HSEC F-HSEC S-SEC F-SEC S-MIN F-MIN VALS)

+ (FORMAT *trace-output* "~&Evaluating: ~A" ,form)

+ ;; read the start time.

+ (MULTIPLE-VALUE-SETQ (IGNORE IGNORE IGNORE S-MIN START)

+ (SYS::%SYSINT #X21 #X2C00 0 0 0))

+ ;; Eval the form.

+ (SETQ VALS (MULTIPLE-VALUE-LIST (progn ,form)))

+ ;; Read the end time.

+ (MULTIPLE-VALUE-SETQ (IGNORE IGNORE IGNORE F-MIN FINISH)

+ (SYS::%SYSINT #X21 #X2C00 0 0 0))

+ ;; Unpack start and end times.

+ (SETQ S-HSEC (LOGAND START #X0FF)

+ F-HSEC (LOGAND FINISH #X0FF)

+ S-SEC (LSH START -8)

+ F-SEC (LSH FINISH -8)

+ S-MIN (LOGAND #X0FF S-MIN)

+ F-MIN (LOGAND #X0FF F-MIN))

+ (SETQ F-HSEC (- F-HSEC S-HSEC)) ; calc hundreths

+ (IF (MINUSP F-HSEC)

+ (SETQ F-HSEC (+ F-HSEC 100)

+ F-SEC (1- F-SEC)))

+ (SETQ F-SEC (- F-SEC S-SEC)) ; calc seconds

+ (IF (MINUSP F-SEC)

+ (SETQ F-SEC (+ F-SEC 60)

+ F-MIN (1- F-MIN)))

+ (SETQ F-MIN (- F-MIN S-MIN)) ; calc minutes

+ (IF (MINUSP F-MIN) (INCF F-MIN 60))

+ (FORMAT *trace-output* "~&Elapsed time: ~D:~:[~D~;0~D~].~:[~D~;0~D~]~%"

+ F-MIN (< F-SEC 10.) F-SEC (< F-HSEC 10) F-HSEC)

+ (VALUES-LIST VALS)))

+

+;;;

+;;; Patch to PROGV

+;;;

+(in-package sys::*compiler-package-load*)

+

+;;; This is a fully portable (though not very efficient)

+;;; implementation of PROGV as a macro. It does its own special

+;;; binding (shallow binding) by saving the original values in a

+;;; list, and marking things that were originally unbound.

+

+(defun PORTABLE-PROGV-BIND (symbol old-vals place-holder)

+ (let ((val-to-save '#:value-to-save))

+ `(let ((,val-to-save (if (boundp ,symbol)

+ (symbol-value ,symbol)

+ ,place-holder)))

+ (if ,old-vals

+ (rplacd (last ,old-vals) (ncons ,val-to-save))

+ (setq ,old-vals (ncons ,val-to-save))))))

+

+(defun PORTABLE-PROGV-UNBIND (symbol old-vals place-holder)

+ (let ((val-to-restore '#:value-to-restore))

+ `(let ((,val-to-restore (pop ,old-vals)))

+ (if (eq ,val-to-restore ,place-holder)

+ (makunbound ,symbol)

+ (setf (symbol-value ,symbol) ,val-to-restore)))))

+

+

+(deftransform PROGV PORTABLE-PROGV-TRANSFORM

+ (symbols-form values-form &rest body)

+ (let ((symbols-lst '#:symbols-list)

+ (values-lst '#:values-list)

+ (syms '#:symbols)

+ (vals '#:values)

+ (sym '#:symbol)

+ (old-vals '#:old-values)

+ (unbound-holder ''#:unbound-holder))

+ `(let ((,symbols-lst ,symbols-form)

+ (,values-lst ,values-form)

+ (,old-vals nil))

+ (unless (and (listp ,symbols-lst) (listp ,values-lst))

+ (error "PROGV: Both symbols and values must be lists"))

+ (unwind-protect

+ (do ((,syms ,symbols-lst (cdr ,syms))

+ (,vals ,values-lst (cdr ,vals))

+ (,sym nil))

+ ((null ,syms) (progn ,@body))

+ (setq ,sym (car ,syms))

+ (if (symbolp ,sym)

+ ,(PORTABLE-PROGV-BIND sym old-vals unbound-holder)

+ (error "PROGV: Object to be bound not a symbol: ~S" ,sym))

+ (if ,vals

+ (setf (symbol-value ,sym) (first ,vals))

+ (makunbound ,sym)))

+ (dolist (,sym ,symbols-lst)

+ ,(PORTABLE-PROGV-UNBIND sym old-vals unbound-holder))))))

+

diff --git a/gcl/pcl/impl/hp/hp-low.lisp b/gcl/pcl/impl/hp/hp-low.lisp
new file mode 100644
index 000000000..d1e807f68
--- /dev/null
+++ b/gcl/pcl/impl/hp/hp-low.lisp

@@ -0,0 +1,37 @@

+;;; -*- 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 is the HP Common Lisp version of the file low.

+;;;

+;;;

+

+(in-package 'pcl)

+

+(defun printing-random-thing-internal (thing stream)

+ (format stream "~O" (prim:@inf thing)))

+

+

+

diff --git a/gcl/pcl/impl/ibcl/ibcl-low.lisp b/gcl/pcl/impl/ibcl/ibcl-low.lisp
new file mode 100644
index 000000000..2ab3f77ba
--- /dev/null
+++ b/gcl/pcl/impl/ibcl/ibcl-low.lisp

@@ -0,0 +1,327 @@

+;;;-*-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.

+;;; *************************************************************************

+;;;

+;;; The version of low for Kyoto Common Lisp (KCL)

+(in-package 'pcl)

+

+;;;

+;;; The reason these are here is because the KCL compiler does not allow

+;;; LET to return FIXNUM values as values of (c) type int, hence the use

+;;; of LOCALLY (which expands into (LET () (DECLARE ...) ...)) forces

+;;; conversion of ints to objects.

+;;;

+(defmacro %logand (&rest args)

+ (reduce-variadic-to-binary 'logand args 0 t 'fixnum))

+

+;(defmacro %logxor (&rest args)

+; (reduce-variadic-to-binary 'logxor args 0 t 'fixnum))

+

+(defmacro %+ (&rest args)

+ (reduce-variadic-to-binary '+ args 0 t 'fixnum))

+

+;(defmacro %- (x y)

+; `(the fixnum (- (the fixnum ,x) (the fixnum ,y))))

+

+(defmacro %* (&rest args)

+ (reduce-variadic-to-binary '* args 1 t 'fixnum))

+

+(defmacro %/ (x y)

+ `(the fixnum (/ (the fixnum ,x) (the fixnum ,y))))

+

+(defmacro %1+ (x)

+ `(the fixnum (1+ (the fixnum ,x))))

+

+(defmacro %1- (x)

+ `(the fixnum (1- (the fixnum ,x))))

+

+(defmacro %svref (vector index)

+ `(svref (the simple-vector ,vector) (the fixnum ,index)))

+

+(defsetf %svref (vector index) (new-value)

+ `(setf (svref (the simple-vector ,vector) (the fixnum ,index))

+ ,new-value))

+

+

+;;;

+;;; std-instance-p

+;;;

+(si:define-compiler-macro std-instance-p (x)

+ (once-only (x)

+ `(and (si:structurep ,x)

+ (eq (si:structure-name ,x) 'std-instance))))

+

+(dolist (inline '((si:structurep

+ ((t) compiler::boolean nil nil "type_of(#0)==t_structure")

+ compiler::inline-always)

+ (si:structure-name

+ ((t) t nil nil "(#0)->str.str_name")

+ compiler::inline-unsafe)))

+ (setf (get (first inline) (third inline)) (list (second inline))))

+

+(setf (get 'cclosure-env 'compiler::inline-always)

+ (list '((t) t nil nil "(#0)->cc.cc_env")))

+

+;;;

+;;; turbo-closure patch. See the file kcl-mods.text for details.

+;;;

+#+:turbo-closure

+(progn

+(CLines

+ "object tc_cc_env_nthcdr (n,tc)"

+ "object n,tc; "

+ "{return (type_of(tc)==t_cclosure&& "

+ " tc->cc.cc_turbo!=NULL&& "

+ " type_of(n)==t_fixnum)? "

+ " tc->cc.cc_turbo[fix(n)]: " ; assume that n is in bounds

+ " Cnil; "

+ "} "

+ )

+

+(defentry tc-cclosure-env-nthcdr (object object) (object tc_cc_env_nthcdr))

+

+(setf (get 'tc-cclosure-env-nthcdr 'compiler::inline-unsafe)

+ '(((fixnum t) t nil nil "(#1)->cc.cc_turbo[#0]")))

+)

+

+

+;;;; low level stuff to hack compiled functions and compiled closures.

+;;;

+;;; The primary client for this is fsc-low, but since we make some use of

+;;; it here (e.g. to implement set-function-name-1) it all appears here.

+;;;

+

+(eval-when (compile eval)

+

+(defmacro define-cstruct-accessor (accessor structure-type field value-type

+ field-type tag-name)

+ (let ((setf (intern (concatenate 'string "SET-" (string accessor))))

+ (caccessor (format nil "pcl_get_~A_~A" structure-type field))

+ (csetf (format nil "pcl_set_~A_~A" structure-type field))

+ (vtype (intern (string-upcase value-type))))

+ `(progn

+ (CLines ,(format nil "~A ~A(~A) ~%~

+ object ~A; ~%~

+ { return ((~A) ~A->~A.~A); } ~%~

+ ~%~

+ ~A ~A(~A, new) ~%~

+ object ~A; ~%~

+ ~A new; ~%~

+ { return ((~A)(~A->~A.~A = ~Anew)); } ~%~

+ "

+ value-type caccessor structure-type

+ structure-type

+ value-type structure-type tag-name field

+ value-type csetf structure-type

+ structure-type

+ value-type

+ value-type structure-type tag-name field field-type

+ ))

+

+ (defentry ,accessor (object) (,vtype ,caccessor))

+ (defentry ,setf (object ,vtype) (,vtype ,csetf))

+

+

+ (defsetf ,accessor ,setf)

+

+ )))

+)

+;;;

+;;; struct cfun { /* compiled function header */

+;;; short t, m;

+;;; object cf_name; /* compiled function name */

+;;; int (*cf_self)(); /* entry address */

+;;; object cf_data; /* data the function uses */

+;;; /* for GBC */

+;;; char *cf_start; /* start address of the code */

+;;; int cf_size; /* code size */

+;;; };

+;;; add field-type tag-name

+(define-cstruct-accessor cfun-name "cfun" "cf_name" "object" "(object)" "cf")

+(define-cstruct-accessor cfun-self "cfun" "cf_self" "int" "(int (*)())"

+ "cf")

+(define-cstruct-accessor cfun-data "cfun" "cf_data" "object" "(object)" "cf")

+(define-cstruct-accessor cfun-start "cfun" "cf_start" "int" "(char *)" "cf")

+(define-cstruct-accessor cfun-size "cfun" "cf_size" "int" "(int)" "cf")

+

+(CLines

+ "object pcl_cfunp (x) "

+ "object x; "

+ "{if(x->c.t == (int) t_cfun) "

+ " return (Ct); "

+ " else "

+ " return (Cnil); "

+ " } "

+ )

+

+(defentry cfunp (object) (object pcl_cfunp))

+

+;;;

+;;; struct cclosure { /* compiled closure header */

+;;; short t, m;

+;;; object cc_name; /* compiled closure name */

+;;; int (*cc_self)(); /* entry address */

+;;; object cc_env; /* environment */

+;;; object cc_data; /* data the closure uses */

+;;; /* for GBC */

+;;; char *cc_start; /* start address of the code */

+;;; int cc_size; /* code size */

+;;; };

+;;;

+(define-cstruct-accessor cclosure-name "cclosure" "cc_name" "object"

+ "(object)" "cc")

+(define-cstruct-accessor cclosure-self "cclosure" "cc_self" "int"

+ "(int (*)())" "cc")

+(define-cstruct-accessor cclosure-data "cclosure" "cc_data" "object"

+ "(object)" "cc")

+(define-cstruct-accessor cclosure-start "cclosure" "cc_start" "int"

+ "(char *)" "cc")

+(define-cstruct-accessor cclosure-size "cclosure" "cc_size" "int"

+ "(int)" "cc")

+(define-cstruct-accessor cclosure-env "cclosure" "cc_env" "object"

+ "(object)" "cc")

+

+

+(CLines

+ "object pcl_cclosurep (x) "

+ "object x; "

+ "{if(x->c.t == (int) t_cclosure) "

+ " return (Ct); "

+ " else "

+ " return (Cnil); "

+ " } "

+ )

+

+(defentry cclosurep (object) (object pcl_cclosurep))

+

+ ;;

+;;;;;; Load Time Eval

+ ;;

+;;;

+

+;;; This doesn't work because it looks at a global variable to see if it is

+;;; in the compiler rather than looking at the macroexpansion environment.

+;;;

+;;; The result is that if in the process of compiling a file, we evaluate a

+;;; form that has a call to load-time-eval, we will get faked into thinking

+;;; that we are compiling that form.

+;;;

+;;; THIS NEEDS TO BE DONE RIGHT!!!

+;;;

+;(defmacro load-time-eval (form)

+; ;; In KCL there is no compile-to-core case. For things that we are

+; ;; "compiling to core" we just expand the same way as if were are

+; ;; compiling a file since the form will be evaluated in just a little

+; ;; bit when gazonk.o is loaded.

+; (if (and (boundp 'compiler::*compiler-input*) ;Hack to see of we are

+; compiler::*compiler-input*) ;in the compiler!

+; `'(si:|#,| . ,form)

+; `(progn ,form)))

+

+(defmacro load-time-eval (form)

+ (read-from-string (format nil "'#,~S" form)))

+

+(defmacro memory-block-ref (block offset)

+ `(svref (the simple-vector ,block) (the fixnum ,offset)))

+

+ ;;

+;;;;;; Generating CACHE numbers

+ ;;

+;;; This needs more work to be sure it is going as fast as possible.

+;;; - The calls to si:address should be open-coded.

+;;; - The logand should be open coded.

+;;;

+

+;(defmacro symbol-cache-no (symbol mask)

+; (if (and (constantp symbol)

+; (constantp mask))

+; `(load-time-eval (logand (ash (si:address ,symbol) -2) ,mask))

+; `(logand (ash (the fixnum (si:address ,symbol)) -2) ,mask)))

+

+(defmacro object-cache-no (object mask)

+ `(logand (the fixnum (si:address ,object)) ,mask))

+

+ ;;

+;;;;;; printing-random-thing-internal

+ ;;

+(defun printing-random-thing-internal (thing stream)

+ (format stream "~O" (si:address thing)))

+

+

+(defun set-function-name-1 (fn new-name ignore)

+ (cond ((cclosurep fn)

+ (setf (cclosure-name fn) new-name))

+ ((cfunp fn)

+ (setf (cfun-name fn) new-name))

+ ((and (listp fn)

+ (eq (car fn) 'lambda-block))

+ (setf (cadr fn) new-name))

+ ((and (listp fn)

+ (eq (car fn) 'lambda))

+ (setf (car fn) 'lambda-block

+ (cdr fn) (cons new-name (cdr fn)))))

+ fn)

+

+

+

+

+#|

+(defconstant most-positive-small-fixnum 1024) /* should be supplied */

+(defconstant most-negative-small-fixnum -1024) /* by ibuki */

+

+(defmacro symbol-cache-no (symbol mask)

+ (if (constantp mask)

+ (if (and (> mask 0)

+ (< mask most-positive-small-fixnum))

+ (if (constantp symbol)

+ `(load-time-eval (coffset ,symbol ,mask 2))

+ `(coffset ,symbol ,mask 2))

+ (if (constantp symbol)

+ `(load-time-eval

+ (logand (ash (the fixnum (si:address ,symbol)) -2) ,mask))

+ `(logand (ash (the fixnum (si:address ,symbol)) -2) ,mask)))

+ `(logand (ash (the fixnum (si:address ,symbol)) -2) ,mask)))

+

+

+(defmacro object-cache-no (object mask)

+ (if (and (constantp mask)

+ (> mask 0)

+ (< mask most-positive-small-fixnum))

+ `(coffset ,object ,mask 4)

+ `(logand (ash (the fixnum (si:address ,object)) -4) ,mask)))

+

+(CLines

+ "object pcl_coffset (sym,mask,lshift)"

+ "object sym,mask,lshift;"

+ "{"

+ " return(small_fixnum(((int)sym >> fix(lshift)) & fix(mask)));"

+ "}"

+ )

+

+(defentry coffset (object object object) (object pcl_coffset))

+

+

+|#

+

diff --git a/gcl/pcl/impl/ibcl/ibcl-patches.lisp b/gcl/pcl/impl/ibcl/ibcl-patches.lisp
new file mode 100644
index 000000000..68e071cef
--- /dev/null
+++ b/gcl/pcl/impl/ibcl/ibcl-patches.lisp

@@ -0,0 +1,129 @@

+;;;-*-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 'system)

+

+;;; This makes DEFMACRO take &WHOLE and &ENVIRONMENT args anywhere

+;;; in the lambda-list. The former allows deviation from the CL spec,

+;;; but what the heck.

+

+(eval-when (compile) (proclaim '(optimize (safety 2) (space 3))))

+

+(defvar *old-defmacro*)

+

+(defun new-defmacro (whole env)

+ (flet ((call-old-definition (new-whole)

+ (funcall *old-defmacro* new-whole env)))

+ (if (not (and (consp whole)

+ (consp (cdr whole))

+ (consp (cddr whole))

+ (consp (cdddr whole))))

+ (call-old-definition whole)

+ (let* ((ll (caddr whole))

+ (env-tail (do ((tail ll (cdr tail)))

+ ((not (consp tail)) nil)

+ (when (eq '&environment (car tail))

+ (return tail)))))

+ (if env-tail

+ (call-old-definition (list* (car whole)

+ (cadr whole)

+ (append (list '&environment

+ (cadr env-tail))

+ (ldiff ll env-tail)

+ (cddr env-tail))

+ (cdddr whole)))

+ (call-old-definition whole))))))

+

+(eval-when (load eval)

+ (unless (boundp '*old-defmacro*)

+ (setq *old-defmacro* (macro-function 'defmacro))

+ (setf (macro-function 'defmacro) #'new-defmacro)))

+

+;;;

+;;; setf patches

+;;;

+

+(in-package 'system)

+

+(defun get-setf-method (form)

+ (multiple-value-bind (vars vals stores store-form access-form)

+ (get-setf-method-multiple-value form)

+ (unless (listp vars)

+ (error

+ "The temporary variables component, ~s,

+ of the setf-method for ~s is not a list."

+ vars form))

+ (unless (listp vals)

+ (error

+ "The values forms component, ~s,

+ of the setf-method for ~s is not a list."

+ vals form))

+ (unless (listp stores)

+ (error

+ "The store variables component, ~s,

+ of the setf-method for ~s is not a list."

+ stores form))

+ (unless (= (list-length stores) 1)

+ (error "Multiple store-variables are not allowed."))

+ (values vars vals stores store-form access-form)))

+

+(defun get-setf-method-multiple-value (form)

+ (cond ((symbolp form)

+ (let ((store (gensym)))

+ (values nil nil (list store) `(setq ,form ,store) form)))

+ ((or (not (consp form)) (not (symbolp (car form))))

+ (error "Cannot get the setf-method of ~S." form))

+ ((get (car form) 'setf-method)

+ (apply (get (car form) 'setf-method) (cdr form)))

+ ((get (car form) 'setf-update-fn)

+ (let ((vars (mapcar #'(lambda (x)

+ (declare (ignore x))

+ (gensym))

+ (cdr form)))

+ (store (gensym)))

+ (values vars (cdr form) (list store)

+ `(,(get (car form) 'setf-update-fn)

+ ,@vars ,store)

+ (cons (car form) vars))))

+ ((get (car form) 'setf-lambda)

+ (let* ((vars (mapcar #'(lambda (x)

+ (declare (ignore x))

+ (gensym))

+ (cdr form)))

+ (store (gensym))

+ (l (get (car form) 'setf-lambda))

+ (f `(lambda ,(car l)

+ (funcall #'(lambda ,(cadr l) ,@(cddr l))

+ ',store))))

+ (values vars (cdr form) (list store)

+ (apply f vars)

+ (cons (car form) vars))))

+ ((macro-function (car form))

+ (get-setf-method-multiple-value (macroexpand-1 form)))

+ (t

+ (error "Cannot expand the SETF form ~S." form))))

+

diff --git a/gcl/pcl/impl/kcl/kcl-low.lisp b/gcl/pcl/impl/kcl/kcl-low.lisp
new file mode 100644
index 000000000..77cb4f569
--- /dev/null
+++ b/gcl/pcl/impl/kcl/kcl-low.lisp

@@ -0,0 +1,438 @@

+;;;-*-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.

+;;; *************************************************************************

+;;;

+;;; The version of low for Kyoto Common Lisp (KCL)

+(in-package "SI")

+(export '(%structure-name

+ %compiled-function-name

+ %set-compiled-function-name

+ %instance-ref

+ %set-instance-ref))

+(in-package 'pcl)

+

+(shadow 'lisp:dotimes)

+

+(defmacro dotimes ((var form &optional (val nil)) &rest body &environment env)

+ (multiple-value-bind (doc decls bod)

+ (extract-declarations body env)

+ (declare (ignore doc))

+ (let ((limit (gensym))

+ (label (gensym)))

+ `(let ((,limit ,form)

+ (,var 0))

+ (declare (fixnum ,limit ,var))

+ ,@decls

+ (block nil

+ (tagbody

+ ,label

+ (when (>= ,var ,limit) (return-from nil ,val))

+ ,@bod

+ (setq ,var (the fixnum (1+ ,var)))

+ (go ,label)))))))

+

+(defun memq (item list) (member item list :test #'eq))

+(defun assq (item list) (assoc item list :test #'eq))

+(defun posq (item list) (position item list :test #'eq))

+

+(si:define-compiler-macro memq (item list)

+ (let ((var (gensym)))

+ (once-only (item)

+ `(let ((,var ,list))

+ (loop (unless ,var (return nil))

+ (when (eq ,item (car ,var))

+ (return ,var))

+ (setq ,var (cdr ,var)))))))

+

+(si:define-compiler-macro assq (item list)

+ (let ((var (gensym)))

+ (once-only (item)

+ `(dolist (,var ,list nil)

+ (when (eq ,item (car ,var))

+ (return ,var))))))

+

+(si:define-compiler-macro posq (item list)

+ (let ((var (gensym)) (index (gensym)))

+ (once-only (item)

+ `(let ((,var ,list) (,index 0))

+ (declare (fixnum ,index))

+ (dolist (,var ,list nil)

+ (when (eq ,item ,var)

+ (return ,index))

+ (incf ,index))))))

+

+(defun printing-random-thing-internal (thing stream)

+ (format stream "~X" (si:address thing)))

+

+(defmacro %svref (vector index)

+ `(svref (the simple-vector ,vector) (the fixnum ,index)))

+

+(defsetf %svref (vector index) (new-value)

+ `(setf (svref (the simple-vector ,vector) (the fixnum ,index))

+ ,new-value))

+

+

+;;;

+;;; std-instance-p

+;;;

+#-akcl

+(si:define-compiler-macro std-instance-p (x)

+ (once-only (x)

+ `(and (si:structurep ,x)

+ (eq (si:%structure-name ,x) 'std-instance))))

+

+#+akcl

+(progn

+

+#-new-kcl-wrapper

+;; declare that std-instance-p may be computed simply, and will not change.

+(si::freeze-defstruct 'std-instance)

+

+(si::freeze-defstruct 'method-call)

+(si::freeze-defstruct 'fast-method-call)

+

+(defvar *pcl-funcall*

+ `(lambda (loc)

+ (compiler::wt-nl

+ "{object _funobj = " loc ";"

+ "if(Rset&&type_of(_funobj)!=t_symbol)funcall_no_event(_funobj);

+ else super_funcall(_funobj);}")))

+

+(setq compiler::*super-funcall* *pcl-funcall*)

+

+(defmacro fmc-funcall (fn pv-cell next-method-call &rest args)

+ `(funcall ,fn ,pv-cell ,next-method-call ,@args))

+

+)

+

+;;;

+;;; turbo-closure patch. See the file kcl-mods.text for details.

+;;;

+#-turbo-closure-env-size

+(clines "

+object cclosure_env_nthcdr (n,cc)

+int n; object cc;

+{ object env;

+ if(n<0)return Cnil;

+ if(type_of(cc)!=t_cclosure)return Cnil;

+ env=cc->cc.cc_env;

+ while(n-->0)

+ {if(type_of(env)!=t_cons)return Cnil;

+ env=env->c.c_cdr;}

+ return env;

+}")

+

+#+turbo-closure-env-size

+(clines "

+object cclosure_env_nthcdr (n,cc)

+int n; object cc;

+{ object env,*turbo;

+ if(n<0)return Cnil;

+ if(type_of(cc)!=t_cclosure)return Cnil;

+ if((turbo=cc->cc.cc_turbo)==NULL)

+ {env=cc->cc.cc_env;

+ while(n-->0)

+ {if(type_of(env)!=t_cons)return Cnil;

+ env=env->c.c_cdr;}

+ return env;}

+ else

+ {if(n>=fix(*(turbo-1)))return Cnil;

+ return turbo[n];}

+}")

+

+;; This is the completely safe version.

+(defentry cclosure-env-nthcdr (int object) (object cclosure_env_nthcdr))

+;; This is the unsafe but fast version.

+(defentry %cclosure-env-nthcdr (int object) (object cclosure_env_nthcdr))

+

+;;; #+akcl means this is an AKCL newer than 5/11/89 (structures changed)

+(eval-when (compile load eval)

+

+#+new-kcl-wrapper

+(progn

+

+(defun instance-ref (slots index)

+ (si:structure-ref1 slots index))

+

+(defun set-instance-ref (slots index value)

+ (si:structure-set1 slots index value))

+

+(defsetf instance-ref set-instance-ref)

+(defsetf %instance-ref %set-instance-ref)

+)

+

+(defsetf structure-def set-structure-def)

+

+;;((name args-type result-type side-effect-p new-object-p c-expression) ...)

+(defparameter *kcl-function-inlines*

+ '((%fboundp (t) compiler::boolean nil nil "(#0)->s.s_gfdef!=OBJNULL")

+ (%symbol-function (t) t nil nil "(#0)->s.s_gfdef")

+ #-akcl (si:structurep (t) compiler::boolean nil nil "type_of(#0)==t_structure")

+ #-akcl (si:%structure-name (t) t nil nil "(#0)->str.str_name")

+ #+akcl (si:%structure-name (t) t nil nil "(#0)->str.str_def->str.str_self[0]")

+ #+new-kcl-wrapper

+ (si:%instance-ref (t t) t nil nil "(#0)->str.str_self[fix(#1)]")

+ #+new-kcl-wrapper

+ (si:%set-instance-ref (t t t) t t nil "(#0)->str.str_self[fix(#1)]=(#2)")

+ (si:%compiled-function-name (t) t nil nil "(#0)->cf.cf_name")

+ (si:%set-compiled-function-name (t t) t t nil "((#0)->cf.cf_name)=(#1)")

+ (cclosurep (t) compiler::boolean nil nil "type_of(#0)==t_cclosure")

+ #+akcl (sfun-p (t) compiler::boolean nil nil "type_of(#0)==t_sfun")

+ (%cclosure-env (t) t nil nil "(#0)->cc.cc_env")

+ (%set-cclosure-env (t t) t t nil "((#0)->cc.cc_env)=(#1)")

+ #+turbo-closure

+ (%cclosure-env-nthcdr (fixnum t) t nil nil "(#1)->cc.cc_turbo[#0]")

+

+ (logxor (fixnum fixnum) fixnum nil nil "((#0) ^ (#1))")))

+

+(defun make-function-inline (inline)

+ (setf (get (car inline) 'compiler::inline-always)

+ (list (if (fboundp 'compiler::flags)

+ (let ((opt (cdr inline)))

+ (list (first opt) (second opt)

+ (logior (if (fourth opt) 1 0) ; allocates-new-storage

+ (if (third opt) 2 0) ; side-effect

+ (if nil 4 0) ; constantp

+ (if (eq (car inline) 'logxor)

+ 8 0)) ;result type from args

+ (fifth opt)))

+ (cdr inline)))))

+

+(defmacro define-inlines ()

+ `(progn

+ ,@(mapcan #'(lambda (inline)

+ (let* ((*package* *the-pcl-package*)

+ (name (intern (format nil "~S inline" (car inline))))

+ (vars (mapcar #'(lambda (type)

+ (declare (ignore type))

+ (gensym))

+ (cadr inline))))

+ `((make-function-inline ',(cons name (cdr inline)))

+ ,@(when (or (every #'(lambda (type) (eq type 't))

+ (cadr inline))

+ (char= #\% (aref (symbol-name (car inline)) 0)))

+ `((defun ,(car inline) ,vars

+ ,@(mapcan #'(lambda (var var-type)

+ (unless (eq var-type 't)

+ `((declare (type ,var-type ,var)))))

+ vars (cadr inline))

+ (,name ,@vars))

+ (make-function-inline ',inline))))))

+ *kcl-function-inlines*)))

+

+(define-inlines)

+)

+

+(defsetf si:%compiled-function-name si:%set-compiled-function-name)

+(defsetf %cclosure-env %set-cclosure-env)

+

+(defun set-function-name-1 (fn new-name ignore)

+ (declare (ignore ignore))

+ (cond ((compiled-function-p fn)

+ (si::turbo-closure fn)

+ ;;(when (symbolp new-name) (proclaim-defgeneric new-name nil))

+ (setf (si:%compiled-function-name fn) new-name))

+ ((and (listp fn)

+ (eq (car fn) 'lambda-block))

+ (setf (cadr fn) new-name))

+ ((and (listp fn)

+ (eq (car fn) 'lambda))

+ (setf (car fn) 'lambda-block

+ (cdr fn) (cons new-name (cdr fn)))))

+ fn)

+

+

+#+akcl (clines "#define AKCL206")

+

+(clines "

+#ifdef AKCL206

+use_fast_links();

+#endif

+

+object set_cclosure (result_cc,value_cc,available_size)

+ object result_cc,value_cc; int available_size;

+{

+ object result_env_tail,value_env_tail; int i;

+#ifdef AKCL206

+ /* If we are currently using fast linking, */

+ /* make sure to remove the link for result_cc. */

+ use_fast_links(3,Cnil,result_cc);

+#endif

+ result_env_tail=result_cc->cc.cc_env;

+ value_env_tail=value_cc->cc.cc_env;

+ for(i=available_size;

+ result_env_tail!=Cnil && i>0;

+ result_env_tail=CMPcdr(result_env_tail), value_env_tail=CMPcdr(value_env_tail))

+ CMPcar(result_env_tail)=CMPcar(value_env_tail), i--;

+ result_cc->cc.cc_self=value_cc->cc.cc_self;

+ result_cc->cc.cc_data=value_cc->cc.cc_data;

+#ifndef AKCL206

+ result_cc->cc.cc_start=value_cc->cc.cc_start;

+ result_cc->cc.cc_size=value_cc->cc.cc_size;

+#endif

+ return result_cc;

+}")

+

+(defentry %set-cclosure (object object int) (object set_cclosure))

+

+

+(defun structure-functions-exist-p ()

+ t)

+

+(si:define-compiler-macro structure-instance-p (x)

+ (once-only (x)

+ `(and (si:structurep ,x)

+ (not (eq (si:%structure-name ,x) 'std-instance)))))

+

+(defun structure-type (x)

+ (and (si:structurep x)

+ (si:%structure-name x)))

+

+(si:define-compiler-macro structure-type (x)

+ (once-only (x)

+ `(and (si:structurep ,x)

+ (si:%structure-name ,x))))

+

+(defun structure-type-p (type)

+ (or (not (null (gethash type *structure-table*)))

+ (let (#+akcl(s-data nil))

+ (and (symbolp type)

+ #+akcl (setq s-data (get type 'si::s-data))

+ #-akcl (get type 'si::is-a-structure)

+ (null #+akcl (si::s-data-type s-data)

+ #-akcl (get type 'si::structure-type))))))

+

+(defun structure-type-included-type-name (type)

+ (or (car (gethash type *structure-table*))

+ #+akcl (let ((includes (si::s-data-includes (get type 'si::s-data))))

+ (when includes

+ (si::s-data-name includes)))

+ #-akcl (get type 'si::structure-include)))

+

+(defun structure-type-internal-slotds (type)

+ #+akcl (si::s-data-slot-descriptions (get type 'si::s-data))

+ #-akcl (get type 'si::structure-slot-descriptions))

+

+(defun structure-type-slot-description-list (type)

+ (or (cdr (gethash type *structure-table*))

+ (mapcan #'(lambda (slotd)

+ #-new-kcl-wrapper

+ (when (and slotd (car slotd))

+ (let ((offset (fifth slotd)))

+ (let ((reader #'(lambda (x)

+ #+akcl (si:structure-ref1 x offset)

+ #-akcl (si:structure-ref x type offset)))

+ (writer #'(lambda (v x)

+ (si:structure-set x type offset v))))

+ #+turbo-closure (si:turbo-closure reader)

+ #+turbo-closure (si:turbo-closure writer)

+ (let* ((reader-sym

+ (let ((*package* *the-pcl-package*))

+ (intern (format nil "~s SLOT~D" type offset))))

+ (writer-sym (get-setf-function-name reader-sym))

+ (slot-name (first slotd))

+ (read-only-p (fourth slotd)))

+ (setf (symbol-function reader-sym) reader)

+ (setf (symbol-function writer-sym) writer)

+ (do-standard-defsetf-1 reader-sym)

+ (list (list slot-name

+ reader-sym

+ reader

+ (and (not read-only-p) writer)))))))

+ #+new-kcl-wrapper

+ (list slotd))

+ (let ((slotds (structure-type-internal-slotds type))

+ (inc (structure-type-included-type-name type)))

+ (if inc

+ (nthcdr (length (structure-type-internal-slotds inc))

+ slotds)

+ slotds)))))

+

+#+new-kcl-wrapper

+(defun si::slot-reader-function (slot)

+ (let ((offset (si::slot-offset slot)))

+ (si:turbo-closure #'(lambda (x)

+ (si::structure-ref1 x offset)))))

+

+#+new-kcl-wrapper

+(defun si::slot-writer-function (slot)

+ (let ((offset (si::slot-offset slot)))

+ (si:turbo-closure #'(lambda (x)

+ (si::structure-set1 x offset)))))

+

+(mapcar #'(lambda (fname value)

+ (setf (symbol-function fname) (symbol-function value)))

+ '(structure-slotd-name

+ structure-slotd-accessor-symbol

+ structure-slotd-reader-function

+ structure-slotd-writer-function

+ structure-slotd-type

+ structure-slotd-init-form)

+ #-new-kcl-wrapper

+ '(first second third fourth function-returning-nil function-returning-nil)

+ #+new-kcl-wrapper

+ '(si::slot-name si::slot-accessor-name

+ si::slot-reader-function si::slot-writer-function

+ si::slot-type si::slot-default-init))

+

+

+;; Construct files sys-proclaim.lisp and sys-package.lisp

+;; The file sys-package.lisp must be loaded first, since the

+;; package sys-proclaim.lisp will refer to symbols and they must

+;; be in the right packages. sys-proclaim.lisp contains function

+;; declarations and declarations that certain things are closures.

+

+(defun renew-sys-files()

+ ;; packages:

+ (compiler::get-packages "sys-package.lisp")

+ (with-open-file (st "sys-package.lisp"

+ :direction :output

+ :if-exists :append)

+ (format st "(in-package 'SI)

+(export '(%structure-name

+ %compiled-function-name

+ %set-compiled-function-name))

+(in-package 'pcl)

+"))

+

+ ;; proclaims

+ (compiler::make-all-proclaims "*.fn")

+ (let ((*package* (find-package 'user)))

+ (with-open-file (st "sys-proclaim.lisp"

+ :direction :output

+ :if-exists :append)

+ ;;(format st "~%(IN-PACKAGE \"PCL\")~%")

+ (print

+ `(dolist (v ',

+

+ (sloop::sloop for v in-package "PCL"

+ when (get v 'compiler::proclaimed-closure)

+ collect v))

+ (setf (get v 'compiler::proclaimed-closure) t))

+ st)

+ (format st "~%")

+ )))

+

+

diff --git a/gcl/pcl/impl/kcl/kcl-mods.text b/gcl/pcl/impl/kcl/kcl-mods.text
new file mode 100644
index 000000000..741e41ac6
--- /dev/null
+++ b/gcl/pcl/impl/kcl/kcl-mods.text

@@ -0,0 +1,224 @@

+If you have akcl version 604 or newer, do not make these patches.

+

+

+(1) Turbo closure patch

+

+To make the turbo closure stuff work, make the following changes to KCL.

+These changes can also work for an IBCL.

+

+The three patches in this file add two features (reflected in the

+value of *features*) to your KCL or IBCL:

+ a feature named :TURBO-CLOSURE which increases the speed of the

+ code generated by FUNCALLABLE-INSTANCE-DATA-1

+ (previous versions of the file kcl-mods.text had this feature only),

+and

+ a feature named :TURBO-CLOSURE-ENV-SIZE which increases the speed

+ of the function FUNCALLABLE-INSTANCE-P.

+

+(This file comprises two features rather than just one to allow the

+PCL system to be work in KCL systems that do not have this patch,

+or that have the old version of this patch.)

+

+

+The first of these patches changes the turbo_closure function to

+store the size of the environment in the turbo structure.

+

+The second of patch fixes a garbage-collector bug in which

+the turbo structure was sometimes ignored, AND also adapts

+the garbage-collector to conform to the change made in the

+first patch. The bug has been fixed in newer versions of

+AKCL, but it is still necessary to apply this patch, if the

+first and third patches are applied.

+

+The third change pushes :turbo-closure and :turbo-closure-env-size

+on the *features* list so that PCL will know that turbo closures

+are enabled.

+

+

+Note that these changes have to be made before PCL is compiled, and a

+PCL which is compiled in a KCL/IBCL with these changes can only be run

+in a KCL/IBCL with these changes.

+

+(1-1) edit the function turbo_closure in the file kcl/c/cfun.c,

+change the lines

+----------

+turbo_closure(fun)

+object fun;

+{

+ object l;

+ int n;

+

+ for (n = 0, l = fun->cc.cc_env; !endp(l); n++, l = l->c.c_cdr)

+ ;

+ fun->cc.cc_turbo = (object *)alloc_contblock(n*sizeof(object));

+ for (n = 0, l = fun->cc.cc_env; !endp(l); n++, l = l->c.c_cdr)

+ fun->cc.cc_turbo[n] = l;

+}

+----------

+to

+----------

+turbo_closure(fun)

+object fun;

+{

+ object l,*block;

+ int n;

+

+ if(fun->cc.cc_turbo==NULL)

+ {for (n = 0, l = fun->cc.cc_env; !endp(l); n++, l = l->c.c_cdr);

+ block=(object *)alloc_contblock((1+n)*sizeof(object));

+ *block=make_fixnum(n);

+ fun->cc.cc_turbo = block+1; /* equivalent to &block[1] */

+ for (n = 0, l = fun->cc.cc_env; !endp(l); n++, l = l->c.c_cdr)

+ fun->cc.cc_turbo[n] = l;}

+}

+----------

+

+

+(1-2) edit the function mark_object in the file kcl/c/gbc.c,

+Find the lines following case t_cclosure: in mark_object.

+If they look like the ones between the lines marked (KCL),

+make the first change, but if the look like the lines marked

+(AKCL), apply the second change instead, and if the file

+sgbc.c exists, apply the third change to it.

+(1-2-1) Change:

+(KCL)----------

+ case t_cclosure:

+ mark_object(x->cc.cc_name);

+ mark_object(x->cc.cc_env);

+ mark_object(x->cc.cc_data);

+ if (x->cc.cc_start == NULL)

+ break;

+ if (what_to_collect == t_contiguous) {

+ if (get_mark_bit((int *)(x->cc.cc_start)))

+ break;

+ mark_contblock(x->cc.cc_start, x->cc.cc_size);

+ if (x->cc.cc_turbo != NULL) {

+ for (i = 0, y = x->cc.cc_env;

+ type_of(y) == t_cons;

+ i++, y = y->c.c_cdr);

+ mark_contblock((char *)(x->cc.cc_turbo),

+ i*sizeof(object));

+ }

+ }

+ break;

+(KCL)----------

+to

+(KCL new)----------

+ case t_cclosure:

+ mark_object(x->cc.cc_name);

+ mark_object(x->cc.cc_env);

+ mark_object(x->cc.cc_data);

+ if (what_to_collect == t_contiguous)

+ if (x->cc.cc_turbo != NULL) {

+ mark_contblock((char *)(x->cc.cc_turbo-1),

+ (1+fix(*(x->cc.cc_turbo-1)))*sizeof(object));

+ }

+ if (x->cc.cc_start == NULL)

+ break;

+ if (what_to_collect == t_contiguous) {

+ if (get_mark_bit((int *)(x->cc.cc_start)))

+ break;

+ mark_contblock(x->cc.cc_start, x->cc.cc_size);

+ }

+ break;

+(KCL new)----------

+(1-2-2) Or, Change:

+(AKCL)----------

+ case t_cclosure:

+ mark_object(x->cc.cc_name);

+ mark_object(x->cc.cc_env);

+ mark_object(x->cc.cc_data);

+ if (what_to_collect == t_contiguous) {

+ if (x->cc.cc_turbo != NULL) {

+ for (i = 0, y = x->cc.cc_env;

+ type_of(y) == t_cons;

+ i++, y = y->c.c_cdr);

+ mark_contblock((char *)(x->cc.cc_turbo),

+ i*sizeof(object));

+ }

+ }

+ break;

+(AKCL)----------

+To:

+(AKCL new)----------

+ case t_cclosure:

+ mark_object(x->cc.cc_name);

+ mark_object(x->cc.cc_env);

+ mark_object(x->cc.cc_data);

+ if (what_to_collect == t_contiguous) {

+ if (x->cc.cc_turbo != NULL)

+ mark_contblock((char *)(x->cc.cc_turbo-1),

+ (1+fix(*(x->cc.cc_turbo-1)))*sizeof(object));

+ }

+ break;

+(AKCL new)----------

+(1-2-3) In sgbc.c (if it exists), Change:

+(AKCL)----------

+ case t_cclosure:

+ sgc_mark_object(x->cc.cc_name);

+ sgc_mark_object(x->cc.cc_env);

+ sgc_mark_object(x->cc.cc_data);

+ if (what_to_collect == t_contiguous) {

+ if (x->cc.cc_turbo != NULL) {

+ for (i = 0, y = x->cc.cc_env;

+ type_of(y) == t_cons;

+ i++, y = y->c.c_cdr);

+ mark_contblock((char *)(x->cc.cc_turbo),

+ i*sizeof(object));

+ }

+ }

+ break;

+(AKCL)----------

+To:

+(AKCL new)----------

+ case t_cclosure:

+ sgc_mark_object(x->cc.cc_name);

+ sgc_mark_object(x->cc.cc_env);

+ sgc_mark_object(x->cc.cc_data);

+ if (what_to_collect == t_contiguous) {

+ if (x->cc.cc_turbo != NULL)

+ mark_contblock((char *)(x->cc.cc_turbo-1),

+ (1+fix(*(x->cc.cc_turbo-1)))*sizeof(object));

+ }

+ break;

+(AKCL new)----------

+

+

+(1-3) edit the function init_main in the file kcl/c/main.c,

+change the lines where setting the value of *features* to add a :turbo-closure

+and a :turbo-closure-env-size into the list in your KCL/IBCL.

+

+For example, in Sun4(SunOS) version of IBCL

+changing the lines:

+----------

+ make_special("*FEATURES*",

+ make_cons(make_ordinary("SUN4"),

+ make_cons(make_ordinary("SPARC"),

+ make_cons(make_ordinary("IEEE-FLOATING-POINT"),

+ make_cons(make_ordinary("UNIX"),

+ make_cons(make_ordinary("BSD"),

+ make_cons(make_ordinary("COMMON"),

+ make_cons(make_ordinary("IBCL"), Cnil))))))));

+----------

+to

+----------

+ make_special("*FEATURES*",

+ make_cons(make_ordinary("SUN4"),

+ make_cons(make_ordinary("SPARC"),

+ make_cons(make_ordinary("IEEE-FLOATING-POINT"),

+ make_cons(make_ordinary("UNIX"),

+ make_cons(make_ordinary("BSD"),

+ make_cons(make_ordinary("COMMON"),

+ make_cons(make_ordinary("IBCL"),

+ make_cons(make_keyword("TURBO-CLOSURE"),

+ make_cons(make_keyword("TURBO-CLOSURE-ENV-SIZE"),

+ Cnil))))))))));

+----------

+But, if the C macro ADD_FEATURE is defined at the end of main.c,

+use it instead.

+Insert the lines:

+ ADD_FEATURE("TURBO-CLOSURE");

+ ADD_FEATURE("TURBO-CLOSURE-ENV-SIZE");

+After the line:

+ ADD_FEATURE("AKCL");

+

diff --git a/gcl/pcl/impl/kcl/kcl-notes.text b/gcl/pcl/impl/kcl/kcl-notes.text
new file mode 100644
index 000000000..fc8a6831e
--- /dev/null
+++ b/gcl/pcl/impl/kcl/kcl-notes.text

@@ -0,0 +1,39 @@

+

+Some notes on using "5/1/90 May Day PCL (REV 4b)" with KCL and AKCL.

+

+1. KCL will try to load the PCL file "init" when it starts up,

+ if you rename the files as is mentioned in defsys.lisp and the

+ currect directory is the one containing PCL. I suggest that

+ you do not rename any file except maybe "defsys", and also

+ that you change the (files-renamed-p t) to (files-renamed-p nil)

+ in defsys.lisp.

+

+2. Do not comment out the file kcl-patches.lisp, even if you are

+ using AKCL. It contins a patch to make compiler messages more

+ informative for AKCL, and also sets compiler::*compile-ordinaries*

+ to T, so that methods will get compiled.

+

+3. While fixup.lisp compiles, there will be a pause, because

+ KCL's compiler is not reentrant, and some uncompiled

+ code is run. If you want, you can change the form

+ (fix-early-generic-functions) to (fix-early-generic-functions t)

+ in fixup.lisp to see what is happening.

+

+4. (If you are using AKCL 605 or newer, skip this step.)

+ If you want, you can apply the changes in kcl-mods.text

+ to your KCL or AKCL to make PCL run faster. The file kcl-mods.text

+ is different from what it was in versions of PCL earlier than

+ May Day PCL. If you do not make these changes, or if you made

+ the old changes, things will still work.

+

+5. If you are using AKCL, and you previously used the kcl-low.lisp

+ file from rascal.ics.utexas.edu, you should not use it this time.

+ The kcl-low.lisp that comes with May Day PCL works fine. (If you

+ insist on using an old version of kcl-low.lisp, you will need to

+ use an old version of the KCL part of fin.lisp as well: this is

+ what is done for IBCL, by the way.)

+

+6. I recommend that you use AKCL version 457 or newer rather than using

+ KCL or an older version of AKCL, because there are some bugs in KCL

+ that cause problems for May Day PCL.

+

diff --git a/gcl/pcl/impl/kcl/kcl-patches.lisp b/gcl/pcl/impl/kcl/kcl-patches.lisp
new file mode 100644
index 000000000..c051d9be3
--- /dev/null
+++ b/gcl/pcl/impl/kcl/kcl-patches.lisp

@@ -0,0 +1,362 @@

+;;;-*-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 "COMPILER")

+

+#+akcl

+(eval-when (compile load eval)

+

+(when (<= system::*akcl-version* 609)

+ (pushnew :pre_akcl_610 *features*))

+

+(if (and (boundp 'si::*akcl-version*)

+ (>= si::*akcl-version* 604))

+ (progn

+ (pushnew :turbo-closure *features*)

+ (pushnew :turbo-closure-env-size *features*))

+ (when (fboundp 'si::allocate-growth)

+ (pushnew :turbo-closure *features*)))

+

+;; patch around compiler bug.

+(when (<= si::*akcl-version* 609)

+ (let ((vcs "static int Vcs;

+"))

+ (unless (search vcs compiler::*cmpinclude-string*)

+ (setq compiler::*cmpinclude-string*

+ (concatenate 'string vcs compiler::*cmpinclude-string*)))))

+

+(let ((rset "int Rset;

+"))

+ (unless (search rset compiler::*cmpinclude-string*)

+ (setq compiler::*cmpinclude-string*

+ (concatenate 'string rset compiler::*cmpinclude-string*))))

+

+(when (get 'si::basic-wrapper 'si::s-data)

+ (pushnew :new-kcl-wrapper *features*)

+ (pushnew :structure-wrapper *features*))

+

+)

+

+

+#+akcl

+(progn

+

+(unless (fboundp 'real-c2lambda-expr-with-key)

+ (setf (symbol-function 'real-c2lambda-expr-with-key)

+ (symbol-function 'c2lambda-expr-with-key)))

+

+(defun c2lambda-expr-with-key (lambda-list body)

+ (declare (special *sup-used*))

+ (setq *sup-used* t)

+ (real-c2lambda-expr-with-key lambda-list body))

+

+

+;There is a bug in the implementation of *print-circle* that

+;causes some akcl debugging commands (including :bt and :bl)

+;to cause the following error when PCL is being used:

+;Unrecoverable error: value stack overflow.

+

+;When a CLOS object is printed, travel_push_object ends up

+;traversing almost the whole class structure, thereby overflowing

+;the value-stack.

+

+;from lsp/debug.lsp.

+;*print-circle* is badly implemented in kcl.

+;it has two separate problems that should be fixed:

+; 1. it traverses the printed object putting all objects found

+; on the value stack (rather than in a hash table or some

+; other structure; this is a problem because the size of the value stack

+; is fixed, and a potentially unbounded number of objects

+; need to be traversed), and

+; 2. it blindly traverses all slots of any

+; kind of structure including std-object structures.

+; This is safe, but not always necessary, and is very time-consuming

+; for CLOS objects (because it will always traverse every class).

+

+;For now, avoid using *print-circle* T when it will cause problems.

+

+(eval-when (compile eval)

+(defmacro si::f (op &rest args)

+ `(the fixnum (,op ,@ (mapcar #'(lambda (x) `(the fixnum ,x)) args) )))

+

+(defmacro si::fb (op &rest args)

+ `(,op ,@ (mapcar #'(lambda (x) `(the fixnum ,x)) args) ))

+)

+

+(defun si::display-env (n env)

+ (do ((v (reverse env) (cdr v)))

+ ((or (not (consp v)) (si::fb > (fill-pointer si::*display-string*) n)))

+ (or (and (consp (car v))

+ (listp (cdar v)))

+ (return))

+ (let ((*print-circle* (can-use-print-circle-p (cadar v))))

+ (format si::*display-string* "~s=~s~@[,~]" (caar v) (cadar v) (cdr v)))))

+

+(defun si::display-compiled-env ( plength ihs &aux

+ (base (si::ihs-vs ihs))

+ (end (min (si::ihs-vs (1+ ihs)) (si::vs-top))))

+ (format si::*display-string* "")

+ (do ((i base )

+ (v (get (si::ihs-fname ihs) 'si::debug) (cdr v)))

+ ((or (si::fb >= i end)(si::fb > (fill-pointer si::*display-string*) plength)))

+ (let ((*print-circle* (can-use-print-circle-p (si::vs i))))

+ (format si::*display-string* "~a~@[~d~]=~s~@[,~]"

+ (or (car v) 'si::loc) (if (not (car v)) (si::f - i base)) (si::vs i)

+ (si::fb < (setq i (si::f + i 1)) end)))))

+

+(clines "#define objnull_p(x) ((x==OBJNULL)?Ct:Cnil)")

+(defentry objnull-p (object) (object "objnull_p"))

+

+(defun can-use-print-circle-p (x)

+ (catch 'can-use-print-circle-p

+ (can-use-print-circle-p1 x nil)))

+

+(defun can-use-print-circle-p1 (x so-far)

+ (and (not (objnull-p x)) ; because of deficiencies in the compiler, maybe?

+ (if (member x so-far)

+ (throw 'can-use-print-circle-p t)

+ (let ((so-far (cons x so-far)))

+ (flet ((can-use-print-circle-p (x)

+ (can-use-print-circle-p1 x so-far)))

+ (typecase x

+ (vector (or (not (eq 't (array-element-type x)))

+ (every #'can-use-print-circle-p x)))

+ (cons (and (can-use-print-circle-p (car x))

+ (can-use-print-circle-p (cdr x))))

+ (array (or (not (eq 't (array-element-type x)))

+ (let* ((rank (array-rank x))

+ (dimensions (make-list rank)))

+ (dotimes (i rank)

+ (setf (nth i dimensions) (array-dimension x i)))

+ (or (member 0 dimensions)

+ (do ((cursor (make-list rank :initial-element 0)))

+ (nil)

+ (declare (:dynamic-extent cursor))

+ (unless (can-use-print-circle-p

+ (apply #'aref x cursor))

+ (return nil))

+ (when (si::increment-cursor cursor dimensions)

+ (return t)))))))

+ (t (or (not (si:structurep x))

+ (let* ((def (si:structure-def x))

+ (name (si::s-data-name def))

+ (len (si::s-data-length def))

+ (pfun (si::s-data-print-function def)))

+ (and (null pfun)

+ (dotimes (i len t)

+ (unless (can-use-print-circle-p

+ (si:structure-ref x name i))

+ (return nil)))))))))))))

+

+(defun si::apply-display-fun (display-fun n lis)

+ (let ((*print-length* si::*debug-print-level*)

+ (*print-level* si::*debug-print-level*)

+ (*print-pretty* nil)

+ (*PRINT-CASE* :downcase)

+ (*print-circle* nil)

+ )

+ (setf (fill-pointer si::*display-string*) 0)

+ (format si::*display-string* "{")

+ (funcall display-fun n lis)

+ (when (si::fb > (fill-pointer si::*display-string*) n)

+ (setf (fill-pointer si::*display-string*) n)

+ (format si::*display-string* "..."))

+

+ (format si::*display-string* "}")

+ )

+ si::*display-string*

+ )

+

+;The old definition of this had a bug:

+;sometimes it returned without calling mv-values.

+(defun si::next-stack-frame (ihs &aux line-info li i k na)

+ (cond ((si::fb < ihs si::*ihs-base*)

+ (si::mv-values nil nil nil nil nil))

+ ((let (fun)

+ ;; next lower visible ihs

+ (si::mv-setq (fun i) (si::get-next-visible-fun ihs))

+ (setq na fun)

+ (cond ((and (setq line-info (get fun 'si::line-info))

+ (do ((j (si::f + ihs 1) (si::f - j 1))

+ (form ))

+ ((<= j i) nil)

+ (setq form (si::ihs-fun j))

+ (cond ((setq li (si::get-line-of-form form line-info))

+ (return-from si::next-stack-frame

+ (si::mv-values

+ i fun li

+ ;; filename

+ (car (aref line-info 0))

+ ;;environment

+ (list (si::vs (setq k (si::ihs-vs j)))

+ (si::vs (1+ k))

+ (si::vs (+ k 2)))))))))))))

+ ((and (not (special-form-p na))

+ (not (get na 'si::dbl-invisible))

+ (fboundp na))

+ (si::mv-values i na nil nil

+ (if (si::ihs-not-interpreted-env i)

+ nil

+ (let ((i (si::ihs-vs i)))

+ (list (si::vs i) (si::vs (1+ i)) (si::vs (si::f + i 2)))))))

+ (t (si::mv-values nil nil nil nil nil))))

+)

+

+#+pre_akcl_610

+(progn

+

+;(proclaim '(optimize (safety 0) (speed 3) (space 1)))

+

+;Not needed... make-top-level-form generates defuns now.

+;(setq compiler::*compile-ordinaries* t)

+

+(eval-when (compile load eval)

+(unless (fboundp 'original-co1typep)

+ (setf (symbol-function 'original-co1typep) #'co1typep))

+)

+

+(defun new-co1typep (f args)

+ (or (original-co1typep f args)

+ (let ((x (car args))

+ (type (cadr args)))

+ (when (constantp type)

+ (let ((ntype (si::normalize-type (eval type))))

+ (when (and (eq (car ntype) 'satisfies)

+ (cadr ntype)

+ (symbolp (cadr ntype))

+ (symbol-package (cadr ntype)))

+ (c1expr `(the boolean (,(cadr ntype) ,x)))))))))

+

+(setf (symbol-function 'co1typep) #'new-co1typep)

+

+)

+

+#-(or akcl xkcl)

+(progn

+(in-package 'system)

+

+;;; This makes DEFMACRO take &WHOLE and &ENVIRONMENT args anywhere

+;;; in the lambda-list. The former allows deviation from the CL spec,

+;;; but what the heck.

+

+(eval-when (compile) (proclaim '(optimize (safety 2) (space 3))))

+

+(defvar *old-defmacro*)

+

+(defun new-defmacro (whole env)

+ (flet ((call-old-definition (new-whole)

+ (funcall *old-defmacro* new-whole env)))

+ (if (not (and (consp whole)

+ (consp (cdr whole))

+ (consp (cddr whole))

+ (consp (cdddr whole))))

+ (call-old-definition whole)

+ (let* ((ll (caddr whole))

+ (env-tail (do ((tail ll (cdr tail)))

+ ((not (consp tail)) nil)

+ (when (eq '&environment (car tail))

+ (return tail)))))

+ (if env-tail

+ (call-old-definition (list* (car whole)

+ (cadr whole)

+ (append (list '&environment

+ (cadr env-tail))

+ (ldiff ll env-tail)

+ (cddr env-tail))

+ (cdddr whole)))

+ (call-old-definition whole))))))

+

+(eval-when (load eval)

+ (unless (boundp '*old-defmacro*)

+ (setq *old-defmacro* (macro-function 'defmacro))

+ (setf (macro-function 'defmacro) #'new-defmacro)))

+

+;;;

+;;; setf patches

+;;;

+

+(defun get-setf-method (form)

+ (multiple-value-bind (vars vals stores store-form access-form)

+ (get-setf-method-multiple-value form)

+ (unless (listp vars)

+ (error

+ "The temporary variables component, ~s,

+ of the setf-method for ~s is not a list."

+ vars form))

+ (unless (listp vals)

+ (error

+ "The values forms component, ~s,

+ of the setf-method for ~s is not a list."

+ vals form))

+ (unless (listp stores)

+ (error

+ "The store variables component, ~s,

+ of the setf-method for ~s is not a list."

+ stores form))

+ (unless (= (list-length stores) 1)

+ (error "Multiple store-variables are not allowed."))

+ (values vars vals stores store-form access-form)))

+

+(defun get-setf-method-multiple-value (form)

+ (cond ((symbolp form)

+ (let ((store (gensym)))

+ (values nil nil (list store) `(setq ,form ,store) form)))

+ ((or (not (consp form)) (not (symbolp (car form))))

+ (error "Cannot get the setf-method of ~S." form))

+ ((get (car form) 'setf-method)

+ (apply (get (car form) 'setf-method) (cdr form)))

+ ((get (car form) 'setf-update-fn)

+ (let ((vars (mapcar #'(lambda (x)

+ (declare (ignore x))

+ (gensym))

+ (cdr form)))

+ (store (gensym)))

+ (values vars (cdr form) (list store)

+ `(,(get (car form) 'setf-update-fn)

+ ,@vars ,store)

+ (cons (car form) vars))))

+ ((get (car form) 'setf-lambda)

+ (let* ((vars (mapcar #'(lambda (x)

+ (declare (ignore x))

+ (gensym))

+ (cdr form)))

+ (store (gensym))

+ (l (get (car form) 'setf-lambda))

+ (f `(lambda ,(car l)

+ (funcall #'(lambda ,(cadr l) ,@(cddr l))

+ ',store))))

+ (values vars (cdr form) (list store)

+ (apply f vars)

+ (cons (car form) vars))))

+ ((macro-function (car form))

+ (get-setf-method-multiple-value (macroexpand-1 form)))

+ (t

+ (error "Cannot expand the SETF form ~S." form))))

+

+)

+

diff --git a/gcl/pcl/impl/kcl/makefile.akcl b/gcl/pcl/impl/kcl/makefile.akcl
new file mode 100644
index 000000000..057a3f9de
--- /dev/null
+++ b/gcl/pcl/impl/kcl/makefile.akcl

@@ -0,0 +1,32 @@

+# makefile for making pcl -- W. Schelter.

+

+# Directions:

+# make -f makefile.akcl compile

+# make -f makefile.akcl saved_pcl

+

+SHELL=/bin/sh

+

+LISP=akcl

+

+

+SETUP='(load "pkg.lisp")(load "defsys.lisp")' \

+ '(setq pcl::*default-pathname-extensions* (cons "lisp" "o"))' \

+ '(setq pcl::*pathname-extensions* (cons "lisp" "o"))' \

+ '(load "sys-proclaim.lisp")(compiler::emit-fn t)'

+

+compile:

+ echo ${SETUP} '(pcl::compile-pcl)' | ${LISP}

+

+saved_pcl:

+ echo ${SETUP} '(pcl::load-pcl)(si::save-system "saved_pcl")' | ${LISP}

+

+

+# remake the sys-package.lisp and sys-proclaim.lisp files

+# Those files may be empty on a first build.

+remake-sys-files:

+ echo ${SETUP} '(pcl::load-pcl)(in-package "PCL")(renew-sys-files)' | ${LISP}

+ cp sys-proclaim.lisp xxx

+ cat xxx | sed -e "s/COMPILER::CMP-ANON//g" > sys-proclaim.lisp

+

+clean:

+ rm -f *.o

diff --git a/gcl/pcl/impl/kcl/misc-kcl-patches.text b/gcl/pcl/impl/kcl/misc-kcl-patches.text
new file mode 100644
index 000000000..54bb9c718
--- /dev/null
+++ b/gcl/pcl/impl/kcl/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/gcl/pcl/impl/kcl/new-kcl-wrapper.text b/gcl/pcl/impl/kcl/new-kcl-wrapper.text
new file mode 100644
index 000000000..7f161a6c5
--- /dev/null
+++ b/gcl/pcl/impl/kcl/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