From ffe29b22c87ae31bb060d9f80b673743362f5b66 Mon Sep 17 00:00:00 2001
From: phg <phg>
Date: Tue, 12 Jan 1993 18:28:47 +0000
Subject: [PATCH] September-16-92-PCL-e has been incorporated into the CMUCL
 sources thanks to Rick Harris.

---
 pcl/cloe-low.lisp       |  2 +-
 pcl/compat.lisp         |  2 +-
 pcl/construct.lisp      |  4 ++--
 pcl/coral-low.lisp      |  2 +-
 pcl/cpl.lisp            |  2 +-
 pcl/ctypes.lisp         |  2 +-
 pcl/defs.lisp           | 51 ++++++++++++++++++++++-------------------
 pcl/dlap.lisp           |  2 +-
 pcl/dlisp2.lisp         |  7 +++++-
 pcl/fixup.lisp          |  2 +-
 pcl/fngen.lisp          |  2 +-
 pcl/fsc.lisp            |  2 +-
 pcl/list-functions.lisp |  2 ++
 pcl/precom1.lisp        |  2 +-
 pcl/precom2.lisp        |  2 +-
 pcl/std-class.lisp      | 46 +++++++------------------------------
 pcl/sys-package.lisp    |  4 ++--
 pcl/sysdef.lisp         | 35 ++--------------------------
 pcl/walk.lisp           |  2 +-
 19 files changed, 62 insertions(+), 111 deletions(-)

diff --git a/pcl/cloe-low.lisp b/pcl/cloe-low.lisp
index a58e00085..af7459de3 100644
--- a/pcl/cloe-low.lisp
+++ b/pcl/cloe-low.lisp
@@ -25,7 +25,7 @@
 ;;; *************************************************************************
 ;;;
 
-(in-package 'pcl)
+(in-package :pcl)
 
 (defmacro object-cache-no (object mask)
   `(logand (sys::address-of ,object) ,mask))
diff --git a/pcl/compat.lisp b/pcl/compat.lisp
index 7d10ac387..606915388 100644
--- a/pcl/compat.lisp
+++ b/pcl/compat.lisp
@@ -25,7 +25,7 @@
 ;;; *************************************************************************
 ;;;
 
-(in-package 'pcl)
+(in-package :pcl)
 
 ()
 
diff --git a/pcl/construct.lisp b/pcl/construct.lisp
index 197b7e9f1..17784e2fe 100644
--- a/pcl/construct.lisp
+++ b/pcl/construct.lisp
@@ -29,7 +29,7 @@
 ;;; mechanisms.
 ;;; 
 
-(in-package 'pcl)
+(in-package :pcl)
 
 ;;;
 ;;; defconstructor is used to define special purpose functions which just
@@ -289,7 +289,7 @@
     (when old (remove-constructor class old))
     (install-lazy-constructor-installer constructor)
     (add-constructor class constructor)
-    (setf (symbol-function name) constructor)))
+    (setf (gdefinition name) constructor)))
 
 (defmethod install-lazy-constructor-installer ((constructor constructor))
   (let ((class (constructor-class constructor)))
diff --git a/pcl/coral-low.lisp b/pcl/coral-low.lisp
index a40a29142..650dd7517 100644
--- a/pcl/coral-low.lisp
+++ b/pcl/coral-low.lisp
@@ -25,7 +25,7 @@
 ;;; *************************************************************************
 ;;;
 
-(in-package 'pcl)
+(in-package :pcl)
 
 #-:ccl-1.3
 (ccl::add-transform 'std-instance-p 
diff --git a/pcl/cpl.lisp b/pcl/cpl.lisp
index ff05e951e..6d01615bb 100644
--- a/pcl/cpl.lisp
+++ b/pcl/cpl.lisp
@@ -25,7 +25,7 @@
 ;;; *************************************************************************
 ;;;
 
-(in-package 'pcl)
+(in-package :pcl)
 
 ;;;
 ;;; compute-class-precedence-list
diff --git a/pcl/ctypes.lisp b/pcl/ctypes.lisp
index 190525b68..bd2c7a6d6 100644
--- a/pcl/ctypes.lisp
+++ b/pcl/ctypes.lisp
@@ -25,7 +25,7 @@
 ;;; *************************************************************************
 ;;;
 
-(in-package 'pcl)
+(in-package :pcl)
 
 ;;;
 ;;; The built-in method combination types as taken from page 1-31 of 88-002R.
diff --git a/pcl/defs.lisp b/pcl/defs.lisp
index d5489f1b9..348c1f9dc 100644
--- a/pcl/defs.lisp
+++ b/pcl/defs.lisp
@@ -25,7 +25,7 @@
 ;;; *************************************************************************
 ;;;
 
-(in-package 'pcl)
+(in-package :pcl)
 
 (eval-when (compile load eval)
   
@@ -77,10 +77,12 @@
   (once-only (spec)
     `(cond (#-setf (symbolp ,spec) #+setf t
 	    (let ((,non-setf-var ,spec)) ,@non-setf-case))
+	   #-setf
 	   ((and (listp ,spec)
 		 (eq (car ,spec) 'setf)
 		 (symbolp (cadr ,spec)))
 	    (let ((,setf-var (cadr ,spec))) ,@setf-case))
+	   #-setf
 	   (t
 	    (error
 	      "Can't understand ~S as a generic function specifier.~%~
@@ -115,35 +117,38 @@
 ;;; If symbol names a function which is traced or advised, redefine
 ;;; the `real' definition without affecting the advise.
 ;;;
-(defun fdefine-carefully (symbol new-definition)
-  #+Lispm (si:fdefine symbol new-definition t t)
+(defun fdefine-carefully (name new-definition)
+  #+Lispm (si:fdefine name new-definition t t)
   #+Lucid (let ((lucid::*redefinition-action* nil))
-	    (setf (symbol-function symbol) new-definition))
-  #+excl  (setf (symbol-function symbol) new-definition)
-  #+xerox (let ((advisedp (member symbol il:advisedfns :test #'eq))
-                (brokenp (member symbol il:brokenfns :test #'eq)))
+	    (setf (symbol-function name) new-definition))
+  #+excl  (setf (symbol-function name) new-definition)
+  #+xerox (let ((advisedp (member name il:advisedfns :test #'eq))
+                (brokenp (member name il:brokenfns :test #'eq)))
 	    ;; In XeroxLisp (late of envos) tracing is implemented
 	    ;; as a special case of "breaking".  Advising, however,
 	    ;; is treated specially.
-            (xcl:unadvise-function symbol :no-error t)
-            (xcl:unbreak-function symbol :no-error t)
-            (setf (symbol-function symbol) new-definition)
-            (when brokenp (xcl:rebreak-function symbol))
-            (when advisedp (xcl:readvise-function symbol)))
-  #+setf (setf (fdefinition symbol) new-definition)
+            (xcl:unadvise-function name :no-error t)
+            (xcl:unbreak-function name :no-error t)
+            (setf (symbol-function name) new-definition)
+            (when brokenp (xcl:rebreak-function name))
+            (when advisedp (xcl:readvise-function name)))
+  #+(and setf (not cmu)) (setf (fdefinition name) new-definition)
   #+kcl (setf (symbol-function 
-	       (let ((sym (get symbol 'si::traced)) first-form)
+	       (let ((sym (get name 'si::traced)) first-form)
 		 (if (and sym
-			  (consp (symbol-function symbol))
-			  (consp (setq first-form (nth 3 (symbol-function symbol))))
+			  (consp (symbol-function name))
+			  (consp (setq first-form
+				       (nth 3 (symbol-function name))))
 			  (eq (car first-form) 'si::trace-call))
 		     sym
-		     symbol)))
-	      new-definition)  
-  #-(or Lispm Lucid excl Xerox setf kcl)
-  (setf (symbol-function symbol) new-definition)
-  
-  new-definition)
+		     name)))
+	      new-definition)
+  #+cmu (progn
+	  (c::%%defun name new-definition nil)
+	  (c::note-name-defined name :function)
+	  new-definition)
+  #-(or Lispm Lucid excl Xerox setf kcl cmu)
+  (setf (symbol-function name) new-definition))
 
 (defun gboundp (spec)
   (parse-gspec spec
@@ -261,7 +266,7 @@
 
 (defun inform-type-system-about-std-class (name)
   (let ((predicate-name (make-type-predicate-name name)))
-    (setf (symbol-function predicate-name) (make-type-predicate name))
+    (setf (gdefinition predicate-name) (make-type-predicate name))
     (do-satisfies-deftype name predicate-name)))
 
 (defun make-type-predicate (name)
diff --git a/pcl/dlap.lisp b/pcl/dlap.lisp
index adb1f4abe..88710c107 100644
--- a/pcl/dlap.lisp
+++ b/pcl/dlap.lisp
@@ -25,7 +25,7 @@
 ;;; *************************************************************************
 ;;;
 
-(in-package 'pcl)
+(in-package :pcl)
 
 
 
diff --git a/pcl/dlisp2.lisp b/pcl/dlisp2.lisp
index 7bff7953e..b323a6694 100644
--- a/pcl/dlisp2.lisp
+++ b/pcl/dlisp2.lisp
@@ -25,7 +25,7 @@
 ;;; *************************************************************************
 ;;;
 
-(in-package 'pcl)
+(in-package :pcl)
 
 (defun emit-reader/writer-function (reader/writer 1-or-2-class class-slot-p)
   (values
@@ -136,8 +136,10 @@
   (declare (ignore applyp))
   (if cached-emf-p
       #'(lambda (cache miss-fn)
+	  (declare (type function miss-fn))
 	  #'(lambda (&rest args)
 	      (declare #.*optimize-speed*)
+	      #+copy-&rest-arg (setq args (copy-list args))
 	      (with-dfun-wrappers (args metatypes)
 		(dfun-wrappers invalid-wrapper-p)
 		(apply miss-fn args)
@@ -150,8 +152,10 @@
 			      emf
 			      (invoke-emf emf args))))))))
       #'(lambda (cache emf miss-fn)
+	  (declare (type function miss-fn))
 	  #'(lambda (&rest args)
 	      (declare #.*optimize-speed*)
+	      #+copy-&rest-arg (setq args (copy-list args))
 	      (with-dfun-wrappers (args metatypes)
 		(dfun-wrappers invalid-wrapper-p)
 		(apply miss-fn args)
@@ -171,5 +175,6 @@
   (declare (ignore metatypes applyp))
   (values #'(lambda (emf)
 	      #'(lambda (&rest args)
+		  #+copy-&rest-arg (setq args (copy-list args))
 		  (invoke-emf emf args)))
 	  t))
diff --git a/pcl/fixup.lisp b/pcl/fixup.lisp
index aecddc5b3..82c4d6974 100644
--- a/pcl/fixup.lisp
+++ b/pcl/fixup.lisp
@@ -25,7 +25,7 @@
 ;;; *************************************************************************
 ;;;
 
-(in-package 'pcl)
+(in-package :pcl)
 
 (fix-early-generic-functions)
 (setq *boot-state* 'complete)
diff --git a/pcl/fngen.lisp b/pcl/fngen.lisp
index e54dad9b3..61ae0ac66 100644
--- a/pcl/fngen.lisp
+++ b/pcl/fngen.lisp
@@ -25,7 +25,7 @@
 ;;; *************************************************************************
 ;;;
 
-(in-package 'pcl)
+(in-package :pcl)
 
 ;;;
 ;;; GET-FUNCTION is the main user interface to this code. It is like
diff --git a/pcl/fsc.lisp b/pcl/fsc.lisp
index 1a68a86d5..6d7f28a5c 100644
--- a/pcl/fsc.lisp
+++ b/pcl/fsc.lisp
@@ -38,7 +38,7 @@
 ;;; workings of this metaclass and the standard-class metaclass.
 ;;; 
 
-(in-package 'pcl)
+(in-package :pcl)
 
 (defmethod wrapper-fetcher ((class funcallable-standard-class))
   'fsc-instance-wrapper)
diff --git a/pcl/list-functions.lisp b/pcl/list-functions.lisp
index a272131a2..f4601a439 100644
--- a/pcl/list-functions.lisp
+++ b/pcl/list-functions.lisp
@@ -52,6 +52,8 @@
 	(*print-pretty* nil)
 	(s-a-n (find-package "SLOT-ACCESSOR-NAME"))
 	(lisp-sans (mapcar #'slot-reader-symbol '(function type))))
+    ;; This one has no predefined methods.
+    (defgeneric update-dependent (metaobject dependent &rest initargs))
     (map-all-generic-functions 
      #'(lambda (gf)
 	 (when (or all-p
diff --git a/pcl/precom1.lisp b/pcl/precom1.lisp
index 0f8e30f7a..0c550d95d 100644
--- a/pcl/precom1.lisp
+++ b/pcl/precom1.lisp
@@ -25,7 +25,7 @@
 ;;; *************************************************************************
 ;;;
 
-(in-package 'pcl)
+(in-package :pcl)
 
 ;;;
 ;;; pre-allocate generic function caches.  The hope is that this will put
diff --git a/pcl/precom2.lisp b/pcl/precom2.lisp
index 19d619273..97ab8f9eb 100644
--- a/pcl/precom2.lisp
+++ b/pcl/precom2.lisp
@@ -25,7 +25,7 @@
 ;;; *************************************************************************
 ;;;
 
-(in-package 'pcl)
+(in-package :pcl)
 
 (precompile-random-code-segments pcl)
 
diff --git a/pcl/std-class.lisp b/pcl/std-class.lisp
index f41dd8668..50e29e571 100644
--- a/pcl/std-class.lisp
+++ b/pcl/std-class.lisp
@@ -25,7 +25,7 @@
 ;;; *************************************************************************
 ;;;
 
-(in-package 'pcl)
+(in-package :pcl)
 
 (defmethod slot-accessor-function ((slotd effective-slot-definition) type)
   (ecase type
@@ -325,7 +325,7 @@
 						  ,(load-truename))
 			     other))
 
-(setf (symbol-function 'load-defclass) #'real-load-defclass)
+(setf (gdefinition 'load-defclass) #'real-load-defclass)
 
 (defun ensure-class (name &rest all)
   (apply #'ensure-class-using-class name (find-class name nil) all))
@@ -335,8 +335,7 @@
       (ensure-class-values class args)
     (inform-type-system-about-class (class-prototype meta) name);***
     (setf class (apply #'make-instance meta :name name initargs)
-	  (find-class name) class
-	  (find-class-predicate name) (symbol-function (class-predicate-name class)))
+	  (find-class name) class)
     (inform-type-system-about-class class name)	                ;***
     class))
 
@@ -345,9 +344,13 @@
       (ensure-class-values class args)
     (unless (eq (class-of class) meta) (change-class class meta))
     (apply #'reinitialize-instance class initargs)
+    (setf (find-class name) class)
     (inform-type-system-about-class class name)	                ;***
     class))
 
+(defmethod class-predicate-name ((class t))
+  'function-returning-nil)
+
 (defun ensure-class-values (class args)
   (let* ((initargs (copy-list args))
 	 (unsupplied (list 1))
@@ -629,7 +632,7 @@
     (update-slots class (compute-slots class))
     (update-gfs-of-class class)
     (update-inits class (compute-default-initargs class))
-    (update-constructors class))
+    (update-make-instance-function-table class))
   (unless finalizep
     (dolist (sub (class-direct-subclasses class)) (update-class sub nil))))
 
@@ -986,39 +989,6 @@
 ;;;
 (defmethod inform-type-system-about-class ((class std-class) name)
   (inform-type-system-about-std-class name))
-
-
-;;;
-;;; These 4 definitions appear here for bootstrapping reasons.  Logically,
-;;; they should be in the construct file.  For documentation purposes, a
-;;; copy of these definitions appears in the construct file.  If you change
-;;; one of the definitions here, be sure to change the copy there.
-;;; 
-(defvar *initialization-generic-functions*
-	(list #'make-instance
-	      #'default-initargs
-	      #'allocate-instance
-	      #'initialize-instance
-	      #'shared-initialize))
-
-(defmethod maybe-update-constructors
-	   ((generic-function generic-function)
-	    (method method))
-  (when (memq generic-function *initialization-generic-functions*)
-    (labels ((recurse (class)
-	       (update-constructors class)
-	       (dolist (subclass (class-direct-subclasses class))
-		 (recurse subclass))))
-      (when (classp (car (method-specializers method)))
-	(recurse (car (method-specializers method)))))))
-
-(defmethod update-constructors ((class slot-class))
-  (dolist (cons (class-constructors class))
-    (install-lazy-constructor-installer cons)))
-
-(defmethod update-constructors ((class class))
-  ())
-
 
 
 (defmethod compatible-meta-class-change-p (class proto-new-class)
diff --git a/pcl/sys-package.lisp b/pcl/sys-package.lisp
index 82af68aec..c04430e8c 100644
--- a/pcl/sys-package.lisp
+++ b/pcl/sys-package.lisp
@@ -41,8 +41,8 @@
          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::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
diff --git a/pcl/sysdef.lisp b/pcl/sysdef.lisp
index 3056e6e3c..9da68cd54 100644
--- a/pcl/sysdef.lisp
+++ b/pcl/sysdef.lisp
@@ -1,37 +1,6 @@
 ;;; -*- Mode: Lisp; Base: 10; Syntax: Common-Lisp; Package: DSYS -*-
 ;;; File: sysdef.lisp 
 ;;; Author: Richard Harris
-;;;
-;;;	ROSE - Rensselaer Object System for Engineering
-;;;	Common Lisp Implementation
-;;;
-;;; 			   Copyright (c) 1990 by 
-;;; 	      Rensselaer Polytechnic Institute, Troy, New York.
-;;; 			    All Rights Reserved
-;;;
-;;;	THE SOFTWARE AND ACCOMPANYING WRITTEN MATERIALS ARE PROVIDED
-;;;	\"AS IS\" AND WITHOUT ANY WARRANTY, INCLUDING BUT NOT LIMITED 
-;;;	TO THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
-;;;	A PARTICULAR PURPOSE.  THE ENTIRE RISK AS TO THE QUALITY AND
-;;;	PERFORMANCE OF THE SOFTWARE AND USE OF THE ACCOMPANYING WRITTEN
-;;;	MATERIALS IS ASSUMED BY YOU.  IN NO EVENT SHALL RENSSELAER 
-;;;	POLYTECHNIC INSTITUTE BE LIABLE FOR ANY LOST REVENUE, LOST 
-;;;	PROFITS OR OTHER INCIDENTAL OR CONSEQUENTIAL DAMAGES, EVEN
-;;;	IF ADVISED OF THE POSSIBILITIES OF SUCH DAMAGES, WHERE DAMAGES
-;;;	ARISE OUT OF OR IN CONNECTION WITH THE USE OF, PERFORMANCE OR
-;;;	NONPERFORMANCE OF THIS SOFTWARE.
-;;;
-;;;	This software and accompanying written materials may not be 
-;;;	distributed outside your organization or outside the United 
-;;;	States of America without express written authorization from
-;;;	Rensselaer Polytechnic Institute.
-;;;
-;;;	This work has been sponsored in part by Defense Advanced Research 
-;;;	Projects Agency (DARPA) under contract number MDA972-88-C0047 for
-;;; 	DARPA Initiative in Concurrent Engineering (DICE).  This material
-;;;	may be reproduced by or for the U.S. Government pursuant to the 
-;;;	copyright license under the clause at DFARS 252.227-7013 7/26/90.
-;;; 
 
 (in-package "DSYS")
 
@@ -125,11 +94,11 @@
 	     (pcl::compile-pcl))
 	   (reset-pcl-package)
 	   (maybe-load-pcl t)))
-     #+cmu (lisp::purify))
+     #+cmu (purify))
    :load
    (progn 
      (maybe-load-pcl)
-     #+cmu (lisp::purify))))
+     #+cmu (purify))))
 
 (defparameter *pcl-files*
   '((("systems") "lisp"
diff --git a/pcl/walk.lisp b/pcl/walk.lisp
index be759ab63..237612395 100644
--- a/pcl/walk.lisp
+++ b/pcl/walk.lisp
@@ -51,7 +51,7 @@
 ;;; mechanisms is in the first part of the file, the real walker follows it.
 ;;; 
 
-(in-package 'walker)
+(in-package :walker)
 
 ;;;
 ;;; The user entry points are walk-form and nested-walked-form.  In addition,
-- 
GitLab