From a1e3ed9362b3157f08369521f4326300f6f26390 Mon Sep 17 00:00:00 2001 From: gerd <gerd> Date: Sat, 22 Mar 2003 16:15:22 +0000 Subject: [PATCH] * bootfiles/18e/boot[12].lisp: Bootstrap files for the lisp:class = pcl:class part. To get it booted from 18e, cross-compile using boot1.lisp as bootstrap.lisp in pmai's build scripts, then do a normal compile with boot2.lisp as bootstrap.lisp with the resulting Lisp. * code/byte-interp.lisp, code/defstruct.lisp, code/describe.lisp: * code/error.lisp, code/exports.lisp, code/hash-new.lisp: * code/hash.lisp, code/macros.lisp, code/misc.lisp: * code/package.lisp, code/pred.lisp, code/sharpm.lisp, code/type.lisp: * compiler/dump.lisp, compiler/fndb.lisp, compiler/globaldb.lisp: * compiler/proclaim.lisp, compiler/typetran.lisp, compiler/xref.lisp: * compiler/generic/primtype.lisp, compiler/generic/vm-type.lisp: Changes for to use kernel::class etc. * code/class.lisp (toplevel): Shadow class, built-in-class etc. (class): Give it conc-name %class-. (toplevel) [#+bootstrap-lisp-class=pcl-class]: Define old accessors. (everywhere): Use new class accessors. * compiler/generic/vm-fndb.lisp (%make-instance): Change from unsafe to flushable and movable. * code/ntrace.lisp (expand-trace, untrace): Changes for method tracing. * code/profile.lisp (profile, profile-all, unprofile): Method profiling. * pcl/*.text, pcl/bench.lisp, pcl/extensions.lisp: * pcl/fast-init.lisp, pcl/precom1.lisp, pcl/precom4.lisp: * pcl/structure-class.lisp, pcl/user-instances.lisp: Removed. * tools/pclcom.lisp: Changes for my PCL and lisp:class = pcl::class. --- bootfiles/18e/boot1.lisp | 165 +++ bootfiles/18e/boot2.lisp | 20 + code/byte-interp.lisp | 6 +- code/class.lisp | 157 ++- code/defstruct.lisp | 49 +- code/describe.lisp | 8 +- code/error.lisp | 35 +- code/exports.lisp | 30 +- code/hash-new.lisp | 6 +- code/hash.lisp | 6 +- code/macros.lisp | 4 +- code/misc.lisp | 6 +- code/ntrace.lisp | 50 +- code/package.lisp | 4 +- code/pred.lisp | 10 +- code/profile.lisp | 122 +- code/sharpm.lisp | 13 +- code/type.lisp | 37 +- compiler/dump.lisp | 4 +- compiler/fndb.lisp | 10 +- compiler/generic/primtype.lisp | 8 +- compiler/generic/vm-fndb.lisp | 4 +- compiler/generic/vm-type.lisp | 6 +- compiler/globaldb.lisp | 6 +- compiler/ir1tran.lisp | 12 +- compiler/node.lisp | 4 +- compiler/proclaim.lisp | 12 +- compiler/typetran.lisp | 14 +- compiler/xref.lisp | 10 +- pcl/12-7-88-notes.text | 45 - pcl/3-17-88-notes.text | 167 --- pcl/3-19-87-notes.text | 138 -- pcl/4-21-87-notes.text | 53 - pcl/4-29-87-notes.text | 80 -- pcl/5-22-87-notes.text | 126 -- pcl/5-22-89-notes.text | 152 --- pcl/8-28-88-notes.text | 537 -------- pcl/bench.lisp | 458 ------- pcl/boot.lisp | 1287 ++++++++++-------- pcl/braid.lisp | 264 ++-- pcl/cache.lisp | 653 ++++++---- pcl/clos-bench.lisp | 731 +++++++++++ pcl/cmucl-documentation.lisp | 36 +- pcl/combin.lisp | 811 ++++++------ pcl/construct.lisp | 1064 --------------- pcl/cpl.lisp | 77 +- pcl/ctor.lisp | 772 +++++++++++ pcl/ctypes.lisp | 1 - pcl/defclass.lisp | 175 ++- pcl/defcombin.lisp | 228 ++-- pcl/defs.lisp | 515 ++++---- pcl/defsys.lisp | 92 +- pcl/dfun.lisp | 1087 +++++++++------- pcl/dlisp.lisp | 242 ++-- pcl/dlisp2.lisp | 60 +- pcl/dlisp3.lisp | 3 +- pcl/env.lisp | 192 +-- pcl/extensions.lisp | 495 ------- pcl/fast-init.lisp | 947 -------------- pcl/fin.lisp | 23 +- pcl/fixup.lisp | 9 +- pcl/fngen.lisp | 69 +- pcl/fsc.lisp | 28 +- pcl/generic-functions.lisp | 30 +- pcl/gf-call-optimization.lisp | 212 +++ pcl/gray-streams-class.lisp | 33 +- pcl/gray-streams.lisp | 6 +- pcl/herald.lisp | 8 + pcl/info.lisp | 702 ++++++++++ pcl/init.lisp | 251 ++-- pcl/lap.text | 655 ---------- pcl/low.lisp | 206 +-- pcl/macros.lisp | 169 ++- pcl/march-92-notes.text | 311 ----- pcl/may-day-notes.text | 98 -- pcl/method-slot-access-optimization.lisp | 779 +++++++++++ pcl/methods.lisp | 1051 +++++++-------- pcl/notes.text | 280 ---- pcl/pkg.lisp | 199 ++- pcl/precom1.lisp | 27 - pcl/precom4.lisp | 32 - pcl/rt/ctor.lisp | 412 ++++++ pcl/rt/defclass.lisp | 177 +++ pcl/rt/defgeneric.lisp | 62 + pcl/rt/defmethod.lisp | 76 ++ pcl/rt/find-method.lisp | 51 + pcl/rt/inline-access.lisp | 243 ++++ pcl/rt/make-instance.lisp | 391 ++++++ pcl/rt/method-combination.lisp | 217 ++++ pcl/rt/methods.lisp | 48 + pcl/rt/pkg.lisp | 53 + pcl/rt/pv.lisp | 136 ++ pcl/rt/reinitialize-instance.lisp | 89 ++ pcl/rt/slot-accessors.lisp | 131 ++ pcl/rt/slot-boundp.lisp | 75 ++ pcl/rt/slot-missing.lisp | 100 ++ pcl/rt/slot-type.lisp | 76 ++ pcl/rt/slot-value.lisp | 60 + pcl/rt/system.lisp | 91 ++ pcl/seal.lisp | 133 ++ pcl/slots-boot.lisp | 211 +-- pcl/slots.lisp | 183 +-- pcl/std-class.lisp | 507 +++++--- pcl/structure-class.lisp | 342 ----- pcl/user-instances.lisp | 688 ---------- pcl/vector.lisp | 1516 +++++++++------------- pcl/walk.lisp | 94 +- tools/pclcom.lisp | 23 +- 108 files changed, 11660 insertions(+), 12009 deletions(-) create mode 100644 bootfiles/18e/boot1.lisp create mode 100644 bootfiles/18e/boot2.lisp delete mode 100644 pcl/12-7-88-notes.text delete mode 100644 pcl/3-17-88-notes.text delete mode 100644 pcl/3-19-87-notes.text delete mode 100644 pcl/4-21-87-notes.text delete mode 100644 pcl/4-29-87-notes.text delete mode 100644 pcl/5-22-87-notes.text delete mode 100644 pcl/5-22-89-notes.text delete mode 100644 pcl/8-28-88-notes.text delete mode 100644 pcl/bench.lisp create mode 100644 pcl/clos-bench.lisp delete mode 100644 pcl/construct.lisp create mode 100644 pcl/ctor.lisp delete mode 100644 pcl/extensions.lisp delete mode 100644 pcl/fast-init.lisp create mode 100644 pcl/gf-call-optimization.lisp create mode 100644 pcl/herald.lisp create mode 100644 pcl/info.lisp delete mode 100644 pcl/lap.text delete mode 100644 pcl/march-92-notes.text delete mode 100644 pcl/may-day-notes.text create mode 100644 pcl/method-slot-access-optimization.lisp delete mode 100644 pcl/notes.text delete mode 100644 pcl/precom1.lisp delete mode 100644 pcl/precom4.lisp create mode 100644 pcl/rt/ctor.lisp create mode 100644 pcl/rt/defclass.lisp create mode 100644 pcl/rt/defgeneric.lisp create mode 100644 pcl/rt/defmethod.lisp create mode 100644 pcl/rt/find-method.lisp create mode 100644 pcl/rt/inline-access.lisp create mode 100644 pcl/rt/make-instance.lisp create mode 100644 pcl/rt/method-combination.lisp create mode 100644 pcl/rt/methods.lisp create mode 100644 pcl/rt/pkg.lisp create mode 100644 pcl/rt/pv.lisp create mode 100644 pcl/rt/reinitialize-instance.lisp create mode 100644 pcl/rt/slot-accessors.lisp create mode 100644 pcl/rt/slot-boundp.lisp create mode 100644 pcl/rt/slot-missing.lisp create mode 100644 pcl/rt/slot-type.lisp create mode 100644 pcl/rt/slot-value.lisp create mode 100644 pcl/rt/system.lisp create mode 100644 pcl/seal.lisp delete mode 100644 pcl/structure-class.lisp delete mode 100644 pcl/user-instances.lisp diff --git a/bootfiles/18e/boot1.lisp b/bootfiles/18e/boot1.lisp new file mode 100644 index 000000000..a6926d665 --- /dev/null +++ b/bootfiles/18e/boot1.lisp @@ -0,0 +1,165 @@ +;;; +;;; Bootstrap file 1 of 2 for moving LISP:CLASS and assorted functions +;;; and types to KERNEL, so that they are freed for use by PCL. +;;; +;;; Use this file as bootstrap.lisp, using Pierre Mai's build scripts, +;;; to cross-compile, resulting in a Lisp that is almost what we +;;; need to get to final result, except that it has still CLASS-NAME +;;; defined as a function, which needs to be corrected in a second +;;; build with the second bootstrap file of this series. +;;; + +(in-package "LISP") + +;;; +;;; Move the symbol whose name is NAME from LISP to KERNEL, and +;;; fix packages using that symbol. +;;; +(defun lisp-symbol->kernel (name) + (let ((sym (find-symbol name :lisp))) + (ext:collect ((pkgs)) + (dolist (p (list-all-packages)) + (when (eq (find-symbol name p) sym) + (pkgs p))) + (unexport sym :lisp) + (unintern sym :lisp) + (import sym :kernel) + (dolist (p (pkgs)) + (unless (eq (find-symbol name p) sym) + (import sym p)))))) + +;;; +;;; Move symbols we want to end up in KERNEL from LISP to KERNEL. +;;; +(defvar *symbols-to-move* + '("CLASS" + "BUILT-IN-CLASS" + "STANDARD-CLASS" + "STRUCTURE-CLASS" + "FIND-CLASS" + "CLASS-OF")) + +(mapc #'lisp-symbol->kernel *symbols-to-move*) + +;;; +;;; Redefine MAKE-PACKAGE because cross-compilation and build scripts +;;; rename some packages and make new ones. We want to make sure that +;;; the new packages contain the symbols we imported from KERNEL +;;; in LISP-SYMBOL->KERNEL into the old package. +;;; +(defun make-package (name &key (use *default-package-use-list*) nicknames + (internal-symbols 10) (external-symbols 10)) + "Makes a new package having the specified Name and Nicknames. The + package will inherit all external symbols from each package in + the use list. :Internal-Symbols and :External-Symbols are + estimates for the number of internal and external symbols which + will ultimately be present in the package." + (when (find-package name) + (cerror "Leave existing package alone." + "A package named ~S already exists" name)) + (let* ((name (package-namify name)) + (package (internal-make-package + :%name name + :internal-symbols (make-package-hashtable internal-symbols) + :external-symbols (make-package-hashtable external-symbols)))) + (if *in-package-init* + (push (list use package) *deferred-use-packages*) + (use-package use package)) + (enter-new-nicknames package nicknames) + (setf (gethash name *package-names*) package) + (let ((old-pkg (find-package (concatenate 'string "OLD-" name)))) + (when (and old-pkg + (find-symbol (car *symbols-to-move*) old-pkg)) + (dolist (sym *symbols-to-move*) + (import (find-symbol sym "KERNEL") package)))) + package)) + +(in-package :kernel) + +(export '(%class-layout %class-name %class-state + %class-direct-superclasses %class-subclasses %class-pcl-class)) + +;;; +;;; Like DEFSTRUCT, but silently clobber old definitions. +;;; +(defmacro defstruct! (name &rest stuff) + `(handler-bind ((error (lambda (c) + (declare (ignore c)) + (invoke-restart 'kernel::clobber-it)))) + (defstruct ,name ,@stuff))) + +;;; +;;; Redefine CLASS in the compiling Lisp. +;;; +(defstruct! (class + (:conc-name %class-) + (:make-load-form-fun class-make-load-form-fun) + (:print-function %print-class) + (:include ctype + (:class-info (type-class-or-lose 'class))) + (:pure nil)) + (name nil) + (layout nil :type (or layout null)) + (state nil :type (member nil :read-only :sealed)) + (direct-superclasses () :type list) + (subclasses nil :type (or hash-table null)) + (pcl-class nil)) + +;;; +;;; Provide old accessors so that the compiling Lisp continues +;;; to work. +;;; +(macrolet ((def (o n) + `(progn + (defun ,o (x) (,n x)) + (defun (setf ,o) (v x) (setf (,n x) v))))) + (def class-layout %class-layout) + (def class-name %class-name) + (def class-state %class-state) + (def class-direct-subclasses %class-direct-superclasses) + (def class-subclasses %class-subclasses)) + +;;; +;;; This build feature is checked in code:class.lisp, and makes it +;;; define the same accessors as above. +;;; +(pushnew :bootstrap-lisp-class=pcl-class *features*) + +;;; +;;; Redefine other affected structs. +;;; +(defstruct! (undefined-class + (:include class) + (:constructor make-undefined-class (name)))) + +(defstruct! (built-in-class (:include class)) + (translation nil :type (or ctype (member nil :initializing)))) + +(defstruct! (slot-class (:include class)) + (print-function nil :type (or function symbol null))) + +(defstruct! (basic-structure-class (:include slot-class))) + +(defstruct! (structure-class (:include basic-structure-class)) + (make-load-form-fun nil :type (or function symbol + (member :just-dump-it-normally + :ignore-it + nil))) + (constructor nil :type (or function null))) + +(defstruct! (funcallable-structure-class (:include basic-structure-class))) +(defstruct! (std-class (:include class))) +(defstruct! (standard-class (:include std-class))) +(defstruct! (random-pcl-class (:include std-class))) + +(in-package "CONDITIONS") + +(kernel::defstruct! (condition-class (:include slot-class)) + (slots nil :type list) + (class-slots nil :type list) + (report nil :type (or function null)) + (default-initargs () :type list) + (cpl () :type list) + (hairy-slots nil :type list)) + +;;; end of file diff --git a/bootfiles/18e/boot2.lisp b/bootfiles/18e/boot2.lisp new file mode 100644 index 000000000..8533352c7 --- /dev/null +++ b/bootfiles/18e/boot2.lisp @@ -0,0 +1,20 @@ +;;; +;;; Bootstrap file 2 of 2 for moving LISP:CLASS and assorted functions +;;; and types to KERNEL, so that they are freed for use by PCL. +;;; +;;; Use this file as bootstrap.lisp, using Pierre Mai's build scripts, +;;; to compile the final Lisp with the cross-compiled Lisp that resulted +;;; from using the first bootstrap file in this series. +;;; + +(in-package "USER") + +;;; +;;; Otherwise PCL barfs when it is built, because it defines generic +;;; functions with the same names. The functions are still there +;;; in the compiling Lisp for bootstrapping reasons. +;;; +(fmakunbound 'class-name) +(fmakunbound '(setf class-name)) + +;;; end of file diff --git a/code/byte-interp.lisp b/code/byte-interp.lisp index eb31b22d4..444543221 100644 --- a/code/byte-interp.lisp +++ b/code/byte-interp.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/byte-interp.lisp,v 1.35 2002/11/14 16:54:32 toy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/byte-interp.lisp,v 1.36 2003/03/22 16:15:22 gerd Exp $") ;;; ;;; ********************************************************************** ;;; @@ -915,8 +915,8 @@ (defun load-type-predicate (desc) (or (gethash desc *byte-type-predicates*) (let ((type (specifier-type desc))) - (if (typep type 'structure-class) - (let ((info (layout-info (class-layout type)))) + (if (typep type 'kernel::structure-class) + (let ((info (layout-info (%class-layout type)))) (if (and info (eq (dd-type info) 'structure)) (let ((pred (dd-predicate info))) (if (and pred (fboundp pred)) diff --git a/code/class.lisp b/code/class.lisp index 5aed16efa..a807c90e4 100644 --- a/code/class.lisp +++ b/code/class.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/class.lisp,v 1.51 2002/11/14 16:54:32 toy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/class.lisp,v 1.52 2003/03/22 16:15:22 gerd Exp $") ;;; ;;; ********************************************************************** ;;; @@ -17,31 +17,40 @@ (in-package "KERNEL") (export '(layout layout-hash layout-hash-length layout-hash-max - initialize-layout-hash layout-class layout-invalid - layout-inherits layout-inheritance-depth layout-length - layout-info layout-pure - layout-of structure-class-p - slot-class-print-function - structure-class-make-load-form-fun find-layout - class-proper-name class-layout class-state - class-direct-superclasses class-subclasses - class-pcl-class class-init register-layout - basic-structure-class slot-class funcallable-instance - funcallable-structure-class - make-funcallable-structure-class - funcallable-structure-class-p make-standard-class - random-pcl-class make-random-pcl-class - built-in-class-direct-superclasses - find-class-cell class-cell-name class-cell-class - make-layout make-undefined-class insured-find-class - redefine-layout-warning std-compute-class-precedence-list)) + initialize-layout-hash layout-class layout-invalid + layout-inherits layout-inheritance-depth layout-length + layout-info layout-pure + layout-of structure-class-p + slot-class-print-function + structure-class-make-load-form-fun find-layout + class-proper-name + class-init + register-layout + basic-structure-class slot-class funcallable-instance + funcallable-structure-class + make-funcallable-structure-class + funcallable-structure-class-p make-standard-class + random-pcl-class make-random-pcl-class + built-in-class-direct-superclasses + find-class-cell class-cell-name class-cell-class + make-layout make-undefined-class insured-find-class + redefine-layout-warning std-compute-class-precedence-list + + %class-name + %class-layout + %class-state + %class-direct-superclasses + %class-subclasses + %class-pcl-class)) (in-package "LISP") -(export '(class structure-class standard-class class-name find-class class-of - built-in-class)) +(export '(class-name)) (in-package "KERNEL") +(shadow '("CLASS" "BUILT-IN-CLASS" "STANDARD-CLASS" "STRUCTURE-CLASS" + "FIND-CLASS" "CLASS-OF")) + (with-cold-load-init-forms) ;;; Table mapping class names to layouts for classes we have referenced but not @@ -102,7 +111,7 @@ (hash7 0 :type index) ;; ;; The class this is a layout for. - (class (required-argument) :type class) + (class (required-argument) :type kernel::class) ;; ;; NIL if this is the latest layout for this class. If non-null, then the ;; class was changed after this instance was created. The exact value may @@ -227,11 +236,12 @@ ;;; CTYPE structure as recognized by the type system. ;;; (defstruct (class - (:make-load-form-fun class-make-load-form-fun) - (:print-function %print-class) - (:include ctype - (:class-info (type-class-or-lose 'class))) - (:pure nil)) + (:conc-name %class-) + (:make-load-form-fun class-make-load-form-fun) + (:print-function %print-class) + (:include ctype + (:class-info (type-class-or-lose 'class))) + (:pure nil)) ;; ;; Optional name, for printing. (name nil) @@ -255,9 +265,26 @@ ;; ;; The PCL class object, or NIL if none assigned yet. (pcl-class nil)) + +;;; +;;; Remove this whole stuff once everyone has bootstrapped the +;;; LISP:CLASS = PCL:CLASS stuff, that is, when the bootstrap file +;;; using this feature is no longer needed. +;;; +#+bootstrap-lisp-class=pcl-class +(macrolet ((def (o n) + `(progn + (defun ,o (x) (,n x)) + (defun (setf ,o) (v x) (setf (,n x) v))))) + (def class-layout %class-layout) + (def class-name %class-name) + (def class-state %class-state) + (def class-direct-subclasses %class-direct-superclasses) + (def class-subclasses %class-subclasses)) + ;;; (defun class-make-load-form-fun (class) - (let ((name (class-name class))) + (let ((name (%class-name class))) (unless (and name (eq (find-class name nil) class)) (error "Can't use anonymous or undefined class as constant:~% ~S" @@ -268,7 +295,7 @@ (declare (ignore d)) (print-unreadable-object (s stream :identity t :type t) (format stream "~:[<anonymous>~;~:*~S~]~@[ (~(~A~))~]" - (class-name s) (class-state s)))) + (%class-name s) (%class-state s)))) ;;; The UNDEFINED-CLASS is a cookie we make up to stick in forward referenced @@ -392,7 +419,7 @@ (new (class-of new-value))) (unless (eq old new) (warn "Changing meta-class of ~S from ~S to ~S." - name (class-name old) (class-name new))))) + name (%class-name old) (%class-name new))))) (:primitive (error "Illegal to redefine standard type ~S." name)) (:defined @@ -405,8 +432,8 @@ (setf (info type kind name) :instance) (setf (class-cell-class (find-class-cell name)) new-value) (unless (eq (info type compiler-layout name) - (class-layout new-value)) - (setf (info type compiler-layout name) (class-layout new-value))))) + (%class-layout new-value)) + (setf (info type compiler-layout name) (%class-layout new-value))))) new-value) @@ -423,7 +450,7 @@ old (funcall constructor :name name))) (found (or (gethash name *forward-referenced-layouts*) - (when old (class-layout old))))) + (when old (%class-layout old))))) (when found (setf (layout-class found) res)) @@ -437,7 +464,7 @@ ;;; (defun class-proper-name (class) (declare (type class class)) - (let ((name (class-name class))) + (let ((name (%class-name class))) (if (and name (eq (find-class name nil) class)) name class))) @@ -456,7 +483,7 @@ (define-type-method (class :simple-subtypep) (class1 class2) (assert (not (eq class1 class2))) - (let ((subclasses (class-subclasses class2))) + (let ((subclasses (%class-subclasses class2))) (if (and subclasses (gethash class1 subclasses)) (values t t) (values nil t)))) @@ -470,8 +497,8 @@ ;;; (defun sealed-class-intersection (sealed other) (declare (type class sealed other)) - (let ((s-sub (class-subclasses sealed)) - (o-sub (class-subclasses other))) + (let ((s-sub (%class-subclasses sealed)) + (o-sub (%class-subclasses other))) (if (and s-sub o-sub) (collect ((res *empty-type* type-union)) (do-hash (subclass layout s-sub) @@ -490,18 +517,18 @@ (define-type-method (class :simple-intersection) (class1 class2) (declare (type class class1 class2)) (cond ((eq class1 class2) class1) - ((let ((subclasses (class-subclasses class2))) + ((let ((subclasses (%class-subclasses class2))) (and subclasses (gethash class1 subclasses))) (values class1 t)) - ((let ((subclasses (class-subclasses class1))) + ((let ((subclasses (%class-subclasses class1))) (and subclasses (gethash class2 subclasses))) (values class2 t)) ((or (basic-structure-class-p class1) (basic-structure-class-p class2)) (values *empty-type* t)) - ((eq (class-state class1) :sealed) + ((eq (%class-state class1) :sealed) (sealed-class-intersection class1 class2)) - ((eq (class-state class2) :sealed) + ((eq (%class-state class2) :sealed) (sealed-class-intersection class2 class1)) (t (values class1 nil)))) @@ -854,7 +881,7 @@ (inherit-layouts (map 'vector #'(lambda (x) - (let ((super-layout (class-layout (find-class x)))) + (let ((super-layout (%class-layout (find-class x)))) (when (= (layout-inheritance-depth super-layout) -1) (setf inheritance-depth -1)) super-layout)) @@ -877,7 +904,7 @@ (setf (info type kind name) :instance) (let ((inherit-layouts (map 'vector #'(lambda (x) - (class-layout (lisp:find-class x))) + (%class-layout (find-class x))) inherits))) (register-layout (find-layout name 0 inherit-layouts -1) :invalidate nil))))) @@ -888,7 +915,7 @@ (cold-load-init (dolist (x built-in-classes) (destructuring-bind (name &key (state :sealed) &allow-other-keys) x - (setf (class-state (find-class name)) state)))) + (setf (%class-state (find-class name)) state)))) ;;; A vector that maps type codes to layouts, used for quickly finding the @@ -898,11 +925,11 @@ (cold-load-init (setq built-in-class-codes (let ((res (make-array 256 :initial-element - '#.(class-layout (find-class 'random-class))))) + '#.(%class-layout (find-class 'random-class))))) (dolist (x built-in-classes res) (destructuring-bind (name &key codes &allow-other-keys) x - (let ((layout (class-layout (find-class name)))) + (let ((layout (%class-layout (find-class name)))) (dolist (code codes) (setf (svref res code) layout)))))))) @@ -921,7 +948,7 @@ (declare (optimize (speed 3) (safety 0))) (cond ((%instancep x) (%instance-layout x)) ((funcallable-instance-p x) (%funcallable-instance-layout x)) - ((null x) '#.(class-layout (find-class 'null))) + ((null x) '#.(%class-layout (find-class 'null))) (t (svref built-in-class-codes (get-type x))))) @@ -943,10 +970,10 @@ ;;; (defun modify-class (class) (clear-type-caches) - (when (member (class-state class) '(:read-only :frozen)) + (when (member (%class-state class) '(:read-only :frozen)) (warn "Modifing ~(~A~) class ~S; making it writable." - (class-state class) (class-name class)) - (setf (class-state class) nil))) + (%class-state class) (%class-name class)) + (setf (%class-state class) nil))) ;;; INVALIDATE-LAYOUT -- Internal @@ -964,7 +991,7 @@ (modify-class class) (dotimes (i (length inherits)) (let* ((super (svref inherits i)) - (subs (class-subclasses (layout-class super)))) + (subs (%class-subclasses (layout-class super)))) (when subs (remhash class subs))))) (undefined-value)) @@ -985,8 +1012,8 @@ (defun register-layout (layout &key (invalidate t) destruct-layout) (declare (type layout layout) (type (or layout null) destruct-layout)) (let* ((class (layout-class layout)) - (class-layout (class-layout class)) - (subclasses (class-subclasses class))) + (class-layout (%class-layout class)) + (subclasses (%class-subclasses class))) (assert (not (eq class-layout layout))) (when class-layout (modify-class class) @@ -996,7 +1023,7 @@ (when invalidate (invalidate-layout l)))) (when invalidate (invalidate-layout class-layout) - (setf (class-subclasses class) nil))) + (setf (%class-subclasses class) nil))) (cond (destruct-layout (setf (layout-invalid destruct-layout) nil) @@ -1005,22 +1032,22 @@ (layout-inheritance-depth layout)) (setf (layout-length destruct-layout) (layout-length layout)) (setf (layout-info destruct-layout) (layout-info layout)) - (setf (class-layout class) destruct-layout)) + (setf (%class-layout class) destruct-layout)) (t (setf (layout-invalid layout) nil) - (setf (class-layout class) layout))) + (setf (%class-layout class) layout))) (let ((inherits (layout-inherits layout))) (dotimes (i (length inherits)) (let* ((super (layout-class (svref inherits i))) - (subclasses (or (class-subclasses super) - (setf (class-subclasses super) + (subclasses (or (%class-subclasses super) + (setf (%class-subclasses super) (make-hash-table :test #'eq))))) - (when (and (eq (class-state super) :sealed) + (when (and (eq (%class-state super) :sealed) (not (gethash class subclasses))) (warn "Subclassing sealed class ~S; unsealing it." - (class-name super)) - (setf (class-state super) :read-only)) + (%class-name super)) + (setf (%class-state super) :read-only)) (setf (gethash class subclasses) (or destruct-layout layout)))))) @@ -1100,7 +1127,7 @@ (type (or index (integer -1 -1)) depth)) (let* ((class (or (find-class name nil) (make-undefined-class name))) - (old (or (class-layout class) + (old (or (%class-layout class) (gethash name *forward-referenced-layouts*))) (res (make-layout :class class :invalid :undefined @@ -1206,7 +1233,7 @@ (labels ((note-class (class) (unless (member class classes) (push class classes) - (let ((superclasses (class-direct-superclasses class))) + (let ((superclasses (%class-direct-superclasses class))) (do ((prev class) (rest superclasses (rest rest))) ((endp rest)) @@ -1217,7 +1244,7 @@ (note-class class))))) (std-cpl-tie-breaker (free-classes rev-cpl) (dolist (class rev-cpl (first free-classes)) - (let* ((superclasses (class-direct-superclasses class)) + (let* ((superclasses (%class-direct-superclasses class)) (intersection (intersection free-classes superclasses))) (when intersection @@ -1243,7 +1270,7 @@ (let ((class (find-class name nil))) (cond ((not class) (setf (layout-class layout) (make-undefined-class name))) - ((eq (class-layout class) layout) + ((eq (%class-layout class) layout) (remhash name *forward-referenced-layouts*)) (t (warn "Something strange with forward layout for ~S:~% ~S" diff --git a/code/defstruct.lisp b/code/defstruct.lisp index df8ab468a..e138ec86a 100644 --- a/code/defstruct.lisp +++ b/code/defstruct.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/defstruct.lisp,v 1.81 2003/02/01 20:42:29 gerd Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/defstruct.lisp,v 1.82 2003/03/22 16:15:22 gerd Exp $") ;;; ;;; ********************************************************************** ;;; @@ -377,10 +377,10 @@ `#',mlff))))) ,@(let ((pure (dd-pure defstruct))) (cond ((eq pure 't) - `((setf (layout-pure (class-layout (find-class ',name))) + `((setf (layout-pure (%class-layout (find-class ',name))) t))) ((eq pure :substructure) - `((setf (layout-pure (class-layout (find-class ',name))) + `((setf (layout-pure (%class-layout (find-class ',name))) 0))))) ,@(let ((def-con (dd-default-constructor defstruct))) (when (and def-con (not (dd-alternate-metaclass defstruct))) @@ -405,10 +405,10 @@ `#',mlff))))) ,@(let ((pure (dd-pure defstruct))) (cond ((eq pure 't) - `((setf (layout-pure (class-layout (find-class ',name))) + `((setf (layout-pure (%class-layout (find-class ',name))) t))) ((eq pure :substructure) - `((setf (layout-pure (class-layout (find-class ',name))) + `((setf (layout-pure (%class-layout (find-class ',name))) 0))))) ,@(let ((def-con (dd-default-constructor defstruct))) (when (and def-con (not (dd-alternate-metaclass defstruct))) @@ -1340,7 +1340,7 @@ :expected-type class :format-control "Structure for accessor ~S is not a ~S:~% ~S" :format-arguments (list (dsd-accessor dsd) - (class-name class) + (%class-name class) structure))) (%instance-ref structure (dsd-index dsd))) #'(lambda (structure) @@ -1365,7 +1365,7 @@ :expected-type class :format-control "Structure for setter ~S is not a ~S:~% ~S" :format-arguments (list `(setf ,(dsd-accessor dsd)) - (class-name class) + (%class-name class) structure))) (unless (%typep new-value (dsd-type dsd)) (error 'simple-type-error @@ -1384,7 +1384,7 @@ :expected-type class :format-control "Structure for setter ~S is not a ~S:~% ~S" :format-arguments (list `(setf ,(dsd-accessor dsd)) - (class-name class) + (%class-name class) structure))) (unless (%typep new-value (dsd-type dsd)) (error 'simple-type-error @@ -1409,7 +1409,7 @@ (multiple-value-bind (class layout old-layout) (ensure-structure-class info inherits "current" "new") (cond ((not old-layout) - (unless (eq (class-layout class) layout) + (unless (eq (%class-layout class) layout) (register-layout layout))) (t (let ((old-info (layout-info old-layout))) @@ -1421,7 +1421,7 @@ (unless (dsd-read-only slot) (fmakunbound `(setf ,aname)))))))) (%redefine-defstruct class old-layout layout) - (setq layout (class-layout class)))) + (setq layout (%class-layout class)))) (setf (find-class (dd-name info)) class) @@ -1487,16 +1487,16 @@ &optional compiler-layout) (multiple-value-bind (class old-layout) - (destructuring-bind (&optional name (class 'structure-class) + (destructuring-bind (&optional name (class 'kernel::structure-class) (constructor 'make-structure-class)) (dd-alternate-metaclass info) (declare (ignore name)) (insured-find-class (dd-name info) - (if (eq class 'structure-class) - #'(lambda (x) (typep x 'structure-class)) + (if (eq class 'kernel::structure-class) + #'(lambda (x) (typep x 'kernel::structure-class)) #'(lambda (x) (typep x (find-class class)))) (fdefinition constructor))) - (setf (class-direct-superclasses class) + (setf (%class-direct-superclasses class) (if (eq (dd-name info) 'lisp-stream) ;; Hack to add stream as a superclass mixin to lisp-streams. (list (layout-class (svref inherits (1- (length inherits)))) @@ -1569,7 +1569,8 @@ ;;; different slots than in the currently loaded version. ;;; (defun redefine-structure-warning (class old new) - (declare (type defstruct-description old new) (type class class) + (declare (type defstruct-description old new) + (type kernel::class class) (ignore class)) (let ((name (dd-name new))) (multiple-value-bind (moved retyped deleted) @@ -1619,7 +1620,7 @@ ;;; type info, and undefining all the associated functions. ;;; (defun undefine-structure (class) - (let ((info (layout-info (class-layout class)))) + (let ((info (layout-info (%class-layout class)))) (when (defstruct-description-p info) (let ((type (dd-name info))) (setf (info type compiler-layout type) nil) @@ -1680,12 +1681,12 @@ (super (if include (compiler-layout-or-lose (first include)) - (class-layout (find-class (or (first superclass-opt) + (%class-layout (find-class (or (first superclass-opt) 'structure-object)))))) (if (eq (dd-name info) 'lisp-stream) ;; Hack to added the stream class as a mixin for lisp-streams. (concatenate 'simple-vector (layout-inherits super) - (vector super (class-layout (find-class 'stream)))) + (vector super (%class-layout (find-class 'stream)))) (concatenate 'simple-vector (layout-inherits super) (vector super))))) ;;; %COMPILER-ONLY-DEFSTRUCT -- Internal @@ -1713,18 +1714,18 @@ (cond (old-layout (undefine-structure (layout-class old-layout)) - (when (and (class-subclasses class) + (when (and (%class-subclasses class) (not (eq layout old-layout))) (collect ((subs)) - (do-hash (class layout (class-subclasses class)) + (do-hash (class layout (%class-subclasses class)) (declare (ignore layout)) (undefine-structure class) (subs (class-proper-name class))) (when (subs) (warn "Removing old subclasses of ~S:~% ~S" - (class-name class) (subs)))))) + (%class-name class) (subs)))))) (t - (unless (eq (class-layout class) layout) + (unless (eq (%class-layout class) layout) (register-layout layout :invalidate nil)) (setf (find-class (dd-name info)) class))) @@ -1836,7 +1837,7 @@ (print-unreadable-object (structure stream :identity t :type t) (write-string "Funcallable Structure" stream)) (let* ((type (%instance-layout structure)) - (name (class-name (layout-class type))) + (name (%class-name (layout-class type))) (dd (layout-info type))) (if *print-pretty* (pprint-logical-block (stream nil :prefix "#S(" :suffix ")") @@ -1889,7 +1890,7 @@ fun) (null (error "Structures of type ~S cannot be dumped as constants." - (class-name class))) + (%class-name class))) (function (funcall fun structure)) (symbol diff --git a/code/describe.lisp b/code/describe.lisp index c368598c9..f045c72bd 100644 --- a/code/describe.lisp +++ b/code/describe.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/describe.lisp,v 1.40 2003/02/06 15:20:13 gerd Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/describe.lisp,v 1.41 2003/03/22 16:15:22 gerd Exp $") ;;; ;;; ********************************************************************** ;;; @@ -137,7 +137,7 @@ (format t "~&~S is a ~S." x (type-of x))) (defun describe-instance (x &optional (kind :structure)) - (cond ((let ((so-class (find-class 'pcl::std-object nil))) + (cond ((let ((so-class (kernel::find-class 'pcl::std-object nil))) (and so-class (typep x so-class))) (fresh-line *standard-output*) (describe-object x *standard-output*)) @@ -430,11 +430,11 @@ (format t "~&Documentation on the ~(~A~):~%~A" (car assoc) (cdr assoc))) ;; ;; Print Class information - (let ((class (find-class x nil))) + (let ((class (kernel::find-class x nil))) (when class (format t "~&It names a class ~A." class) (describe class) - (let ((pcl-class (class-pcl-class class))) + (let ((pcl-class (%class-pcl-class class))) (when pcl-class (format t "~&It names a PCL class ~A." pcl-class) (describe pcl-class))))) diff --git a/code/error.lisp b/code/error.lisp index 5e6ae303d..f491815bd 100644 --- a/code/error.lisp +++ b/code/error.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/error.lisp,v 1.65 2003/02/15 23:41:30 pmai Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/error.lisp,v 1.66 2003/03/22 16:15:21 gerd Exp $") ;;; ;;; ********************************************************************** ;;; @@ -21,8 +21,7 @@ (in-package "KERNEL") (export '(layout-invalid condition-function-name simple-control-error simple-file-error simple-program-error simple-parse-error - simple-style-warning - simple-undefined-function)) + simple-style-warning simple-undefined-function)) (in-package "LISP") (export '(break error warn cerror @@ -402,10 +401,10 @@ (cell nil :type (or cons null))) (eval-when (compile load eval) - (setf (condition-class-cpl (find-class 'condition)) - (list (find-class 'condition)))) + (setf (condition-class-cpl (kernel::find-class 'condition)) + (list (kernel::find-class 'condition)))) -(setf (condition-class-report (find-class 'condition)) +(setf (condition-class-report (kernel::find-class 'condition)) #'(lambda (cond stream) (format stream "Condition ~S was signalled." (type-of cond)))) @@ -417,14 +416,14 @@ (reduce #'append (mapcar #'(lambda (x) (condition-class-cpl - (find-class x))) + (kernel::find-class x))) parent-types))))) (cond-layout (info type compiler-layout 'condition)) (olayout (info type compiler-layout name)) (new-inherits (order-layout-inherits (concatenate 'simple-vector (layout-inherits cond-layout) - (mapcar #'class-layout cpl))))) + (mapcar #'%class-layout cpl))))) (if (and olayout (not (mismatch (layout-inherits olayout) new-inherits))) olayout @@ -447,7 +446,7 @@ (defun real-print-condition (s stream) (if *print-escape* (print-unreadable-object (s stream :identity t :type t)) - (dolist (class (condition-class-cpl (class-of s)) + (dolist (class (condition-class-cpl (kernel::class-of s)) (error "No REPORT? Shouldn't happen!")) (let ((report (condition-class-report class))) (when report @@ -523,7 +522,7 @@ ;; Note: ANSI specifies no exceptional situations in this function. ;; signalling simple-type-error would not be wrong. (let* ((thing (if (symbolp thing) - (find-class thing) + (kernel::find-class thing) thing)) (class (typecase thing (condition-class thing) @@ -540,7 +539,7 @@ :format-control "Bad thing for class arg:~% ~S" :format-arguments (list thing))))) (res (make-condition-object args))) - (setf (%instance-layout res) (class-layout class)) + (setf (%instance-layout res) (%class-layout class)) ;; ;; Set any class slots with initargs present in this call. (dolist (cslot (condition-class-class-slots class)) @@ -568,25 +567,25 @@ (insured-find-class name #'condition-class-p #'make-condition-class) (setf (layout-class layout) class) - (setf (class-direct-superclasses class) - (mapcar #'find-class direct-supers)) + (setf (%class-direct-superclasses class) + (mapcar #'kernel::find-class direct-supers)) (cond ((not old-layout) (register-layout layout)) ((not *type-system-initialized*) (setf (layout-class old-layout) class) (setq layout old-layout) - (unless (eq (class-layout class) layout) + (unless (eq (%class-layout class) layout) (register-layout layout))) ((redefine-layout-warning old-layout "current" layout "new") (register-layout layout :invalidate t)) - ((not (class-layout class)) + ((not (%class-layout class)) (register-layout layout))) (setf (layout-info layout) - (layout-info (class-layout (find-class 'condition)))) + (layout-info (%class-layout (kernel::find-class 'condition)))) - (setf (find-class name) class) + (setf (kernel::find-class name) class) ;; ;; Initialize CPL slot. (setf (condition-class-cpl class) @@ -626,7 +625,7 @@ (defun %define-condition (name slots documentation report default-initargs) - (let ((class (find-class name))) + (let ((class (kernel::find-class name))) (setf (slot-class-print-function class) #'%print-condition) (setf (condition-class-slots class) slots) (setf (condition-class-report class) report) diff --git a/code/exports.lisp b/code/exports.lisp index 2bdef5aa7..d005b2629 100644 --- a/code/exports.lisp +++ b/code/exports.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/exports.lisp,v 1.202 2003/03/21 23:43:35 pmai Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/exports.lisp,v 1.203 2003/03/22 16:15:21 gerd Exp $") ;;; ;;; ********************************************************************** ;;; @@ -17,7 +17,6 @@ (if (find-package "PCL") (rename-package "PCL" "PCL" 'nil) (make-package "PCL" :nicknames 'nil :use nil)) -(shadow 'class "PCL") (if (find-package "C-CALL") (rename-package "C-CALL" "C-CALL" 'nil) @@ -314,7 +313,13 @@ (defpackage "FORMAT") (defpackage "COMMON-LISP" (:nicknames "CL" "LISP") - (:export "&ALLOW-OTHER-KEYS" "&AUX" "&BODY" "&ENVIRONMENT" "&KEY" + (:shadow "CLASS" "BUILT-IN-CLASS" "STANDARD-CLASS" + "STRUCTURE-CLASS" "CLASS-OF" "FIND-CLASS") + (:export + "CLASS" "BUILT-IN-CLASS" "STANDARD-CLASS" + "STRUCTURE-CLASS" "CLASS-OF" "FIND-CLASS" + + "&ALLOW-OTHER-KEYS" "&AUX" "&BODY" "&ENVIRONMENT" "&KEY" "&OPTIONAL" "&REST" "&WHOLE" "*" "**" "***" "*BREAK-ON-SIGNALS*" "*COMPILE-FILE-PATHNAME*" "*COMPILE-FILE-TRUENAME*" @@ -352,7 +357,7 @@ "BOOLE-C1" "BOOLE-C2" "BOOLE-CLR" "BOOLE-EQV" "BOOLE-IOR" "BOOLE-NAND" "BOOLE-NOR" "BOOLE-ORC1" "BOOLE-ORC2" "BOOLE-SET" "BOOLE-XOR" "BOTH-CASE-P" "BOUNDP" "BREAK" - "BROADCAST-STREAM" "BROADCAST-STREAM-STREAMS" "BUILT-IN-CLASS" + "BROADCAST-STREAM" "BROADCAST-STREAM-STREAMS" "BUTLAST" "BYTE" "BYTE-POSITION" "BYTE-SIZE" "CAAAAR" "CAAADR" "CAAAR" "CAADAR" "CAADDR" "CAADR" "CAAR" "CADAAR" "CADADR" "CADAR" "CADDAR" "CADDDR" "CADDR" "CADR" @@ -365,7 +370,7 @@ "CHAR-NAME" "CHAR-NOT-EQUAL" "CHAR-NOT-GREATERP" "CHAR-NOT-LESSP" "CHAR-UPCASE" "CHAR/=" "CHAR<" "CHAR<=" "CHAR=" "CHAR>" "CHAR>=" "CHARACTER" - "CHARACTERP" "CHECK-TYPE" "CIS" "CLASS" "CLASS-OF" "CLASS-NAME" + "CHARACTERP" "CHECK-TYPE" "CIS" "CLASS-NAME" "CLEAR-INPUT" "CLEAR-OUTPUT" "CLOSE" "CLRHASH" "CODE-CHAR" "COERCE" "COMPILATION-SPEED" "COMPILE" "COMPILE-FILE" @@ -407,7 +412,7 @@ "FILE-ERROR-PATHNAME" "FILE-LENGTH" "FILE-NAMESTRING" "FILE-POSITION" "FILE-STREAM" "FILE-STRING-LENGTH" "FILE-WRITE-DATE" "FILL" "FILL-POINTER" "FIND" - "FIND-ALL-SYMBOLS" "FIND-CLASS" + "FIND-ALL-SYMBOLS" "FIND-IF" "FIND-IF-NOT" "FIND-PACKAGE" "FIND-RESTART" "FIND-SYMBOL" "FINISH-OUTPUT" "FIRST" "FIXNUM" "FLET" "FLOAT" "FLOAT-DIGITS" "FLOAT-PRECISION" "FLOAT-RADIX" @@ -541,7 +546,7 @@ "STRING-RIGHT-TRIM" "STRING-STREAM" "STRING-TRIM" "STRING-UPCASE" "STRING/=" "STRING<" "STRING<=" "STRING=" "STRING>" "STRING>=" "STRINGP" - "STRUCTURE" "STRUCTURE-CLASS" "STRUCTURE-OBJECT" + "STRUCTURE" "STRUCTURE-OBJECT" "SUBLIS" "SUBSEQ" "SUBSETP" "SUBST" "SUBST-IF" "SUBST-IF-NOT" "SUBSTITUTE" "SUBSTITUTE-IF" "SUBSTITUTE-IF-NOT" "SUBTYPEP" "SVREF" "SXHASH" "SYMBOL" @@ -583,7 +588,7 @@ "NO-APPLICABLE-METHOD" "NO-NEXT-METHOD" "PRINT-OBJECT" "REINITIALIZE-INSTANCE" "REMOVE-METHOD" "SHARED-INITIALIZE" "SLOT-BOUNDP" "SLOT-EXISTS-P" "SLOT-MAKUNBOUND" "SLOT-MISSING" - "SLOT-UNBOUND" "SLOT-VALUE" "STANDARD" "STANDARD-CLASS" + "SLOT-UNBOUND" "SLOT-VALUE" "STANDARD" "STANDARD-GENERIC-FUNCTION" "STANDARD-METHOD" "STANDARD-OBJECT" "UPDATE-INSTANCE-FOR-DIFFERENT-CLASS" "UPDATE-INSTANCE-FOR-REDEFINED-CLASS" "WITH-ACCESSORS" "WITH-SLOTS" @@ -644,6 +649,8 @@ "READ-ONLY-SPACE-START" "SHORT-FLOAT-P" "STATIC-SPACE-START" "STRING/=*" "STRING<*" "STRING<=*" "STRING=*" "STRING>*" "STRING>=*") + (:shadowing-import-from "KERNEL" "CLASS" "BUILT-IN-CLASS" "STANDARD-CLASS" + "STRUCTURE-CLASS" "FIND-CLASS" "CLASS-OF") (:export "*ASSEMBLY-UNIT-LENGTH*" "*PRIMITIVE-OBJECTS*" "AFTER-BREAKPOINT-TRAP" "ANY-REG-SC-NUMBER" "ARRAY-DATA-SLOT" "ARRAY-DIMENSIONS-OFFSET" @@ -1135,6 +1142,8 @@ "STRING>*" "STRING>=*") (:import-from "SYSTEM" "FOREIGN-SYMBOL-ADDRESS" "FOREIGN-SYMBOL-CODE-ADDRESS" "FOREIGN-SYMBOL-DATA-ADDRESS") + (:shadowing-import-from "KERNEL" "CLASS" "BUILT-IN-CLASS" "STANDARD-CLASS" + "STRUCTURE-CLASS" "FIND-CLASS" "CLASS-OF") (:export "%ALIEN-FUNCALL" "%CATCH-BREAKUP" "%CONTINUE-UNWIND" "&MORE" "%LISTIFY-REST-ARGS" "%MORE-ARG" "%MORE-ARG-VALUES" "%UNWIND-PROTECT-BREAKUP" @@ -1495,10 +1504,13 @@ "PATHNAME-NAME" "PATHNAME-TYPE" "PATHNAME-VERSION")) (intern name "LISP")) (intern "VOID" "C-CALL") + (defpackage "KERNEL" (:import-from "LISP" "BOOLEAN") (:import-from "C-CALL" "VOID") - (:export "*ANSI-DEFSTRUCT-OPTIONS-P*" + (:export "%CLASS-LAYOUT" "%CLASS-STATE" "%CLASS-DIRECT-SUPERCLASSES" + "%CLASS-SUBCLASSES" "%CLASS-PCL-CLASS" + "*ANSI-DEFSTRUCT-OPTIONS-P*" "%ACOS" "%ACOSH" "%ARRAY-AVAILABLE-ELEMENTS" "%ARRAY-DATA-VECTOR" "%ARRAY-DIMENSION" "%ARRAY-DISPLACED-P" "%ARRAY-DISPLACEMENT" "%ARRAY-FILL-POINTER" diff --git a/code/hash-new.lisp b/code/hash-new.lisp index c0cf77dff..c3cfbd8ae 100644 --- a/code/hash-new.lisp +++ b/code/hash-new.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/hash-new.lisp,v 1.21 2003/03/10 21:09:11 gerd Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/hash-new.lisp,v 1.22 2003/03/22 16:15:21 gerd Exp $") ;;; ;;; ********************************************************************** ;;; @@ -911,7 +911,7 @@ (character (char-code (char-upcase s-expr))) (instance (if (typep s-expr 'structure-object) - (internal-sxhash (class-name (layout-class (%instance-layout s-expr))) + (internal-sxhash (%class-name (layout-class (%instance-layout s-expr))) depth) (sxhash-instance s-expr))) (funcallable-instance (sxhash-instance s-expr)) @@ -978,7 +978,7 @@ 0 (let* ((layout (%instance-layout ,structure)) (length (min (1- (layout-length layout)) sxhash-max-len)) - (hash (internal-sxhash (class-name (layout-class layout)) + (hash (internal-sxhash (%class-name (layout-class layout)) depth)) (,depth (+ ,depth 1))) (declare (type index length) (type hash hash)) diff --git a/code/hash.lisp b/code/hash.lisp index cfdd6d732..fac684372 100644 --- a/code/hash.lisp +++ b/code/hash.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/hash.lisp,v 1.41 2002/11/28 00:51:34 pmai Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/hash.lisp,v 1.42 2003/03/22 16:15:21 gerd Exp $") ;;; ;;; ********************************************************************** ;;; @@ -872,7 +872,7 @@ (character (char-code (char-upcase s-expr))) (instance (if (typep s-expr 'structure-object) - (internal-sxhash (class-name (layout-class (%instance-layout s-expr))) + (internal-sxhash (%class-name (layout-class (%instance-layout s-expr))) depth) (sxhash-instance s-expr))) (funcallable-instance (sxhash-instance s-expr)) @@ -939,7 +939,7 @@ 0 (let* ((layout (%instance-layout ,structure)) (length (min (1- (layout-length layout)) sxhash-max-len)) - (hash (internal-sxhash (class-name (layout-class layout)) + (hash (internal-sxhash (%class-name (layout-class layout)) depth)) (,depth (+ ,depth 1))) (declare (type index length) (type hash hash)) diff --git a/code/macros.lisp b/code/macros.lisp index 2b1631b2f..006165bba 100644 --- a/code/macros.lisp +++ b/code/macros.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/macros.lisp,v 1.90 2003/02/28 12:44:11 emarsden Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/macros.lisp,v 1.91 2003/03/22 16:15:21 gerd Exp $") ;;; ;;; ********************************************************************** ;;; @@ -207,7 +207,7 @@ (error "Illegal to redefine standard type: ~S." name))) (:instance (warn "Redefining class ~S to be a DEFTYPE." name) - (undefine-structure (layout-info (class-layout (find-class name)))) + (undefine-structure (layout-info (%class-layout (kernel::find-class name)))) (setf (class-cell-class (find-class-cell name)) nil) (setf (info type compiler-layout name) nil) (setf (info type kind name) :defined)) diff --git a/code/misc.lisp b/code/misc.lisp index 335608dab..0303d21c9 100644 --- a/code/misc.lisp +++ b/code/misc.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/misc.lisp,v 1.29 2001/07/08 16:28:09 pw Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/misc.lisp,v 1.30 2003/03/22 16:15:21 gerd Exp $") ;;; ;;; ********************************************************************** ;;; @@ -79,14 +79,14 @@ (values (info type documentation x)))))) (type (typecase x - (structure-class (values (info type documentation (class-name x)))) + (kernel::structure-class (values (info type documentation (%class-name x)))) (t (and (typep x 'symbol) (values (info type documentation x)))))) (setf (info setf documentation x)) ((t) (typecase x (function (function-doc x)) (package (package-doc-string x)) - (structure-class (values (info type documentation (class-name x)))) + (kernel::structure-class (values (info type documentation (%class-name x)))) (symbol (try-cmucl-random-doc x doc-type)))) (t (typecase x diff --git a/code/ntrace.lisp b/code/ntrace.lisp index f46546db2..6db29c8ce 100644 --- a/code/ntrace.lisp +++ b/code/ntrace.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/ntrace.lisp,v 1.19 2003/01/29 21:48:40 cracauer Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/ntrace.lisp,v 1.20 2003/03/22 16:15:20 gerd Exp $") ;;; ;;; ********************************************************************** ;;; @@ -536,9 +536,25 @@ (let ((temp (gensym))) (binds `(,temp ,(pop current))) (forms `(trace-1 ,temp ',options)))) + ;; + ;; Generic function -> trace all method functions. + ((eq name :methods) + (let ((tem (gensym))) + (binds `(,tem ,(pop current))) + (forms `(dolist (name (all-method-function-names ,tem)) + (when (fboundp name) + (trace-1 name ',options)))))) ((and (keywordp name) (not (or (fboundp name) (macro-function name)))) (error "Unknown TRACE option: ~S" name)) + ;; + ;; Method name -> trace method functions. + ((and (consp name) (eq (car name) 'method)) + (when (fboundp name) + (forms `(trace-1 ',name ',options))) + (let ((name `(pcl::fast-method ,@(cdr name)))) + (when (fboundp name) + (forms `(trace-1 ',name ',options))))) (t (forms `(trace-1 ',name ',options)))) (setq current (parse-trace-options current options))))) @@ -563,6 +579,9 @@ are called. In its simplest form: (trace Name-1 Name-2 ...) + CLOS methods can be traced by specifying a name of the form + (METHOD {Qualifier}* ({Specializer}*)). + TRACE causes a printout on *TRACE-OUTPUT* each time that one of the named functions is entered or returns (the Names are not evaluated.) The output is indented according to the number of pending traced calls, and this trace @@ -610,6 +629,12 @@ what function to trace. The Function-Form is evaluated immediately, and the resulting function is traced. + :METHODS Function-Form + This is a not really an option, but rather a way of specifying + that all methods of a generic functions should be tracee. The + Function-Form is evaluated immediately, and the methods of the resulting + generic function are traced. + :ENCAPSULATE {:DEFAULT | T | NIL} If T, the tracing is done via encapsulation (redefining the function name) rather than by modifying the function. :DEFAULT is the default, @@ -665,8 +690,25 @@ (loop (unless current (return)) (let ((name (pop current))) - (res (if (eq name :function) - `(untrace-1 ,(pop current)) - `(untrace-1 ',name))))) + (cond ((eq name :function) + (res `(untrace-1 ,(pop current)))) + ;; + ;; Method name -> untrace existing method functions. + ((and (consp name) + (eq (car name) 'method)) + (when (fboundp name) + (res `(untrace-1 ',name))) + (let ((name `(pcl::fast-method ,@(cdr name)))) + (when (fboundp name) + (res `(untrace-1 ',name))))) + ;; + ;; Generic function -> untrace all method functions. + ((eq name :methods) + (res + `(dolist (name (all-method-function-names ,(pop current))) + (when (fboundp name) + (untrace-1 name))))) + (t + (res `(untrace-1 ',name)))))) `(progn ,@(res) t))) '(untrace-all))) diff --git a/code/package.lisp b/code/package.lisp index ff28a234a..a98e5278e 100644 --- a/code/package.lisp +++ b/code/package.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/package.lisp,v 1.61 2002/11/25 18:59:50 toy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/package.lisp,v 1.62 2003/03/22 16:15:20 gerd Exp $") ;;; ;;; ********************************************************************** ;;; @@ -1678,7 +1678,7 @@ ;; Class and Type Namespace(s) (cond - ((find-class symbol nil) + ((kernel::find-class symbol nil) (print-symbol "class")) ((info type kind symbol) (print-symbol "type"))) diff --git a/code/pred.lisp b/code/pred.lisp index 0c6745436..097d0634f 100644 --- a/code/pred.lisp +++ b/code/pred.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/pred.lisp,v 1.55 2003/01/29 02:16:30 toy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/pred.lisp,v 1.56 2003/03/22 16:15:20 gerd Exp $") ;;; ;;; ********************************************************************** ;;; @@ -133,7 +133,7 @@ (if (typep object '(or function array complex)) (type-specifier (ctype-of object)) (let* ((class (layout-class (layout-of object))) - (name (class-name class))) + (name (%class-name class))) (if (%instancep object) (case name (alien-internals:alien-value @@ -285,7 +285,7 @@ (specifier-type (array-element-type object))))))) (member-type (if (member object (member-type-members type)) t)) - (class + (kernel::class (class-typep (layout-of object) type object)) (union-type (dolist (type (union-type-types type)) @@ -354,11 +354,11 @@ (defun class-typep (obj-layout class object) (declare (optimize speed)) (when (layout-invalid obj-layout) - (if (and (typep (class-of object) 'standard-class) object) + (if (and (typep (kernel::class-of object) 'kernel::standard-class) object) (setq obj-layout (pcl::check-wrapper-validity object)) (error "TYPEP on obsolete object (was class ~S)." (class-proper-name (layout-class obj-layout))))) - (let ((layout (class-layout class)) + (let ((layout (%class-layout class)) (obj-inherits (layout-inherits obj-layout))) (when (layout-invalid layout) (error "Class is currently invalid: ~S" class)) diff --git a/code/profile.lisp b/code/profile.lisp index 78c8499c4..6918d1fca 100644 --- a/code/profile.lisp +++ b/code/profile.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/profile.lisp,v 1.31 2003/02/09 17:25:20 emarsden Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/profile.lisp,v 1.32 2003/03/22 16:15:20 gerd Exp $") ;;; ;;; ********************************************************************** ;;; @@ -32,6 +32,7 @@ ;;; (defpackage "PROFILE" + (:use :common-lisp :ext) (:export *timed-functions* profile profile-all unprofile reset-time report-time report-time-custom *default-report-time-printfunction* with-spacereport print-spacereports reset-spacereports @@ -424,51 +425,128 @@ this, the functions are listed. If NIL, then always list the functions.") Wraps profiling code around the named functions. As in TRACE, the names are not evaluated. If a function is already profiled, then unprofile and reprofile (useful to notice function redefinition.) If a name is undefined, - then we give a warning and ignore it. If :CALLERS T appears, subsequent - names have counts of the most common calling functions recorded. + then we give a warning and ignore it. + + CLOS methods can be profiled by specifying names of the form + (METHOD <name> <qualifier>* (<specializer>*)), like in TRACE. + + :METHODS Function-Form is a way of specifying that all methods of a + generic functions should be profiled. The Function-Form is + evaluated immediately, and the methods of the resulting generic + function are profiled. + + If :CALLERS T appears, subsequent names have counts of the most + common calling functions recorded. + See also UNPROFILE, REPORT-TIME and RESET-TIME." - (let ((names names) - (callers nil) - (res ())) - (loop - (unless names (return)) - (let ((name (pop names))) - (case name - (:callers - (setq callers (pop names))) - (t - (push `(profile-1-function ',name ,callers) res))))) - `(progn ,@res (values)))) + (collect ((binds) (forms)) + (let ((names names) + (callers nil)) + (loop + (unless names (return)) + (let ((name (pop names))) + (cond ((eq name :callers) + (setq callers (pop names))) + ;; + ;; Method functions. + #+pcl + ((and (consp name) (eq 'method (car name))) + (let ((fast-name `(pcl::fast-method ,@(cdr name)))) + (forms `(when (fboundp ',name) + (profile-1-function ',name ,callers) + (reinitialize-method-function ',name))) + (forms `(when (fboundp ',fast-name) + (profile-1-function ',fast-name ,callers) + (reinitialize-method-function ',fast-name))))) + ;; + ;; All method of a generic function. + #+pcl + ((eq :methods name) + (let ((tem (gensym))) + (binds `(,tem ,(pop names))) + (forms `(dolist (name + (debug::all-method-function-names ,tem)) + (when (fboundp name) + (profile-1-function name ,callers) + (reinitialize-method-function name)))))) + (t + (forms `(profile-1-function ',name ,callers)))))) + (if (binds) + `(let ,(binds) ,@(forms) (values)) + `(progn ,@(forms) (values)))))) ;;; PROFILE-ALL -- Public ;;; ;;; Add profiling to all symbols in the given package. ;;; -(defun profile-all (&key (package *package*) (callers-p nil)) +(defun profile-all (&key (package *package*) (callers-p nil) + (methods nil)) "PROFILE-ALL Wraps profiling code around all functions in PACKAGE, which defaults to *PACKAGE*. If a function is already profiled, then unprofile and reprofile (useful to notice function redefinition.) If a name is undefined, then we give a warning and ignore it. If CALLERS-P is T - names have counts of the most common calling functions recorded. See - also UNPROFILE, REPORT-TIME and RESET-TIME. " + names have counts of the most common calling functions recorded. + + When called with arguments :METHODS T, profile all methods of all + generic function having names in the given package. Generic functions + themselves, that is, their dispatch functions, are left alone. + + See also UNPROFILE, REPORT-TIME and RESET-TIME. " (let ((package (if (packagep package) package (find-package package)))) (do-symbols (symbol package (values)) (when (and (eq (symbol-package symbol) package) (fboundp symbol) - (not (special-operator-p symbol))) - (profile-1-function symbol callers-p))))) + (not (special-operator-p symbol)) + (or (not methods) + (not (typep (fdefinition symbol) 'generic-function)))) + (profile-1-function symbol callers-p))) + ;; + ;; Profile all method functions whose generic function name + ;; is in the package. + (when methods + (dolist (name (debug::all-method-functions-in-package package)) + (when (fboundp name) + (profile-1-function name callers-p) + (reinitialize-method-function name)))))) ;;; UNPROFILE -- Public ;;; (defmacro unprofile (&rest names) "Unwraps the profiling code around the named functions. Names defaults to the list of all currently profiled functions." - `(dolist (name ,(if names `',names '*timed-functions*) (values)) - (unprofile-1-function name))) + (collect ((binds) (forms)) + (let ((names names)) + (loop + (unless names (return)) + (let ((name (pop names))) + (cond #+pcl + ((and (consp name) + (member (car name) '(method pcl::fast-method))) + (let ((name `(method ,@(cdr name))) + (fast-name `(pcl::fast-method ,@(cdr name)))) + (forms `(when (fboundp ',name) + (unprofile-1-function ',name) + (reinitialize-method-function ',name))) + (forms `(when (fboundp ',fast-name) + (unprofile-1-function ',fast-name) + (reinitialize-method-function ',fast-name))))) + #+pcl + ((eq :methods name) + (let ((tem (gensym))) + (binds `(,tem ,(pop names))) + (forms `(dolist (name (debug::all-method-function-names ,tem)) + (when (fboundp name) + (unprofile-1-function name) + (reinitialize-method-function name)))))) + (t + (forms `(unprofile-1-function ',name)))))) + (if (binds) + `(let ,(binds) ,@(forms) (values)) + `(progn ,@(forms) (values)))))) ;;; UNPROFILE-1-FUNCTION -- Internal diff --git a/code/sharpm.lisp b/code/sharpm.lisp index 6b7fed140..a04c0e80c 100644 --- a/code/sharpm.lisp +++ b/code/sharpm.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/sharpm.lisp,v 1.23 2003/01/06 22:27:16 toy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/sharpm.lisp,v 1.24 2003/03/22 16:15:20 gerd Exp $") ;;; ;;; ********************************************************************** ;;; @@ -214,13 +214,13 @@ (%reader-error stream "Non-list following #S: ~S" body)) (unless (symbolp (car body)) (%reader-error stream "Structure type is not a symbol: ~S" (car body))) - (let ((class (find-class (car body) nil))) - (unless (typep class 'structure-class) + (let ((class (kernel::find-class (car body) nil))) + (unless (typep class 'kernel::structure-class) (%reader-error stream "~S is not a defined structure type." (car body))) (let ((def-con (dd-default-constructor (layout-info - (class-layout class))))) + (%class-layout class))))) (unless def-con (%reader-error stream "The ~S structure does not have a default constructor." @@ -239,12 +239,13 @@ ;; alist of the things to be replaced assoc'd with the things to replace them. ;; (defun circle-subst (old-new-alist tree) - (cond ((not (typep tree '(or cons (array t) structure-object))) + (cond ((not (typep tree '(or cons (array t) structure-object + standard-object))) (let ((entry (find tree old-new-alist :key #'second))) (if entry (third entry) tree))) ((null (gethash tree *sharp-equal-circle-table*)) (setf (gethash tree *sharp-equal-circle-table*) t) - (cond ((typep tree 'structure-object) + (cond ((typep tree '(or structure-object standard-object)) (do ((i 1 (1+ i)) (end (%instance-length tree))) ((= i end)) diff --git a/code/type.lisp b/code/type.lisp index 4d3cffa05..db95085d4 100644 --- a/code/type.lisp +++ b/code/type.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/type.lisp,v 1.50 2003/03/18 05:35:28 toy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/type.lisp,v 1.51 2003/03/22 16:15:20 gerd Exp $") ;;; ;;; ********************************************************************** ;;; @@ -89,13 +89,13 @@ ;;; (defun has-superclasses-complex-subtypep-arg1 (type1 type2 info) (values - (and (typep type2 'class) + (and (typep type2 'kernel::class) (dolist (x info nil) (when (or (not (cdr x)) (csubtypep type1 (specifier-type (cdr x)))) (return (or (eq type2 (car x)) - (let ((inherits (layout-inherits (class-layout (car x))))) + (let ((inherits (layout-inherits (%class-layout (car x))))) (dotimes (i (length inherits) nil) (when (eq type2 (layout-class (svref inherits i))) (return t))))))))) @@ -117,7 +117,7 @@ (mapcar #'(lambda (spec) (destructuring-bind (super &optional guard) spec - (cons (find-class super) guard))) + (cons (kernel::find-class super) guard))) specs))) `(cold-load-init (setf (type-class-complex-subtypep-arg1 @@ -869,15 +869,16 @@ ((and (not (eq spec orig)) (info type builtin spec))) ((eq (info type kind spec) :instance) - (find-class spec)) - ((typep spec 'class) - (if (typep spec 'built-in-class) + (kernel::find-class spec)) + ((typep spec 'kernel::class) + (if (typep spec 'kernel::built-in-class) (or (built-in-class-translation spec) spec) spec)) (t (let* ((lspec (if (atom spec) (list spec) spec)) (fun (info type translator (car lspec)))) - (cond (fun (funcall fun lspec)) + (cond (fun + (funcall fun lspec)) ((or (and (consp spec) (symbolp (car spec))) (symbolp spec)) (when *type-system-initialized* @@ -2535,14 +2536,15 @@ (defun ctypep (obj type) (declare (type ctype type)) (etypecase type - ((or numeric-type named-type member-type array-type built-in-class cons-type) + ((or numeric-type named-type member-type array-type + kernel::built-in-class cons-type) (values (%typep obj type) t)) (class (if (if (csubtypep type (specifier-type 'funcallable-instance)) (funcallable-instance-p obj) (%instancep obj)) - (if (eq (class-layout type) - (info type compiler-layout (class-name type))) + (if (eq (%class-layout type) + (info type compiler-layout (%class-name type))) (values (typep obj type) t) (values nil nil)) (values nil t))) @@ -2622,7 +2624,7 @@ (typecase x (function (if (funcallable-instance-p x) - (class-of x) + (kernel::class-of x) (extract-function-type x))) (symbol (make-member-type :members (list x))) @@ -2661,7 +2663,7 @@ (cons (make-cons-type)) (t - (class-of x)))) + (kernel::class-of x)))) ;;; Clear this cache on GC so that we don't hold onto too much garbage. @@ -2699,11 +2701,14 @@ ;;;; Some types that we use in defining the standard functions: -;;; +;;; ;;; -;;; A type specifier. -(deftype type-specifier () '(or list symbol class)) +;;; A type specifier. INSTANCE stands for either KERNEL::CLASS +;;; or LISP:CLASS (CLOS class), but since LISP:CLASS isn't a type +;;; until PCL is loaded, that's not expressable. +;;; +(deftype type-specifier () '(or list symbol instance)) ;;; ;;; An index into an array. Also used for sequence index. (deftype index () `(integer 0 (,array-dimension-limit))) diff --git a/compiler/dump.lisp b/compiler/dump.lisp index 7e3ec4753..280779361 100644 --- a/compiler/dump.lisp +++ b/compiler/dump.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/dump.lisp,v 1.77 2002/10/12 16:43:56 pmai Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/dump.lisp,v 1.78 2003/03/22 16:15:20 gerd Exp $") ;;; ;;; ********************************************************************** ;;; @@ -1660,7 +1660,7 @@ (unless (member (layout-invalid obj) '(nil :compiler)) (compiler-error "Dumping reference to obsolete class: ~S" (layout-class obj))) - (let ((name (class-name (layout-class obj)))) + (let ((name (%class-name (layout-class obj)))) (assert name) (dump-fop 'lisp::fop-normal-load file) (let ((*cold-load-dump* t)) diff --git a/compiler/fndb.lisp b/compiler/fndb.lisp index 4c9657276..66436e277 100644 --- a/compiler/fndb.lisp +++ b/compiler/fndb.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/fndb.lisp,v 1.108 2003/03/21 21:36:35 pmai Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/fndb.lisp,v 1.109 2003/03/22 16:15:20 gerd Exp $") ;;; ;;; ********************************************************************** ;;; @@ -100,11 +100,9 @@ ;;;; Classes: -(deftype name-for-class () 't) -(defknown class-name (class) name-for-class (flushable)) -(defknown find-class (name-for-class &optional t lexenv-or-null) - (or class null) ()) -(defknown class-of (t) class (flushable)) +(defknown kernel::find-class (t &optional t lexenv-or-null) + (or kernel::class null) ()) +(defknown kernel::class-of (t) kernel::class (flushable)) (defknown layout-of (t) layout (flushable)) (defknown copy-structure (structure-object) structure-object (flushable unsafe)) diff --git a/compiler/generic/primtype.lisp b/compiler/generic/primtype.lisp index 9a17e1a5a..cf6066087 100644 --- a/compiler/generic/primtype.lisp +++ b/compiler/generic/primtype.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/primtype.lisp,v 1.22 2002/09/04 14:04:17 toy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/primtype.lisp,v 1.23 2003/03/22 16:15:18 gerd Exp $") ;;; ;;; ********************************************************************** ;;; @@ -393,10 +393,10 @@ (ecase (named-type-name type) ((t *) (values *any-primitive-type* t)) ((nil) (any)))) - (built-in-class - (case (class-name type) + (kernel::built-in-class + (case (%class-name type) ((complex function instance system-area-pointer weak-pointer) - (values (primitive-type-or-lose (class-name type) *backend*) t)) + (values (primitive-type-or-lose (%class-name type) *backend*) t)) (funcallable-instance (part-of function)) (base-char diff --git a/compiler/generic/vm-fndb.lisp b/compiler/generic/vm-fndb.lisp index 8f222e97d..de378ee4f 100644 --- a/compiler/generic/vm-fndb.lisp +++ b/compiler/generic/vm-fndb.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/vm-fndb.lisp,v 1.63 2000/07/09 16:08:43 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/vm-fndb.lisp,v 1.64 2003/03/22 16:15:18 gerd Exp $") ;;; ;;; ********************************************************************** ;;; @@ -99,7 +99,7 @@ (defknown %make-instance (index) instance - (unsafe)) + (flushable movable)) (defknown %instance-layout (instance) layout (foldable flushable)) (defknown %set-instance-layout (instance layout) layout diff --git a/compiler/generic/vm-type.lisp b/compiler/generic/vm-type.lisp index 72ca9ae71..27169411e 100644 --- a/compiler/generic/vm-type.lisp +++ b/compiler/generic/vm-type.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/vm-type.lisp,v 1.41 2000/07/07 09:33:11 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/vm-type.lisp,v 1.42 2003/03/22 16:15:18 gerd Exp $") ;;; ;;; ********************************************************************** ;;; @@ -188,8 +188,8 @@ (if (type= type (specifier-type 'cons)) 'c:check-cons nil)) - (built-in-class - (case (class-name type) + (kernel::built-in-class + (case (%class-name type) (symbol 'c:check-symbol))) (function-type 'c:check-function) diff --git a/compiler/globaldb.lisp b/compiler/globaldb.lisp index b8ac6be65..67121d02f 100644 --- a/compiler/globaldb.lisp +++ b/compiler/globaldb.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/globaldb.lisp,v 1.41 2001/03/13 16:52:16 pw Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/globaldb.lisp,v 1.42 2003/03/22 16:15:19 gerd Exp $") ;;; ;;; ********************************************************************** ;;; @@ -1132,8 +1132,8 @@ ;;; Layout for this type being used by the compiler. ;;; (define-info-type type compiler-layout (or layout null) - (let ((class (find-class name nil))) - (when class (class-layout class)))) + (let ((class (kernel::find-class name nil))) + (when class (%class-layout class)))) (define-info-class typed-structure) (define-info-type typed-structure info t nil) diff --git a/compiler/ir1tran.lisp b/compiler/ir1tran.lisp index d1d2f66d8..258a0ea2a 100644 --- a/compiler/ir1tran.lisp +++ b/compiler/ir1tran.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir1tran.lisp,v 1.138 2003/02/05 23:37:06 gerd Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir1tran.lisp,v 1.139 2003/03/22 16:15:19 gerd Exp $") ;;; ;;; ********************************************************************** ;;; @@ -147,10 +147,10 @@ ;;; accessor Name. Class is the structure class. ;;; (defun find-structure-slot-accessor (class name) - (declare (type class class)) + (declare (type kernel::class class)) (let* ((info (layout-info - (or (info type compiler-layout (class-name class)) - (class-layout class)))) + (or (info type compiler-layout (%class-name class)) + (%class-layout class)))) (accessor (if (listp name) (cadr name) name)) (slot (find accessor (kernel:dd-slots info) :key #'kernel:dsd-accessor)) @@ -201,11 +201,11 @@ (etypecase info (null (find-free-really-function name)) - (structure-class + (kernel::structure-class (find-structure-slot-accessor info name)) (class (if (typep (layout-info (info type compiler-layout - (class-name info))) + (%class-name info))) 'defstruct-description) (find-structure-slot-accessor info name) (find-free-really-function name)))))))))))) diff --git a/compiler/node.lisp b/compiler/node.lisp index 8027456c5..797929838 100644 --- a/compiler/node.lisp +++ b/compiler/node.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/node.lisp,v 1.37 2001/03/04 20:12:24 pw Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/node.lisp,v 1.38 2003/03/22 16:15:19 gerd Exp $") ;;; ;;; ********************************************************************** ;;; @@ -731,7 +731,7 @@ ;; ;; The description of the structure that this is an accessor for. (for (required-argument) - :type #+ns-boot (or class defstruct-description) + :type #+ns-boot (or kernel::class defstruct-description) #-ns-boot class) ;; ;; The slot description of the slot. diff --git a/compiler/proclaim.lisp b/compiler/proclaim.lisp index 7dc1455df..4d33b9473 100644 --- a/compiler/proclaim.lisp +++ b/compiler/proclaim.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/proclaim.lisp,v 1.39 2003/02/05 12:33:12 gerd Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/proclaim.lisp,v 1.40 2003/03/22 16:15:19 gerd Exp $") ;;; ;;; ********************************************************************** ;;; @@ -238,7 +238,7 @@ (compiler-warning "Undefining structure type:~% ~S~@ so that this slot accessor can be redefined:~% ~S" - (class-name for) name) + (%class-name for) name) (undefine-structure for) (setf (info function kind name) :function)))) (:macro @@ -395,13 +395,13 @@ (freeze-type (dolist (type args) (let ((class (specifier-type type))) - (when (typep class 'class) - (setf (class-state class) :sealed) - (let ((subclasses (class-subclasses class))) + (when (typep class 'kernel::class) + (setf (%class-state class) :sealed) + (let ((subclasses (%class-subclasses class))) (when subclasses (do-hash (subclass layout subclasses) (declare (ignore layout)) - (setf (class-state subclass) :sealed)))))))) + (setf (%class-state subclass) :sealed)))))))) (function ;; ;; Handle old-style FUNCTION declaration, which is a shorthand for diff --git a/compiler/typetran.lisp b/compiler/typetran.lisp index 40dec60d9..5fb886ca7 100644 --- a/compiler/typetran.lisp +++ b/compiler/typetran.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/typetran.lisp,v 1.39 2000/08/09 13:00:17 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/typetran.lisp,v 1.40 2003/03/22 16:15:19 gerd Exp $") ;;; ;;; ********************************************************************** ;;; @@ -118,8 +118,8 @@ ;;; If FIND-CLASS is called on a constant class, locate the CLASS-CELL at ;;; load time. ;;; -(deftransform find-class ((name) ((constant-argument symbol)) * - :when :both) +(deftransform kernel::find-class ((name) ((constant-argument symbol)) * + :when :both) (let* ((name (continuation-value name)) (cell (find-class-cell name))) `(or (class-cell-class ',cell) @@ -432,7 +432,7 @@ (assert (constant-continuation-p spec)) (let* ((spec (continuation-value spec)) (class (specifier-type spec)) - (name (class-name class)) + (name (%class-name class)) (otype (continuation-type object)) (layout (let ((res (info type compiler-layout name))) (if (and res (member (layout-invalid res) '(:compiler nil))) @@ -443,7 +443,7 @@ ((not (types-intersect otype class)) 'nil) ((csubtypep otype class) 't) ;; If not properly named, error. - ((not (and name (eq (find-class name) class))) + ((not (and name (eq (kernel::find-class name) class))) (compiler-error "Can't compile TYPEP of anonymous or undefined ~ class:~% ~S" class)) @@ -461,8 +461,8 @@ (t (values '(lambda (x) (declare (ignore x)) t) 'layout-of))) (cond - ((and (eq (class-state class) :sealed) layout - (not (class-subclasses class))) + ((and (eq (%class-state class) :sealed) layout + (not (%class-subclasses class))) ;; Sealed and has no subclasses. (let ((n-layout (gensym))) `(and (,pred object) diff --git a/compiler/xref.lisp b/compiler/xref.lisp index d66bf1e35..42e675ec5 100644 --- a/compiler/xref.lisp +++ b/compiler/xref.lisp @@ -3,7 +3,7 @@ ;;; Author: Eric Marsden <emarsden@laas.fr> ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/xref.lisp,v 1.2 2003/02/24 16:40:05 emarsden Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/xref.lisp,v 1.3 2003/03/22 16:15:19 gerd Exp $") ;; ;; This code was written as part of the CMUCL project and has been ;; placed in the public domain. @@ -205,22 +205,22 @@ be set at runtime." ;; #+pcl (defun who-subclasses (class) - (declare (type class class)) + (declare (type kernel::class class)) (pcl::class-direct-subclasses class)) ;; WHO-SUPERCLASSES -- interface ;; #+pcl (defun who-superclasses (class) - (declare (type class class)) + (declare (type kernel::class class)) (pcl::class-direct-superclasses class)) ;; generic functions defined for this class #+pcl (defun who-specializes (class) - (declare (type class class)) + (declare (type kernel::class class)) (let ((pcl-class (etypecase class - (lisp:class (pcl::coerce-to-pcl-class class)) + (kernel::class (pcl::coerce-to-pcl-class class)) (pcl::class class)))) (pcl::specializer-direct-methods pcl-class))) diff --git a/pcl/12-7-88-notes.text b/pcl/12-7-88-notes.text deleted file mode 100644 index a9405156f..000000000 --- a/pcl/12-7-88-notes.text +++ /dev/null @@ -1,45 +0,0 @@ -Copyright (c) Xerox Corporation 1988. All rights reserved. - - -These notes correspond to the "12/7/88 Can't think of a cute name PCL" -version of PCL. - -Please read this entire file carefully. You may also be interested in -looking at previous versions of the notes.text file. These are called -xxx-notes.text where xxx is the version of the PCL system the file -corresponds to. At least the last two versions of this file contain -useful information for any PCL user. - -This version of PCL has been tested at PARC in the following Common -Lisps: - - Symbolics 7.2 - Coral 1.2 - Lucid 3.0 - KCL (October 15, 1987) - Allegro 3.0.1 - -These three should work, but haven't been tested just yet. - - EnvOS Medley - TI - -The notes file hasn't yet been fleshed out yet. - -The two major changes in this release are: - - - The generic function cache algorithm has been revised. In addition - generic function caches now expand automatically. Programs that used - to run into problems with lots of cache misses shouldn't run into - those problems anymore. - - - the DEFCONSTRUCTOR hack now works. Please see the construct.lisp - file for details. If you are consing lots of instances, you may be - able to get a tremendous performance boost by using this hack. - - -Another important change is that this version includes some KCL patches -which dramatically improve PCL performance in KCL. See the kcl-mods.text -file for more details. - - diff --git a/pcl/3-17-88-notes.text b/pcl/3-17-88-notes.text deleted file mode 100644 index 7602fb07e..000000000 --- a/pcl/3-17-88-notes.text +++ /dev/null @@ -1,167 +0,0 @@ -Copyright (c) Xerox Corporation 1988. All rights reserved. - -These notes correspond to the beta test release of March 17th 1988. -Later versions of this release will run in the usual lisps, but for the -time being this has only been tested in Symbolics, Lucid, Coral, -Xerox, Ibuki (01/01), TI and VAXLisp Common Lisps. - -Note may not run in all Franz Lisps, I believe it runs on the SUN3 -though. I will get back to this in a few days when I get the needed -code from Franz. - -*** -This release will run in Lucid 3.0 beta 2, with the boolean.lbin patch. - -*** -This release contains a prototype implementation of the make-instance -behavior documented in the CLOS specification (X3J13 document # 88-002). -This prototype implementation does not provide high performance, but it -should conform to the specification with one exception, it does not -check the validity of the initargs. - -All the generic functions in the instance creation protocol are as -specified in the CLOS specification except that make-instance is called -mki instead. This name is a temporary name, it is so that people can -try out the new make-instance protocol without having to convert all -their code at once. In a future release, the name make-instance will be -switched to the new behavior. - -*** -Standard method combination is supported. General declarative -method combination is not yet supported, so define-method-combination does -not yet work, but standard method combination is what generic functions -do by default now. :after :before :around and unqualified methods are -supported. Error checking is minimal. - -*** -call-next-method works with standard-method-combination. -call-next-method is much faster than it was before, and call-next-method -behaves as a lexically defined function. This means it is possible to -pass around funargs which include call-next-method. - -*** -All uses of slot-value within a method body should be optimized. It -should no longer be necessary to use with-slots just to get the -optimization. - -*** -There are new macros with-slots* and with-accessors*. These correspond -to the macros which will appear in the final specification, with-slots -and with-accessors. They work as follows: - -(with-slots* ((x x-slot) - (y y-slot)) ===\ (let ((#:g1 (foo))) - (foo) ===/ (swapf (slot-value #:g1 'x-slot) - (swapf x y)) (slot-value #:g1 'y-slot))) - -(with-accessors* ((x position-x) - (y position-y)) ===\ (let ((#:g1 (foo))) - (foo) ===/ (incf (position-x #:g1)) - (incf x) (incf (position-y #:g1))) - (incf y)) - -As an abbreviation, the (<variable-name> <slot-name>) pairs in with-slots* -can be abbreviated to just <variable-and-slot-name> when the variable -and slot name are the same. This means that: - -(with-slots* (x y z) <instance-form> &body <body>) - -is equivalent to: - -(with-slots* ((x x) (y y) (z z)) <instance-form> &body <body>) - -You should begin to convert your code to use these macros as soon as -possible since the old macro with-slots will swap names with with-slots* -sometime soon. - -A trick you may want to use for remembering the order of the first two -arguments to with-slots* and with-accessors* is that it is "like -multiple-value-bind". - -*** -In addition this release includes the beginnings of support for doing -some of the compiling which PCL does a load time at compile time -instead. To use this support, put the form: - - (pcl::precompile-random-code-segments) - -in a file which is compiled after all your other pcl using files are -loaded. Then arrange for that file to be loaded before all your -other pcl using files are loaded. - -For example, if your system has two files called "classes" and "methods", -create a new file called "precom" that contains: - - (in-package 'pcl) - - (pcl::precompile-random-code-segments) - - -Then you can use the defsystem stuff defined in the file defsys to -maintain your system as follows: - -(defsystem my-very-own-system - "/usr/myname/lisp/" - ((classes (precom) () ()) - (methods (precom classes) (classes) ()) - (precom () (classes methods) (classes methods)))) - -This defsystem should be read as follows: - -* Define a system named MY-VERY-OWN-SYSTEM, the sources and binaries - should be in the directory "/usr/me/lisp/". There are three files - in the system, there are named classes, methods and precom. (The - extension the filenames have depends on the lisp you are running in.) - -* For the first file, classes, the (precom) in the line means that - the file precom should be loaded before this file is loaded. The - first () means that no other files need to be loaded before this - file is compiled. The second () means that changes in other files - don't force this file to be recompiled. - -* For the second file, methods, the (precom classes) means that both - of the files precom and classes must be loaded before this file - can be loaded. The (classes) means that the file classes must be - loaded before this file can be compiled. The () means that changes - in other files don't force this file to be recompiled. - -* For the third file, precom, the first () means that no other files - need to be loaded before this file is loaded. The first use of - (classes methods) means that both classes and methods must be - loaded before this file can be compiled. The second use of (classes - methods) mean that whenever either classes or methods changes precom - must be recompiled. - -Then you can compile your system with: - - (operate-on-system 'my-very-own-system :compile) - -and load your system with: - - (operate-on-system 'my-very-own-system :load) - -*** -The code walker has gone through some signigificant revision. The -principle change is that the function walk-form now takes three required -arguments, and the walk-function itself now must accept an environment -argument. There are other changes having to do with the implementation -specific representation of macroexpansion environments. For details see -the file walk.lisp. - -*** -The following functions and macros which used to be supported for -backward compatibility only are now not supported at all: - -WITH* and WITH - -DEFMETH - -GET-SLOT - -MAKE - - -*** -There are other small changes in this release. If you notice one that -causes you problems please send me a message about it. - diff --git a/pcl/3-19-87-notes.text b/pcl/3-19-87-notes.text deleted file mode 100644 index ce332f63a..000000000 --- a/pcl/3-19-87-notes.text +++ /dev/null @@ -1,138 +0,0 @@ - - -These notes correspond to *pcl-system-date* 3/19/87 prime. - -This release runs in: - ExCL - Lucid - Symbolics Common Lisp (Genera) - Vaxlisp (2.0) - Xerox Common Lisp (Lyric Release) - -CMU Lisp (nee Spice) and KCL should be working soon, I will announce -another release at that time. I figured it was better to get some -people beating on it as soon as possibl. - -Xerox Lisp users should FTP all the source files from /pub/pcl/ as well -as all the dfasl files from /pub/pcl/xerox/. Included in the xerox -specific directory is a file called PCL-ENV, which provides some simple -environment support for using PCL in Xerox Lisp. - - - -Following is a description of some of the things that are different in -this release of PCL. This list isn't in any particular order. There -are a number of incompatible changes in this release, please read the -whole thing carefully. - -As usual, please enjoy, and send bug-reports, questions etc. to -CommonLoops@Xerox.com. - -*** -The single most significant change is that discriminator-objects with -corresponding discriminating functions have been replaced by generic -function objects. What does this mean?? Well, in previous releases of -PCL, if you did: - -(defmethod foo ((x class)) 'class) -(defmethod foo ((x method)) 'method) - -Then (discriminator-named 'foo) returned a discriminator object which -had both of these methods defined on it. (symbol-function 'foo) -returned a discriminating function, which (discriminator-named 'foo) had -put in foo's function cell. - -In this release of PCL, the above defmethod's put a generic-function -object in foo's function cell. This generic-function object is a -combination of the discriminator object and discriminating function of -the previous releases of PCL. This generic-function object is -funcallable, funcalling it causes the appropriate method to be looked up -and called. This generic function object has accessors which return the -methods defined on the generic function. This generic function object -is mutable. It is possible to add and remove methods from it. - -(defmethod foo ((x class)) 'class) -(defmethod foo ((x method)) 'method) - -(generic-function-methods #'foo) -(#<Method FOO (METHOD) 3434> #<Method FOO (CLASS) 3245>) - -(foo (make 'class)) ==> 'class -(foo (make 'method)) ==> 'method - -(remove-method #'foo (car (generic-function-methods #'foo))) - -(foo (make 'class)) ==> 'class -(foo (make 'method)) ==> no matching method error - - -Note that as part of this change, the name of any function, generic -function or class which included the string "DISCRIMINATOR" has changed. -The name changes that happened were: - The class essential-discriminator was renamed to generic-function, - The class basic-discriminator and the class discrimiantor were - combined and renamed to standard-generic-function. - -If you went through your code and made the following name changes, you -would probably win, (this is what I did to PCL and it worked). - - essential-discriminator ==> generic-function - basic-discriminator ==> standard-generic-function - discriminator - (when it appears as a specializer) - ==> standard-generic-function - discriminator - (when it appears as part of a variable name or something) - ==> generic-function - -*** -In most Lisp implementations, method lookup is at least twice as fast as -it was in the previous release. - -*** -The compiler isn't called when PCL is loaded anymore. In a future -release, the compiler will also not be called when any other method -definitions are loaded. This is part of an effort to get PCL to a state -where the compiler will never be needed when compiled files are loaded. - -*** -PCL now has a mechanism for naming the generic-function's and method -functions defined by defmethod. This means that in ports of PCL which -take advantage of this mechanism, you will see useful function names in -the debugger rather than the useless gensym names that have been in the -past few releases. - -*** -Compiled files containing defmethod forms should be smaller and load -faster. - -*** -Many of the files in the system have been renamed. More files will be -renamed in upcoming releases. - -*** -An important part of the bootstrapping code has been re-written. The -remainder of this code (the BRAID1 and BRAID2 files) will be re-written -sometime soon. - -The changes made to bootstrapping in this release were done to make -early methods more understandable, and as part of implementing generic -function objects. Also, most users should find that PCL loads in less -time than it did before. - -The changes which will be made to bootstrapping in a future release will -make understanding the "Braid" stuff easier, and will make it possible -to implement slot-description objects as described in the CURRENT DRAFT -of the Common Lisp Object System Chapter 3. - -*** -The defsys file has been re-written AGAIN. This shouldn't affect users -since there are still the old familiar variables *pcl-pathname-defaults* -and *pathname-extensions*. - -*** -The specialized foo-notes files are all gone. Most of them were -hopelessly out of date, and installing pcl is now the same operation for -any Lisp. In particular, note that in Vaxlisp, it is no longer -necessary to push lisp:vaxlisp on the *features* list. - diff --git a/pcl/4-21-87-notes.text b/pcl/4-21-87-notes.text deleted file mode 100644 index b1acd73f5..000000000 --- a/pcl/4-21-87-notes.text +++ /dev/null @@ -1,53 +0,0 @@ - - -These notes correspond to *pcl-system-date* "4/21/87 April 21rst 1987". - -The notes from the last release are stored as 3-19-notes.text - -This release runs in: - ExCL - Lucid - Symbolics Common Lisp (Genera) - Vaxlisp (2.0) - Xerox Common Lisp (Lyric Release) - Kyoto Common Lisp (5.2) - -CMU Lisp (nee Spice) should be working soon, I will announce another -release at that time. - -Xerox Lisp users should FTP all the source files from /pub/pcl/ as well -as all the dfasl files from /pub/pcl/xerox/. Included in the xerox -specific directory is a file called PCL-ENV, which provides some simple -environment support for using PCL in Xerox Lisp. - - -The major difference in this release is that defclass conforms to the -CLOS specification (pretty much I hope). Previous warnings about what -would happen when defclass became CLOS defclass now apply. Once major -difference is that PCL currently does require that all a classes -superclasses be defined when a defclass form is evaluated. This will -change sometime soon. - -Other small changes include: - -Some more of the files have been renamed and restructured (as promised). - -the defclass parsing protocol has changed - -slotd datastructures are now instances of the class -standard-slot-description. - -a performance bug in the ExCL port which causes method lookup and slot -access to cons needlessly. - -a bug in the 3600 port which broke the printer for stack consed closures - -make-specializable - -a bug in Lucid lisp which made it impossible to say (compile-pcl) has -been patched around, this is the bug that manifested itself as NAME -being ubound. - - -As usual, please enjoy and send comments. - diff --git a/pcl/4-29-87-notes.text b/pcl/4-29-87-notes.text deleted file mode 100644 index 307b86e86..000000000 --- a/pcl/4-29-87-notes.text +++ /dev/null @@ -1,80 +0,0 @@ - - -These notes correspond to *pcl-system-date* "4/29/87 prime April 29, 1987". - -The notes from the last release are stored as 4-21-notes.text - -This release runs in: - ExCL - Lucid - Symbolics Common Lisp (Genera) - Vaxlisp (2.0) - Xerox Common Lisp (Lyric Release) - Kyoto Common Lisp (5.2) - TI Common Lisp (Release 3) - -CMU Lisp (nee Spice) should be working soon, I will announce another -release at that time. - -TI release 2 should also be working soon, I will announce that when it -happens. - - -Note once again, that Xerox Lisp users should FTP all the source files -from /pub/pcl/ as well as all the dfasl files from /pub/pcl/xerox/. -Included in the xerox specific directory is a file called PCL-ENV, which -provides some simple environment support for using PCL in Xerox Lisp. -You must load PCL BEFORE loading pcl-env. - - -MAJOR CHANGES IN THIS RELEASE: - - make has been renamed to make-instance - - make-instance has been renamed to allocate-instance - -for compatibility, make can continue to be used as a synonym for -make-instance. unfortunately, code which used to call make-instance -must be converted. - -I would actually suggest that you do both of these name changes right -away. Two passes through the code using Query Replace seems to work -quite well (changing make-instance to allocate-instance and then make to -make-instance.) I was able to change all of PCL in about 10 minutes -that way. - ---- - -all functions and generic functions whose name included the string -"get-slot" have been renamed. Basically, get-slot was replaced -everywhere it appeared with slot-value. - -get-slot itself still exists for compatibility, but you should start -converting your code to use slot-value. - - - -OTHER CHANGES in this release: - -There is a new file called PKG which does the exports for PCL. PCL now -exports fewer symbols than before. Specifically, PCL now exports only -those symbols documented in the CLOS spec chapters 1 and 2. This means -that some symbols which may be needed by some programs are not exported. - -A good example is print-instance. print-instance is not exported and -since print-instance has not yet been renamed to print-object programs -which define methods on print-instance may want to import that symbol. - ---- - -pcl should load faster in this release. In particular, the file fixup -should load in less than half the time it did before. This release -should load in something like 80% of the time it took in the last -release. Remember, these numbers are only for comparison, your mileage -may vary. - ---- - -This release of PCL, as well as the last one, has *pcl-system-date* -which presents the date in both mm/dd/yy and Month day year format. - diff --git a/pcl/5-22-87-notes.text b/pcl/5-22-87-notes.text deleted file mode 100644 index 01aed9fd0..000000000 --- a/pcl/5-22-87-notes.text +++ /dev/null @@ -1,126 +0,0 @@ - - -These notes correspond to *pcl-system-date* "5/22/87 May 22nd, 1987". - -The notes from the last release are stored as 4-29-notes.text - -This release runs in: - CMU Lisp - ExCL - Lucid - Symbolics Common Lisp (Genera) - Vaxlisp (2.0) - Xerox Common Lisp (Lyric Release) - Kyoto Common Lisp (5.2) - TI Common Lisp (Release 3) - -TI release 2 should also be working soon, I will announce that when it -happens. - - -Note once again, that Xerox Lisp users should FTP all the source files -from /pub/pcl/ as well as all the dfasl files from /pub/pcl/xerox/. -Included in the xerox specific directory is a file called PCL-ENV, which -provides some simple environment support for using PCL in Xerox Lisp. -You must load PCL BEFORE loading pcl-env. - - -MAJOR CHANGES IN THIS RELEASE: - ---- - it is possible to forward reference classes in a defclass (or - add-named-class) form. This means it is possible to say: - - (defclass foo (bar) (i j k)) - - (defclass bar () (x y z)) - - Rather than having to put the in the "right" order. - - NOTE: the full-on error checking for this is not finished yet. - don't try to break it by doing things like: - - (defclass foo (bar) (i j k)) - (make-instance 'foo) - (defclass bar () (x y z)) - ---- - print-instance has been renamed to print-object - ---- - the defclass and class-definition protocol has changed. some of the -effects of this change are: - -* ADD-NAMED-CLASS is a true functional interface for defclass, so for - example, - - (defclass foo () (x y z) (:accessor-prefix foo-)) - - is equivalent to: - - (add-named-class (class-prototype (class-named 'class)) - 'foo - () - '(x y z) - '((:accessor-prefix foo-))) - -* defclass (and add-named-class) now undefined accessor methods, reader - methods and constructors which 'went away'. For example: - - (defclass foo () (x y z) (:reader-prefix foo-)) - - defines methods on the generic functions foo-x foo-y and foo-z. - - but if you then evaluated the defclass form: - - (defclass foo () (x y z)) - - those reader methods will be removed from the generic functions - foo-x foo-y and foo-z. - - Similarly constructors which 'went away' will be undefined. - ---- - writer methods generated by the :accessor and :accessor-prefix options - now pay attention to the :type slot-option. So, - - (defclass foo () ((x :accessor foo-x :type symbol))) - - (defvar *foo-1* (make-instance 'foo)) - - (setf (foo-x *foo-1*) 'bar) ; is OK - - (setf (foo-x *foo-1*) 10) ; signals an error - ---- - There are fewer built-in classes. Specifically, only the following - Common Lisp types have classes: - - ARRAY BIT-VECTOR CHARACTER COMPLEX CONS FLOAT INTEGER LIST - NULL NUMBER RATIO RATIONAL SEQUENCE STRING SYMBOL T VECTOR - -* In a future release the subtypes of FLOAT may have classes, that issue - is still under discussion. - -* Some ports of PCL also define classes for: - - HASH-TABLE PACKAGE PATHNAME RANDOM-STATE READTABLE STREAM - - it depends on how the type is represented in that Lisp's type system. - - ---- - The with-slots option :use-slot-value is now obsolete. You should use - the :use-accessors option as specified in the CLOS spec instead. - - with-slot forms which did not use the :use-slot-value option are OK, - you don't have to touch them. - - with-slot forms which used :USE-SLOT-VALUE T should be changed to say - :USE-ACCESSORS NIL. - - with-slot forms which used :USE-SLOT-VALUE NIL should be changed to - use neither option, or if you insist :USE-ACCESSORS T - - - diff --git a/pcl/5-22-89-notes.text b/pcl/5-22-89-notes.text deleted file mode 100644 index 3f198d8a1..000000000 --- a/pcl/5-22-89-notes.text +++ /dev/null @@ -1,152 +0,0 @@ -Copyright (c) Xerox Corporation 1989. All rights reserved. - -These notes correspond to the "5/22/89 Victoria PCL" version of PCL. - -Please read this entire file carefully. Failure to do so guarantees -that you will have problems porting your code from the previous release -of PCL. - -You may also be interested in looking at previous versions of the -notes.text file. These are called xxx-notes.text where xxx is the -version of the PCL system the file corresponds to. At least the last -two versions of this file contain useful information for any PCL user. - -This version of PCL has been tested at PARC in the following Common -Lisps: - - Symbolics 7.2, 7.4 - Coral 1.2 - Lucid 3.0 - IBCL (October 15, 1987) - Allegro 3.0.1 - Golden Common Lisp 3.1 - EnvOS Medley - -These should work, but haven't been tested yet: - - TI - -This release is similar to Cinco de Mayo and Passover PCL. The major -difference is that this release actually works. - -*** - -*other-exports* flushed. More exports now on *exports* - -The symbol STANDARD is now exported from the PCL package. standard-class -standard-method standard-generic-function standard-object built-in-class -structure-class - -scoping problem with *next-methods* - - -method and generic function initialization protocol - -methods are immutable - -type-specifiers --> specializers - -load-truename etc. - -defgeneric ensure-generic-function define-method-combination - -metabraid changes - -file namings - -*** - -There are a number of minor and one major difference between this -release and No Cute Name PCL. - - -- In the last release there was an implementation of the specified CLOS -initialization protocol. This implementation had the correct behavior, -but some of the generic functions had temporary names (*make-instance, -*initialize-instance and *default-initargs). This was done to give -people time to convert their code to the behavior of the new -initialization protocol. - -In this release, all generic functions in the specified initialization -protocol have their proper names. The implementation of the old, -obsolete initialization protocol has disappeared entirely. - -The following renamings have happened: - - 12/7/88 release this release - - *make-instance make-instance - *initialize-instance initialize-instance - *default-initargs default-initargs - -The functions shared-initialize and reinitialize-instance already had -the proper names. - -The new initialization protocol is documented fully in the 88-002R -specification. - -As part of this change, PCL now uses the new initialization protocol to -create metaobjects internally. That is it calls make-instance to create -these metaobjects. The actual initargs passed are not yet as specified, -that will be in a later release. - -This is the largest change in this release. If you have not already -started using the new initialization protocol (with the temporary *xxx -names) you are going to have to do so now. In most cases, old methods -on the generic functions INITIALIZE, INITIALIZE-FROM-DEFAULTS and -INITIALIZE-FROM-INIT-PLIST must be substantially rewritten to convert -them to methods on INITIALIZE and SHARED-INITIALIZE. - -- slots with :ALLOCATION, :CLASS now inherit properly. As part of this -change, some slot description objects now return a class object as the -result of SLOTD-ALLOCATION. - -- There is now a minimal implementation of the DEFGENERIC macro. This -implementation supports no options, but it does allow you to define a -generic function in one place and put some comments there with it. - -- The following functions and macros have disappeared. This table also - show briefly what you use instead. - - DEFMETHOD-SETF (use DEFMETHOD) - RUN-SUPER (use CALL-NEXT-METHOD) - OBSOLETE-WITH-SLOTS (use WITH-SLOTS or WITH-ACCESSORS) - SYMBOL-CLASS (use FIND-CLASS) - CBOUNDP (use FIND-CLASS) - CLASS-NAMED (use FIND-CLASS) - GET-SETF-GENERIC-FUNCTION (use GDEFINITION) - -- In certain ports, method lookup will be faster because of a new scheme -to deal with interrupts and the cache code. In other ports it will be -slightly slower. In all ports, the cache code now interacts properly -with interrupts. - -- DEFMETHOD should interact properly with TRACE, ADVISE etc. in most -ports. two new port-specific functions (in defs.lisp) implement this. -These are unencapsulated-fdefinition and fdefine-carefully. If this -doesn't work properly in your port, fix the definition of these -functions and send it back so it can be in the next release. - -- This release runs in Golden Common Lisp version 3.0. - -- Previously, the use of slot-value (or with-slots) in the body of a -method which had an illegal specializer gave strange errors. Now it -gives a more reasonable error message. - -- An annoying problem which caused KCL and friends to complain about -*exports* being unbound has been fixed. - -- The walker has been modified to understand the ccl:%stack-block -special form in Coral Common Lisp. - -- The use of defadvice in pre 3.0 releases has been fixed in Lucid Low. - -- multiple-value-setq inside of with-slots now returns the correct -value. - -- A minor bug having to do with macroexpansion environments and the KCL -walker has been fixed. - -- A bug in the parsing of defmethod which caused only symbols (rather -than non-nil atoms) to be used as qualifiers. - diff --git a/pcl/8-28-88-notes.text b/pcl/8-28-88-notes.text deleted file mode 100644 index 854a90bcf..000000000 --- a/pcl/8-28-88-notes.text +++ /dev/null @@ -1,537 +0,0 @@ -Copyright (c) Xerox Corporation 1988. All rights reserved. - - -These notes correspond to the "8/24/88 (beta) AAAI PCL" version of PCL. - -Please read this entire document carefully. - -There have been a number of changes since the 8/2/88 version of PCL. As -usual, these changes are part of our efforts to make PCL conform with -the CLOS specicification (88-002R). This release contains the big -changes which the 7/7 through 8/2 releases were really getting ready -for. - -This version of PCL has been tested at PARC in the following Common -Lisps: - - Symbolics 7.2 - Coral 1.2 - Lucid 3.0 - Franz ?? - Xerox Lyric - Xerox Medley (aka EnvOS Medley) - KCL (October 15, 1987) - - -Most of the changes in this version of PCL fall into one of two -categories. - -The first major set of changes makes the order of arguments to setf -generic functions and methods conform with the spec. In addition, these -changes allow the first argument to defmethod to be of the form (SETF -<symbol>). - -The second major set of changes have to do with slot access and instance -structure. Importantly, PCL now checks to see if a slot is bound, and -calls slot-unbound if the slot is unbound. This is a major change from -previous releases in which slot access just returned NIL for slots which -had not yet been set. These changes affect all the functions which -access the slots of an instance. In addition, the generic functions -which are called by the slot access functions in exceptional -circumstances are affected. This set of changes also include the -implemenentation of the real initialization protocol as specified by -88-002R. - -In addition, there are a number of other changes. The most significant -of these has to do with the symbols which the PCL package exports by -default. - -The rest of this document goes on to first describe the slot access -changes, then describe the setf generic function changes, and finally -describe some of the other minor changes. - -At the very end of this file is a new section which lists PCL features -which are scheduled to disappear in future releases. Please read this -section and take it to heart. This features will be disappearing. - - -*** Changes to slot access and instance structure *** - -This release includes a number of changes to the way slot access works -in PCL. Some of these changes are incompatible with old behavior. Code -which was written with the actual CLOS spec in mind should not be -affected by these incompatible changes, but some older code may be -affected. - -The basic thrust of the changes to slot access is to bring the following -functions and generic functions in line with the specification: - - slot-boundp - slot-exists-p - slot-makunbound - slot-missing - slot-unbound - slot-value - - slot-boundp-using-class - slot-exists-p-using-class - slot-makunbound-using-class - slot-value-using-class - - (setf slot-value) - (setf slot-value-using-class) - - change-class - make-instances-obsolete - - make-instance (temporarily called *make-instance) - initialize-instance (temporarily called *initialize-instance) - reinitialize-instance - update-instance-for-different-class - update-instance-for-redefined-class - shared-initialize - -In this release, these functions accept the specified number of -arguments, return the specified values, have the specified effects, and -are called by the rest of PCL in the specified way at the specified -times (with the exception that PCL does not yet call *make-instance to -create its own metaobjects). Because PCL now checks for unbound slots, -you may notice a slight performance degradation in certain applications. - -For complete information, you should of course see the CLOS specification. -The rest of this note is a short summary of how this new behavior is -different from the last release. - -- Dynamic slots are no longer supported. Various functions like - slot-value-always and remove-slot no longer exist. Also, - slot-value-using-class now only accepts the three arguments as - described in the spec. The two extra arguments having to do with - dynamic slots are no longer accepted. - - Shortly, we will release a metaclass which provides the now missing - dynamic slot behavior. - -- slot-missing now receives and accepts different arguments. - -- slot-unbound is now implemented, and is called at the appropriate - times. - -- the initialization protocol specified in 88-002R is now almost - completely implemented. The only difference is that the current - implementation does not currently check the validity of initargs. - So, no errors are signalled in improper initargs are supplied. - - Because of name conflicts with the two other initialization protocols - PCL currently supports, some of the specified initialization functions - do not have their proper name. The mapping between names in the - specification and names in this version of PCL is as follows: - - SPECIFIED IN PCL - - make-instance *make-instance - initialize-instance *initialize-instance - reinitialize-instance <has proper name> - update-instance-for-different-class <has proper name> - update-instance-for-redefined-class <has proper name> - shared-initialize <has proper name> - - - In a future release of PCL, these functions will have their proper - names, and all the old, obsolete initialization protocols will - disappear. - - Convert to using this new wonderful initialization protocol soon. - - Sometime soon we will release a version of PCL which does significant - optimization of calls to make-instance. This should speed up instance - creation dramatically, which should significantly improve the - performance of some programs. - -- The function all-slots no longer exists. There is a new generic - function called slots-to-inspect, which controls the default behavior - of describe. It also controls the default behavior of the inspector - in ports which have connected their inspectors to PCL. It specifies - which slots of a given class should be inspected. See the definition - in the file high.lisp for more. - -- the metaclass obsolete-class no longer exists. The mechanism by which - instances are marked as being obsolete is now internal, as described - in the spec. The generic-function make-instances-obsolete can be used - to force the instances of a class to go through the obsolete instance - update protocol (see update-instance-for-redefined-class). - -- all-std-class-readers-miss-1, a generic function which was part of - the database interface code I sent out a few weeks ago, has a slightly - different argument list. People using the code I sent out a few weeks - ago should replace the definition there with: - - (defmethod all-std-class-readers-miss-1 - ((class db-class) wrapper slot-name) - (declare (ignore wrapper slot-name)) - ()) - -- The implementation of the slot access generic functions have been - considerably streamlined. The impenetrable macrology which used to be - used is now gone. - -- Because the behavior of the underlying slot access generic functions - has changed, it is possible that some user code which hacks the - underlying instance structure may break. Most of this code shouldn't - break though. There have been some questions on the mailing list - about what is the right way to modify the structure of an instance. - I am working on that section of chapter 3 right now, and will answer - those questions sometime soon. - - -*** Changes to SETF generic functions *** - -This release of PCL includes a significant change related to the order -of arguments of setf generic functions. To most user programs, this -change should be invisible. Your program should run just fine in the -new version of PCL. Even so, there is some conversion you should do to -your program, since DEFMETHOD-SETF is now obsolete and will be going -away soon. - -Some programs may take some work to adapt to this change. This will -be particularly true of programs which manipulated methods for setf -generic-functions using make-instance, add-method and friends. - -Included here is a brief overview of this change to PCL. Most people -will find that this is all they need to know about this change. - -The CLOS specification assumes a default behavior for SETF in the -absence of any defsetf or define-modify-macro. The default behavior is -to expand forms like: - - (SETF (FOO x y) a) - -into: - - (FUNCALL #'(SETF FOO) a x y) - -The key point is that by default, setf expands into a call to a function -with a well-defined name, and that in that call, the new value argument -comes before all the other arguments. - -This requires a change in PCL, because previously, PCL arranged for the -new-value argument to be the last required argument. This change -affects the way automatically generated writer methods work, and the way -that defmethod with a first argument of the form (SETF <symbol>) works. - -An important point is that I cannot implement function names of the form -(SETF <symbol>) portably in PCL. As a result, in PCL, I am using names -of the form |SETF FOO|. Note that the symbol |SETF FOO| is interned in -the home package of the symbol FOO. (See the description of the -GET-SETF-FUNCTION and GET-SETF-FUNCTION-NAME). - - -The user-visible changes are: - -- DEFMETHOD will accept lists of the form (SETF FOO) as a first - argument. This will define methods on the generic function named - by the symbol |SETF FOO|. As specified in the spec, these methods - should expect to receive the new-value as their first argument. - Calls to defmethod of this form will also arrange for SETF of FOO to - expand into an appropriate call to |SETF FOO|. - -- Automatically generated writer methods will expect to receive the new - value as their first argument. - -- DEFMETHOD-SETF will also place the new-value as the first argument. - This is for backward compatibility, since defmethod-setf itself will - be obsolete, and you should convert your code to stop using it. - -- GET-SETF-FUNCTION is a function which takes a function name and - returns the setf function for that function if there is one. Note - that it doesn't take an environment argument. Note that this function - is not specified in Common Lisp or CLOS. PCL will continue to support - it as an extra export indefinetely. - -- GET-SETF-FUNCTION-NAME is a function which takes a function name - and returns the symbol which names the setf function for that - function. Note that this function is not specified in Common Lisp - or CLOS. PCL will continue to support it as an extra export - indefinetely. - -- For convenience, PCL defines a macro called DO-STANDARD-DEFSETF which - can be used to do the appropriate defsetf. This may be helpful for - programs which have calls to setf of a generic-function before any - of the generic function's method definitions. A use of this macro - looks like: - - (do-standard-defsetf position-x) - - Afterwards, a form like (SETF (POSITION-X P) V) will expand into a - form like (|SETF POSITION-X| V P). - - The reason you may have to use do-standard-defsetf is that I cannot - portably change every implementations SETF to have the new default - behavior. The proper way to use this is to take an early file in - your system, and put a bunch of calls to do-standard-defsetf in it. - Note that as soon as PCL sees a defmethod with a name argument of - the form (SETF FOO), or it sees a :accessor in a defclass, it will - do an appropriate do-standard-defsetf for you. - - -In summary, the only things that will need to be changed in most -programs is that uses of defmethod-setf should be converted to -appropriate uses of defmethod. - -Here is an example of a typical user program which is affected by this -change. - -(defclass position () - ((x :initform 0 :accessor pos-x) - (y :initform 0 :accessor pos-y))) - -(defclass monitored-position (position) - ()) - -(defmethod-setf pos-x :before ((p monitored-position)) (new) - (format *trace-output* "~&Changing x coord of ~S to ~D." p new)) - -(defmethod-setf pos-y :before ((p monitored-position)) (new) - (format *trace-output* "~&Changing y coord of ~S to ~D." p new)) - - -To bring this program up to date, you should convert the two -defmethod-setf forms as follows: - -(defmethod (setf pos-x) :before (new (p monitored-position)) - (format *trace-output* "~&Changing x coord of ~S to ~D." p new)) - -(defmethod (setf pos-y) :before (new (p monitored-position)) - (format *trace-output* "~&Changing y coord of ~S to ~D." p new)) - - -*** Other changes in this release *** - -* The symbols exported by the PCL package have now changed. The PCL -package now exports the symbols listed in the table of contents of -chapter 2 of the spec. This list of symbols is the value of the -variable pcl::*exports*. - -Following is the list of symbols which were exported in the 8/2/88 -version but which are not exported in the 8/18/88 version. - -DEFMETHOD-SETF DEFGENERIC-OPTIONS DEFGENERIC-OPTIONS-SETF -CLASS-CHANGED CLASS-NAMED SYMBOL-CLASS -CBOUNDP GET-METHOD GET-SETF-GENERIC-FUNCTION -MAKE-METHOD-CALL - -Following is the list of symbols which are exported in the 8/18/88 -version, but which were not exported in previous versions: - -CALL-METHOD CLASS-NAME COMPUTE-APPLICABLE-METHODS -DEFGENERIC ENSURE-GENERIC-FUNCTION FIND-METHOD -FUNCTION-KEYWORDS GENERIC-FLET GENERIC-LABELS -INITIALIZE-INSTANCE MAKE-INSTANCES-OBSOLETE NO-APPLICABLE-METHOD -NO-NEXT-METHOD REINITIALIZE-INSTANCE SHARED-INITIALIZE -SLOT-BOUNDP SLOT-EXISTS-P SLOT-MAKUNBOUND -SLOT-MISSING SLOT-UNBOUND SYMBOL-MACROLET -UPDATE-INSTANCE-FOR-DIFFERENT-CLASS -UPDATE-INSTANCE-FOR-REDEFINED-CLASS -WITH-ADDED-METHODS - -It should be noted that not all of these newly exported symbols have -been "implemented" yet. - - -* Any program written using PCL will need to be completely recompiled -to run with this release of PCL. - -* The generic-function generic-function-pretty-arglist now returns a -nice arglist for any generic function. It combines all the keyword -arguments accepted by the methods to get the combined set of keywords. -In some ports, the environment specific ARGLIST function has been -connected to this, and so the environments will print out nice arglists -for generic functions. - -* Some bugs in trace-method have been fixed. Trace-method should now -work in all ports of PCL. - -* NO-MATCHING-METHOD has been renamed to NO-APPLICABLE-METHOD. In -addition, it now receives arguments as specified. - -* defmethod has been modified to allow macros which expand into -declarations. - -* The :documentation slot option is now accepted in defclass forms. The -documentation string put here cannot yet be retrieved using the -documentation function. That will happen in a later release. - -* The :writer slot option is now implemented. - -* Some brain damage in high.lisp which caused method lookup to work -incorrectly for built in classes. In addition, it caused the -class-local-supers and class-direct-subclasses of the built in classes -to be strange. People using CLOS browsers should notice this change -dramatically, as it will make the browse of the built in part of the -class lattice look right. - - -*** Older Changes *** - -Following are changes which appeared in release of PCL from 7/7/88 to -8/2/88. Each change is marked with the release it appeared in. - - - -8/2/88 -Loading defclass forms should be much faster now. The bug which caused -all the generic functions in the world to be invalidated whenever a -class was defined has now been fixed. - -Loading defmethod forms should also be much faster. A bug which caused -a tremendous amount of needles computation whenever a method was also -fixed. - - - -8/2/88 -A bug which caused several slots of the classes T, OBJECT, CLASS and -STANDARD-CLASS to be unbound has been fixed. - - - -8/1/88 -load-pcl now adds the symbols :PCL and :PORTABLE-COMMONLOOPS to -*features*. - -PCL still doesn't do any sort of call to PROVIDE because of the total -lack of uniformity in the behavior of require and provide in the various -common lisp implementations. - - -8/1/88 -This version of PCL finally fixes the horrible bug that prevented -the initform for :class allocation slots from being evaluated when the -class was defined. - - -7/20/88 -PCL now converts the function describe into a generic function of one -argument. This is to bring it into conformance with the spec as -described in 88-002. - -In Symbolics Genera, it is actually a function of one required and one -optional argument. This is because the 3600 sometimes calls describe -with more than one argument. - -In Lucid Lisp, describe only takes an optional argument. This argument -defaults to the value of *. PCL converts describe to a generic function -of one required argument so it is not possible to call describe with -only one argument. - - -7/7/88 -class-named and symbol-class have been replaced by find-class. -find-class is documented in 88-002R. - - -7/7/88 -with-slots and with-accessors now conform to 88-002R. - -The old definition of with-slots is now called obsolete-with-slots. The -same is true for with-accessors. - - with-slots ---> obsolete-with-slots - with-accessors --> obsolete-with-accessors - -The temporary correct definition of with-slots, with-slots* is now -called with-slots. The same is true for with-accessors*. - - with-slots* --> with-slots - with-accessors* -> with-accessors - - -7/7/88 -The class-precedence list of the class null now conforms to 88-002R. - -In previous releases of PCL, the class precedence-list of the class -null was: (null list symbol sequence t). In this release the class -precedence list of the class null is: (null symbol list sequence t). - -This change was made to bring PCL into conformance with the spec. - - - -7/7/88 - -print-object now takes only two arguments. - -This changes was made to begin bringing print-object in conformance with -88-002R. print-object conforms to the spec to the extent that is is -called at the approrpiate times for PCL instances. In most -implementations, it is not called at the appropriate times for other -instances. This is not under my control, encourage your vendor to -provide the proper support for print-object. - - -7/7/88 -This version of PCL now includes a beta test version of a new iteration -package. This iteration package was designed by Pavel Curtis and -implemented by Bill vanMelle. This iteration package is defined in the -file iterate.lisp. Please feel free to experiment with it. We are all -very interested in comments on its use. - - - -*** PCL Features that will be disappearing *** - -This section describes features in PCL that will be disappearing in -future releases. For each change, I try to give a release date after -which I will feel free to remove this feature. This list should not be -considered complete. Certain other PCL features will disappear as well. -The items on this list are the user-interface level items that it is -possible to give a lot of warning about. Other changes will have more -subtle effects, for example when the lambda-list congruence rules are -implemented. - -- :accessor-prefix in defclass - -Can disappear anytime after 8/29. - -Warning that this is obsolete has been out for some time. You should -use :accessor in each of the slot specifications of the defclass form. -It is true that this is slightly more cumbersome, but the semantic -difficulties associated with :accesor-prefix are even worse. - -- :constructor in defclass - -Can disappear anytime after 8/29. - -Warning that this is obsolete has been out for some time. It will be -disappearing shortly because the intialization protocol which it goes -with will be disappearing. A future release of PCL will support a -special mechanism for defining functions of the form: - -(defun make-foo (x y &optional z) - (make-instance 'foo 'x x :y y :z z)) - -In the case where there are only :after methods on initialize-instance -and shared-initialize, these functions will run like the wind. We hope -to release this facility by 9/15. - -- old definition of make-instance, intialize, initialize-from-defaults, - initialize-from-init-plist - -Can disappear anytime after 8/29. - -Convert to using the new initialization protocol as described in the -spec and above. - -- mki, old definition of initialize-instance - -Can disappear anytime after 8/29. - -Convert to using the new initialization protocol as described in the -spec and above. - -- defmethod-setf - -Can disappear anytime after 9/15. - -Convert to using (defmethod (setf foo) ... - - diff --git a/pcl/bench.lisp b/pcl/bench.lisp deleted file mode 100644 index bc92fc57b..000000000 --- a/pcl/bench.lisp +++ /dev/null @@ -1,458 +0,0 @@ -;;;-*- Mode: Lisp; Syntax: Common-lisp; Package: user -*- - -;;;Here are a few homebrew benchmarks for testing out Lisp performance. -;;; BENCH-THIS-LISP: benchmarks for common lisp. -;;; BENCH-THIS-CLOS: benchmarks for CLOS. -;;; BENCH-FLAVORS: ditto for Symbolics flavors. -;;; BE SURE TO CHANGE THE PACKAGE DEFINITION TO GET THE CLOS + LISP YOU WANT TO TEST. -;;; -;;;Each benchmark is reported as operations per second. Without-interrupts is used, -;;; so the scheduler isn't supposed to get in the way. Accuracy is generally -;;; between one and five percent. -;;; -;;;Elapsed time is measured using get-internal-run-time. Because the accuracy of -;;; this number is fairly crude, it is important to use a large number of -;;; iterations to get an accurate benchmark. The function median-time may -;;; complain to you if you didn't pick enough iterations. -;;; -;;;July 1992. Watch out! In some cases the instruction being timed will be -;;; optimized away by a clever compiler. Beware of benchmarks that are -;;; nearly as fast as *speed-of-empty-loop*. -;;; -;;;Thanks to Ken Anderson for much of this code. -;;; -;;; jeff morrill -;;; jmorrill@bbn.com - -(eval-when (:compile-toplevel :load-toplevel :execute) - (import '(pcl:allocate-instance))) - -(declaim (optimize (speed 3) (safety 3 #+nil 1) (space 0) - #+lucid (compilation-speed 0))) - -;;;********************************************************************* - -(declaim (single-float *min-time*)) -(defvar *min-time* (/ 500 (float internal-time-units-per-second)) - "At least 2 orders of magnitude larger than our time resolution.") - -(defmacro elapsed-time (form) - "Returns (1) the result of form and (2) the time (seconds) it takes to evaluate form." - ;; Note that this function is completely portable. - (let ((start-time (gensym)) (end-time (gensym))) - `(let ((,start-time (get-internal-run-time))) - (declare (type (unsigned-byte 31) ,start-time)) - (values ,form - (let ((,end-time (get-internal-run-time))) - (declare (type (unsigned-byte 31) ,end-time)) - (/ (abs (- ,end-time ,start-time)) - ,(float internal-time-units-per-second))))))) - -(defmacro without-interruption (&body forms) - #+genera `(scl:without-interrupts ,@forms) - #+lucid `(lcl::with-scheduling-inhibited ,@forms) - #+allegro `(excl:without-interrupts ,@forms) - #+(and (not genera) (not lucid) (not allegro)) `(progn ,@forms)) - -(defmacro median-time (form &optional (I 5)) - "Return the median time it takes to evaluate form." - ;; I: number of samples to take. - `(without-interruption - (let ((results nil)) - (dotimes (ignore ,I) - (declare (fixnum ignore)) - (multiple-value-bind (ignore time) (elapsed-time ,form) - (declare (ignore ignore) - (single-float time)) - (if (< time *min-time*) - (format t "~% Warning. Evaluating ~S took only ~S seconds.~ - ~% You should probably use more iterations." ',form time)) - (push time results))) - (nth ,(truncate I 2) (sort results #'<))))) - -#+debug -(defun test () (median-time (sleep 1.0))) - -;;;********************************************************************* - -;;;OPERATIONS-PER-SECOND actually does the work of computing a benchmark. The amount -;;; of time it takes to execute the form N times is recorded, minus the time it -;;; takes to execute the empty loop. OP/S = N/time. This quantity is recomputed -;;; five times and the median value is returned. Variance in the numbers increases -;;; when memory is being allocated (cons, make-instance, etc). - -(defmacro repeat (form N) - ;; Minimal loop - (let ((count (gensym)) (result (gensym))) - `(let ((,count ,N) ,result) - (declare (fixnum ,count)) - (loop - ;; If you don't use the setq, the compiler may decide that since the - ;; result is ignored, FORM can be "compiled out" of the loop. - (setq ,result ,form) - (if (zerop (decf ,count)) (return ,result)))))) - -(defun nempty (N) - (declare (fixnum N)) - "The empty loop." - (repeat nil N)) - -(defun empty-speed (N) (median-time (nempty N))) - -(defun compute-empty-iterations (&optional (default 1000000)) - (format t "~%Computing speed of empty loop...") - (let ((time 0.0)) - (declare (single-float time)) - (loop - (setq time (empty-speed default)) - (if (< time *min-time*) (setq default (* default 10)) (return))) - (format t "done.") - default)) - -(declaim (fixnum *empty-iterations*)) -(defvar *empty-iterations*) -(declaim (single-float *speed-of-empty-loop*)) -(defvar *speed-of-empty-loop*) - -(eval-when (:load-toplevel :execute) - (setq *empty-iterations* (compute-empty-iterations)) - (setq *speed-of-empty-loop* (/ (empty-speed *empty-iterations*) - (float *empty-iterations*)))) - -(defmacro operations-per-second (form N &optional (I 5)) - "Return the number of times FORM can evaluate in one second." - `(let ((time (median-time (repeat ,form ,N) ,I))) - (declare (single-float time) - (fixnum ,N)) - (/ (float ,N) (- time (* *speed-of-empty-loop* ,N))))) - -(defmacro bench (pretty-name name N &optional (stream t)) - `(format ,stream "~%~A: ~30T~S" ,pretty-name (,name ,N))) - -;;;**************************************************************************** - -;;;BENCH-THIS-LISP - -(defun Nmult (N) - (let ((a 2.1)) - (operations-per-second (* a a) N))) - -(defun Nadd (N) - (let ((a 2.1)) - (operations-per-second (+ a a) N))) - -(defun square (x) (* x x)) - -(defun funcall-1 (N) - ;; inlined - (let ((x 2.1)) - (operations-per-second (funcall #'(lambda (a) (* a a)) x) N))) - -(defun f1 (n) n) - -(defun funcall-2 (N) - (let ((f #'f1) - (x 2.1)) - (operations-per-second (funcall f x) N))) - -(defun funcall-3 (N) - (let ((x 2.1)) - (operations-per-second (f1 x) N))) - -(defun funcall-4 (N) - (let ((x 2.1)) - (operations-per-second (funcall #'square x) N))) - -(defun funcall-5 (N) - (let ((x 2.1) - (f #'square)) - (let ((g #'(lambda (x) - (operations-per-second (funcall f x) N)))) - (funcall g x)))) - -(defun Nsetf (N) - (let ((array (make-array 15))) - (operations-per-second (setf (aref array 5) t) N))) - -(defun Nsymeval (N) (operations-per-second (eval T) N)) - -(defun Repeatuations (N) (operations-per-second (eval '(* 2.1 2.1)) N)) - -(defun n-cons (N) (let ((a 1)) (operations-per-second (cons a a) N))) - -(defvar *object* t) -(Defun nspecial (N) (operations-per-second (null *object*) N)) - -(defun nlexical (N) - (let ((o t)) - (operations-per-second (null o) N))) - -(defun nfree (N) - (let ((o t)) - (let ((g #'(lambda () - #+genera (declare (sys:downward-function)) - (operations-per-second (null o) N)))) - (funcall g)))) - -(defun nfree2 (N) - (let ((o t)) - (let ((g #'(lambda () - (let ((f #'(lambda () - #+genera (declare (sys:downward-function)) - (operations-per-second (null o) N)))) - (funcall f))))) - (funcall g)))) - -(defun ncompilations (N) - (let ((lambda-expression - '(lambda (bar) (let ((baz t)) (if baz (cons bar nil)))))) - (operations-per-second (compile 'bob lambda-expression) N))) - -(defun bench-this-lisp () - (let ((N (/ *empty-iterations* 10))) - (bench "(* 2.1 2.1)" nmult N) - (bench "(+ 2.1 2.1)" nadd N) - (bench "funcall & (* 2.1 2.1)" funcall-3 N) - (bench "special reference" nspecial *empty-iterations*) - (bench "lexical reference" nlexical *empty-iterations*) - ;; (bench "ivar reference" n-ivar-ref N) - (bench "(setf (aref array 5) t)" nsetf N) - (bench "(funcall lexical-f x)" funcall-2 N) - (bench "(f x)" funcall-3 N) - ;; (Bench "(eval t)" nsymeval 10000) - ;; (bench "(eval '(* 2.1 2.1))" repeatuations 10000) - ;; (bench "(cons 1 2)" n-cons 100000) - ;; (bench "compile simple function" ncompilations 50) - )) - -;(bench-this-lisp) - -;;;************************************************************** - -#+genera -(progn - -(scl:defflavor bar (a b) () - :initable-instance-variables - :writable-instance-variables) - -(scl:defflavor frob (c) (bar) - :initable-instance-variables - :writable-instance-variables) - -(scl:defmethod (hop bar) () - a) - -(scl:defmethod (set-hop bar) (n) - (setq a n)) - -(scl:defmethod (nohop bar) () - 5) - -(defun n-ivar-ref (N) - (let ((i (scl:make-instance 'bar :a 0 :b 0))) - (ivar-ref i N))) - -(scl:defmethod (ivar-ref bar) (N) - (operations-per-second b N)) - - -(defun Ninstances (N) (operations-per-second (flavor:make-instance 'bar) N)) - -(defun n-svref (N) - (let ((instance (flavor:make-instance 'bar :a 1))) - (operations-per-second (scl:symbol-value-in-instance instance 'a) N))) -(defun n-hop (N) - (let ((instance (flavor:make-instance 'bar :a 1))) - (operations-per-second (hop instance) n))) -(defun n-gf (N) - (let ((instance (flavor:make-instance 'bar :a 1))) - (operations-per-second (nohop instance) n))) -(defun n-set-hop (N) - (let ((instance (flavor:make-instance 'bar :a 1))) - (operations-per-second (set-hop instance) n))) -(defun n-type-of (N) - (let ((instance (flavor:make-instance 'bar))) - (operations-per-second (flavor::%instance-flavor instance) N))) - -(defun n-bar-b (N) - (let ((instance (flavor:make-instance 'bar :a 0 :b 0))) - (operations-per-second (bar-b instance) N))) - -(defun n-frob-bar-b (N) - (let ((instance (flavor:make-instance 'frob :a 0 :b 0))) - (operations-per-second (bar-b instance) N))) - -(defun bench-flavors () - (bench "flavor:make-instance (2 slots)" ninstances 5000) - (bench "flavor:symbol-value-in-instance" n-svref 100000) - (bench "1 method, 1 dispatch" n-gf 100000) - (bench "slot symbol in method (access)" n-hop 100000) - (bench "slot symbol in method (modify)" n-hop 100000) - (bench "slot accessor bar" n-bar-b 100000) - (bench "slot accessor frob" n-frob-bar-b 100000) - (bench "instance-flavor" n-type-of 500000)) - -) ; end of #+genera - -;;;************************************************************** - -;;;BENCH-THIS-CLOS -;;; (evolved from Ken Anderson's tests of Symbolics CLOS) - -(defmethod strange ((x t)) t) ; default method -(defmethod area ((x number)) 'green) ; builtin class - -(defclass point - () - ((x :initform 0 :accessor x :initarg :x) - (y :initform 0 :accessor y :initarg :y))) - -(defmethod color ((thing point)) 'red) -(defmethod address ((thing point)) 'boston) -(defmethod area ((thing point)) 0) -(defmethod move-to ((p1 point) (p2 point)) 0) - -(defmethod x-offset ((thing point)) - (with-slots (x y) thing x)) - -(defmethod set-x-offset ((thing point) new-x) - (with-slots (x y) thing (setq x new-x))) - -(defclass box - (point) - ((width :initform 10 :accessor width :initarg :width) - (height :initform 10 :accessor height :initarg :height))) - -(defmethod area ((thing box)) 0) -(defmethod move-to ((box box) (point point)) 0) -(defmethod address :around ((thing box)) (call-next-method)) - -(defvar p (make-instance 'point)) -(defvar b (make-instance 'box)) - -(defun n-strange (N) (operations-per-second (strange 5) N)) -(defun n-accesses (N) - (let ((instance p)) - (operations-per-second (x instance) N))) -(defun n-color (N) - (let ((instance p)) - (operations-per-second (color instance) n))) -(defun n-call-next-method (N) - (let ((instance b)) - (operations-per-second (address instance) n))) -(defun n-area-1 (N) - (let ((instance p)) - (operations-per-second (area instance) n))) -(defun n-area-2 (N) - (operations-per-second (area 5) n)) -(defun n-move-1 (N) - (let ((instance p)) - (operations-per-second (move-to instance instance) n))) -(defun n-move-2 (N) - (let ((x p) (y b)) - (operations-per-second (move-to x y) n))) -(defun n-off (N) - (let ((instance p)) - (operations-per-second (x-offset instance) n))) -(defun n-setoff (N) - (let ((instance p)) - (operations-per-second (set-x-offset instance 500) n))) -(defun n-slot-value (N) - (let ((instance p)) - (operations-per-second (slot-value instance 'x) n))) - -(defun n-class-of-1 (N) - (let ((instance p)) - (operations-per-second (class-of instance) n))) -(defun n-class-of-2 (N) - (operations-per-second (class-of 5) n)) - -(defun n-alloc (N) - (let ((c (pcl:find-class 'point))) - (operations-per-second (allocate-instance c) n))) - -(defun n-make (N) - (operations-per-second (make-instance 'point) n)) - -(defun n-make-initargs (N) - ;; Much slower than n-make! - (operations-per-second (make-instance 'point :x 0 :y 5) n)) - -(defun n-make-variable-initargs (N) - ;; Much slower than n-make! - (let ((x 0) - (y 5)) - (operations-per-second (make-instance 'point :x x :y y) n))) - -(pcl::expanding-make-instance-top-level - -(defun n-make1 (N) - (operations-per-second (make-instance 'point) n)) - -(defun n-make-initargs1 (N) - ;; Much slower than n-make! - (operations-per-second (make-instance 'point :x 0 :y 5) n)) - -(defun n-make-variable-initargs1 (N) - ;; Much slower than n-make! - (let ((x 0) - (y 5)) - (operations-per-second (make-instance 'point :x x :y y) n))) - -) - -(pcl::precompile-random-code-segments) - -(defun bench-this-clos () - (let ((N (/ *empty-iterations* 10))) - (bench "1 default method" n-strange (* N 2)) - (bench "1 dispatch, 1 method" n-color N) - (bench "1 dispatch, :around + primary" n-call-next-method N) - (bench "1 dispatch, 3 methods, instance" n-area-1 N) - (bench "1 dispatch, 3 methods, noninstance" n-area-2 N) - (bench "2 dispatch, 2 methods" n-move-1 N) - (bench "slot reader method" n-accesses N) - (bench "with-slots (1 access)" n-off N) - (bench "with-slots (1 modify)" n-setoff N) - (bench "naked slot-value" n-slot-value N) - (bench "class-of instance" n-class-of-1 (* N 5)) - (bench "class-of noninstance" n-class-of-2 (* N 5)) - (bench "allocate-instance (2 slots)" n-alloc - #+pcl 1000000 - #+allegro 100000 - #+(and Genera (not pcl)) 100000 - #+(and Lucid (not pcl)) 10000) - (bench "make-instance (2 slots)" n-make - #+pcl 200000 - #+allegro 100000 - #+(and Genera (not pcl)) 100000 - #+(and Lucid (not pcl)) 10000) - (bench "make-instance (2 constant initargs)" n-make-initargs - #+pcl 100000 - #+allegro 100000 - #+(and Genera (not pcl)) 100000 - #+(and Lucid (not pcl)) 10000) - (bench "make-instance (2 variable initargs)" n-make-variable-initargs - #+pcl 100000 - #+allegro 100000 - #+(and Genera (not pcl)) 100000 - #+(and Lucid (not pcl)) 10000) - - (bench "make-instance (2 slots)" n-make1 - #+pcl 100000 - #+allegro 100000 - #+(and Genera (not pcl)) 100000 - #+(and Lucid (not pcl)) 10000) - (bench "make-instance (2 constant initargs)" n-make-initargs1 - #+pcl 100000 - #+allegro 100000 - #+(and Genera (not pcl)) 100000 - #+(and Lucid (not pcl)) 10000) - (bench "make-instance (2 variable initargs)" n-make-variable-initargs1 - #+pcl 100000 - #+allegro 100000 - #+(and Genera (not pcl)) 100000 - #+(and Lucid (not pcl)) 10000)) ) - -;(bench-this-clos) diff --git a/pcl/boot.lisp b/pcl/boot.lisp index bedec83ed..2d3f8b589 100644 --- a/pcl/boot.lisp +++ b/pcl/boot.lisp @@ -23,10 +23,9 @@ ;;; ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* -;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/boot.lisp,v 1.47 2003/02/10 13:46:19 gerd Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/boot.lisp,v 1.48 2003/03/22 16:15:18 gerd Exp $") (in-package :pcl) @@ -85,8 +84,7 @@ work during bootstrapping. '((make-a-method early-make-a-method real-make-a-method) (add-named-method early-add-named-method - real-add-named-method) - )) + real-add-named-method))) ;;; ;;; For each of the early functions, arrange to have it point to its early @@ -98,20 +96,20 @@ work during bootstrapping. ;;; a separate piece of code because of a bug in ExCL which causes this not ;;; to work if it is inlined. ;;; +#-loadable-pcl (eval-when (:load-toplevel :execute) -(defun redirect-early-function-internal (real early) - (setf (gdefinition real) - (set-function-name - (lambda (&rest args) - (apply (the function (symbol-function early)) args)) - real))) - -(dolist (fns *early-functions*) - (let ((name (car fns)) - (early-name (cadr fns))) - (redirect-early-function-internal name early-name))) - + (defun redirect-early-function-internal (real early) + (setf (gdefinition real) + (set-function-name + (lambda (&rest args) + (apply (the function (symbol-function early)) args)) + real))) + + (dolist (fns *early-functions*) + (let ((name (car fns)) + (early-name (cadr fns))) + (redirect-early-function-internal name early-name))) ) @@ -191,33 +189,36 @@ work during bootstrapping. (declare (ignore restp rest keyp aux allow-other-keys-p more-context more-count)) (labels ((lambda-list-error (format-control &rest format-arguments) - (simple-program-error "Generic function ~A:~%~?" - function-specifier - format-control format-arguments)) + (simple-program-error + (format nil "~~@<Generic function ~a: ~?.~~@:>" + function-specifier + format-control format-arguments))) (check-required-parameter (parameter) (unless (symbolp parameter) (lambda-list-error - "Invalid generic function parameter name ~A" + "Invalid generic function parameter name ~a" parameter))) (check-key-or-optional-parameter (parameter) (unless (or (symbolp parameter) (and (consp parameter) (symbolp (car parameter)))) (lambda-list-error - "Invalid generic function parameter name: ~A" + "Invalid generic function parameter name ~a" parameter)) (when (and (consp parameter) (not (null (cdr parameter)))) (lambda-list-error - "Optional and key parameters of generic functions~%~ + "Optional and key parameters of generic functions ~ may not have default values or supplied-p ~ - parameters: ~A" parameter)))) + parameters: ~<~s~>" parameter)))) (when morep (lambda-list-error - "&MORE not allowed in generic function lambda lists")) + "~s is not allowed in generic function lambda lists" + '&more)) (when auxp (lambda-list-error - "&AUX not allowed in generic function lambda lists")) + "~s is not allowed in generic function lambda lists" + '&aux)) (mapc #'check-required-parameter required) (mapc #'check-key-or-optional-parameter optional) (mapc #'check-key-or-optional-parameter keys)))) @@ -229,9 +230,14 @@ work during bootstrapping. (defun expand-defgeneric (function-specifier lambda-list options) (let ((initargs ()) (methods ())) - (labels ((duplicate-option (name) - (simple-program-error "The option ~S appears more than once." - name)) + (labels ((loose (format-control &rest format-arguments) + (simple-program-error + (format nil "~~@<Generic function ~~s: ~?.~~@:>" + format-control format-arguments) + function-specifier)) + (duplicate-option (name) + (loose "The option ~s appears more than once" + name)) (check-declaration (declaration-specifiers) (loop for specifier in declaration-specifiers when (and (consp specifier) @@ -239,13 +245,17 @@ work during bootstrapping. '(special ftype function inline notinline declaration) :test #'eq)) do - (simple-program-error - "Declaration specifier ~S is not allowed" - specifier))) + (loose "Declaration specifier ~s is not allowed" + specifier))) (initarg (key &optional (new nil new-supplied-p)) (if new-supplied-p (setf (getf initargs key) new) (getf initargs key)))) + + (when (and (symbolp function-specifier) + (special-operator-p function-specifier)) + (loose "Special operators cannot be made generic functions")) + (dolist (option options) (case (car option) (:argument-precedence-order @@ -273,26 +283,38 @@ work during bootstrapping. (duplicate-option :method-class) (initarg :method-class `',(cadr option)))) (:method - (push `(defmethod ,function-specifier ,@(cdr option)) - methods)) - (t ;unsuported things must get a 'program-error - (simple-program-error "Unsupported option ~S." option)))) + (push `(push (defmethod ,function-specifier ,@(cdr option)) + (plist-value #',function-specifier + 'method-description-methods)) + methods)) + (t ;unsuported things must get a 'program-error + (loose "Unsupported option ~s" option)))) - (let ((declarations (initarg :declarations))) - (when declarations (initarg :declarations `',declarations)))) - - (tell-compiler-about-gf function-specifier lambda-list) + (let ((declarations (initarg :declarations))) + (when declarations (initarg :declarations `',declarations)))) + + (tell-compiler-about-gf function-specifier lambda-list) `(progn (proclaim-defgeneric ',function-specifier ',lambda-list) ,(make-top-level-form `(defgeneric ,function-specifier) - *defgeneric-times* + '(:load-toplevel :execute) `(load-defgeneric ',function-specifier ',lambda-list ,@initargs)) ,@methods `,(function ,function-specifier)))) (defun load-defgeneric (function-specifier lambda-list &rest initargs) + ;; + ;; Remove methods defined by a previous DEFGENERIC (CLHS 7.6.1). + (when (and (fboundp function-specifier) + (generic-function-p (gdefinition function-specifier))) + (loop with gf = (gdefinition function-specifier) + for method in (plist-value gf 'method-description-methods) do + (remove-method gf method) + finally + (setf (plist-value gf 'method-description-methods) nil))) + ;; (apply #'ensure-generic-function function-specifier :lambda-list lambda-list @@ -304,11 +326,7 @@ work during bootstrapping. ;;; ;;; ;;; -(defmacro DEFMETHOD (&rest args &environment env) - (declare (arglist name - {method-qualifier}* - specialized-lambda-list - &body body)) +(defmacro defmethod (&rest args &environment env) (multiple-value-bind (name qualifiers lambda-list body) (parse-defmethod args) (multiple-value-bind (proto-gf proto-method) @@ -355,46 +373,58 @@ work during bootstrapping. (find-class 'standard-method))))))) -(defvar *optimize-asv-funcall-p* nil) -(defvar *asv-readers*) -(defvar *asv-writers*) -(defvar *asv-boundps*) - -(defun expand-defmethod (name proto-gf proto-method qualifiers lambda-list body env) - (let ((*make-instance-function-keys* nil) - (*optimize-asv-funcall-p* t) - (*asv-readers* nil) (*asv-writers* nil) (*asv-boundps* nil)) - (declare (special *make-instance-function-keys*)) +(defvar *inline-access*) +(defvar *method-source-info*) + +(defun expand-defmethod (name proto-gf proto-method qualifiers + lambda-list body env) + (let ((*inline-access* ())) (multiple-value-bind (method-lambda unspecialized-lambda-list specializers) (add-method-declarations name qualifiers lambda-list body env) - (multiple-value-bind (method-function-lambda initargs) - (make-method-lambda proto-gf proto-method method-lambda env) - (let ((initargs-form (make-method-initargs-form - proto-gf proto-method - method-function-lambda initargs env))) - (tell-compiler-about-gf name lambda-list) - `(progn - (proclaim-defgeneric ',name ',lambda-list) - ,@(when *make-instance-function-keys* - `((get-make-instance-functions ',*make-instance-function-keys*))) - ,@(when (or *asv-readers* *asv-writers* *asv-boundps*) - `((initialize-internal-slot-gfs* - ',*asv-readers* ',*asv-writers* ',*asv-boundps*))) - ,(make-defmethod-form name qualifiers specializers - unspecialized-lambda-list - (if proto-method - (class-name (class-of proto-method)) - 'standard-method) - initargs-form - (getf (getf initargs :plist) - :pv-table-symbol)))))))) + + (let* ((auto-compile-p (auto-compile-p name qualifiers specializers)) + (*method-source-info* + (when (and auto-compile-p + (or (null env) + (and (null (c::lexenv-functions env)) + (null (c::lexenv-variables env))))) + (list (copy-tree body) lambda-list)))) + + (multiple-value-bind (method-function-lambda initargs) + (make-method-lambda proto-gf proto-method method-lambda env) + + (when (and *inline-access* + auto-compile-p + env + (or (c::lexenv-functions env) + (c::lexenv-variables env))) + (setq *method-source-info* nil) + (warn "~@<Defining method ~s ~s ~s using inline slot access in a ~ + non-null lexical environment means that it cannot be ~ + automatically recompiled.~@:>" + name qualifiers lambda-list)) + + (let ((initargs-form (make-method-initargs-form + proto-gf proto-method + method-function-lambda initargs env))) + (tell-compiler-about-gf name lambda-list) + `(progn + (proclaim-defgeneric ',name ',lambda-list) + ,(make-defmethod-form name qualifiers specializers + unspecialized-lambda-list + (if proto-method + (class-name (class-of proto-method)) + 'standard-method) + initargs-form + (getf (getf initargs :plist) + :pv-table-symbol))))))))) (defun interned-symbol-p (x) (and (symbolp x) (symbol-package x))) (defun make-defmethod-form (name qualifiers specializers - unspecialized-lambda-list method-class-name - initargs-form &optional pv-table-symbol) + unspecialized-lambda-list method-class-name + initargs-form &optional pv-table-symbol) (let (fn fn-lambda) (if (and (interned-symbol-p (if (consp name) (and (eq (car name) 'setf) (cadr name)) @@ -425,20 +455,18 @@ work during bootstrapping. specializers)) (mname `(,(if (eq (cadr initargs-form) :function) 'method 'fast-method) - ,name ,@qualifiers ,specls)) - (mname-sym (intern (let ((*print-pretty* nil)) - (format nil "~S" mname))))) - `(eval-when ,*defmethod-times* - (defun ,mname-sym ,(cadr fn-lambda) - ,@(cddr fn-lambda)) - ,(make-defmethod-form-internal - name qualifiers `',specls - unspecialized-lambda-list method-class-name - `(list* ,(cadr initargs-form) #',mname-sym ,@(cdddr initargs-form)) - pv-table-symbol))) + ,name ,@qualifiers ,specls))) + `(eval-when (:load-toplevel :execute) + (defun ,mname ,(cadr fn-lambda) + ,@(cddr fn-lambda)) + ,(make-defmethod-form-internal + name qualifiers `',specls + unspecialized-lambda-list method-class-name + `(list* ,(cadr initargs-form) #',mname ,@(cdddr initargs-form)) + pv-table-symbol))) (make-top-level-form `(defmethod ,name ,@qualifiers ,specializers) - *defmethod-times* + '(:load-toplevel :execute) (make-defmethod-form-internal name qualifiers `(list ,@(mapcar (lambda (specializer) @@ -451,8 +479,9 @@ work during bootstrapping. pv-table-symbol))))) (defun make-defmethod-form-internal (name qualifiers specializers-form - unspecialized-lambda-list method-class-name - initargs-form &optional pv-table-symbol) + unspecialized-lambda-list + method-class-name initargs-form + &optional pv-table-symbol) `(load-defmethod ',method-class-name ',name @@ -462,7 +491,9 @@ work during bootstrapping. ,initargs-form ;;Paper over a bug in KCL by passing the cache-symbol ;;here in addition to in the list. - ',pv-table-symbol)) + ',pv-table-symbol + ',*inline-access* + ',(when *inline-access* *method-source-info*))) (defmacro make-method-function (method-lambda &environment env) (make-method-function-internal method-lambda env)) @@ -489,26 +520,44 @@ work during bootstrapping. ,@real-body) unspecialized-lambda-list specializers)))) +#+loadable-pcl +(defmethod make-method-initargs-form ((proto-gf standard-generic-function) + (proto-mothed standard-method) + method-lambda initargs env) + (unless (and (consp method-lambda) (eq (car method-lambda) 'lambda)) + (error "The method-lambda argument to make-method-function, ~S,~ + is not a lambda form" method-lambda)) + (make-method-initargs-form-internal method-lambda initargs env)) + +#-loadable-pcl (defun real-make-method-initargs-form (proto-gf proto-method method-lambda initargs env) (declare (ignore proto-gf proto-method)) (unless (and (consp method-lambda) (eq (car method-lambda) 'lambda)) - (error "The method-lambda argument to make-method-function, ~S,~ - is not a lambda form" method-lambda)) + (error "~@<The ~s argument to ~s, ~s, is not a lambda form.~@:>" + 'method-lambda 'make-method-lambda method-lambda)) (make-method-initargs-form-internal method-lambda initargs env)) +#-loadable-pcl (unless (fboundp 'make-method-initargs-form) (setf (gdefinition 'make-method-initargs-form) (symbol-function 'real-make-method-initargs-form))) +#+loadable-pcl +(defmethod make-method-lambda ((proto-gf standard-generic-function) + (proto-method standard-method) + method-lambda env) + (make-method-lambda-internal method-lambda env)) + +#-loadable-pcl (defun real-make-method-lambda (proto-gf proto-method method-lambda env) (declare (ignore proto-gf proto-method)) (make-method-lambda-internal method-lambda env)) (defun make-method-lambda-internal (method-lambda &optional env) (unless (and (consp method-lambda) (eq (car method-lambda) 'lambda)) - (error "The method-lambda argument to make-method-lambda, ~S,~ - is not a lambda form" method-lambda)) + (error "~@<The ~s argument to ~s, ~s, is not a lambda form.~@:>" + 'method-lambda 'make-method-lambda method-lambda)) (multiple-value-bind (real-body declarations documentation) (system:parse-body (cddr method-lambda) env) (let* ((name-decl (get-declaration 'method-name declarations)) @@ -522,10 +571,6 @@ work during bootstrapping. (mapcar (lambda (r s) (declare (ignore s)) r) parameters specializers)) - (specialized-parameters - (loop for s in specialized-lambda-list - for p in required-parameters - when (listp s) collect p)) (slots (mapcar #'list required-parameters)) (calls (list nil)) (class-declarations @@ -535,6 +580,8 @@ work during bootstrapping. (list `(class ,a ,s)))) parameters specializers))) + (block-name (nth-value 1 (ext:valid-function-name-p + generic-function-name))) (method-lambda ;; Remove the documentation string and insert the ;; appropriate class declarations. The documentation @@ -544,12 +591,10 @@ work during bootstrapping. ;; are inserted to communicate the class of the method's ;; arguments to the code walk. `(lambda ,lambda-list - (declare (ignorable ,@specialized-parameters)) + (declare (ignorable ,@required-parameters)) ,class-declarations ,@declarations - (block ,(if (listp generic-function-name) - (cadr generic-function-name) - generic-function-name) + (block ,block-name ,@real-body))) (constant-value-p (and (null (cdr real-body)) (constantp (car real-body)))) @@ -561,46 +606,78 @@ work during bootstrapping. (symbol-package constant-value)))) (list :constant-value constant-value) ())) - (walked-lambda (walk-method-lambda method-lambda - required-parameters env - slots calls))) - (multiple-value-bind (walked-lambda-body walked-declarations - walked-documentation) - (system:parse-body (cddr walked-lambda) env) - (declare (ignore walked-documentation)) - (when (some #'cdr slots) - (multiple-value-bind (slot-name-lists call-list) - (slot-name-lists-from-slots slots calls) - (let ((pv-table-symbol (make-symbol "pv-table"))) - (setq plist - `(,@(when slot-name-lists - `(:slot-name-lists ,slot-name-lists)) - ,@(when call-list - `(:call-list ,call-list)) - :pv-table-symbol ,pv-table-symbol - ,@plist)) - (setq walked-lambda-body - `((pv-binding (,required-parameters - ,slot-name-lists - ,pv-table-symbol) - ,@walked-lambda-body)))))) - (when (and (memq '&key lambda-list) - (not (memq '&allow-other-keys lambda-list))) - (let ((aux (memq '&aux lambda-list))) - (setq lambda-list (nconc (ldiff lambda-list aux) - (list '&allow-other-keys) - aux)))) - (values `(lambda (.method-args. .next-methods.) - (simple-lexical-method-functions - (,lambda-list .method-args. .next-methods. - :method-name-declaration ,name-decl) - ,@walked-declarations - ,@walked-lambda-body)) - `(,@(when plist - `(:plist ,plist)) - ,@(when documentation - `(:documentation ,documentation)))))))))) - + (applyp (dolist (p lambda-list nil) + (cond ((memq p '(&optional &rest &key)) + (return t)) + ((eq p '&aux) + (return nil)))))) + (multiple-value-bind (walked-lambda call-next-method-p closurep + next-method-p-p) + ;; + ;; Process the method lambda, possibly optimizing forms + ;; appearing in it. + (walk-method-lambda method-lambda required-parameters env + slots calls) + (multiple-value-bind (walked-lambda-body walked-declarations + walked-documentation) + (system:parse-body (cddr walked-lambda) env) + (declare (ignore walked-documentation)) + (when (or next-method-p-p call-next-method-p) + (setq plist (list* :needs-next-methods-p t plist))) + ;; + ;; If slot-value, set-slot-value, slot-boundp optimizations + ;; have been done in WALK-METHOD-LAMBDA, wrap a PV-BINDING + ;; form around the lambda-body, which gives the code in + ;; the lambda body access to the PV table, required parameters + ;; and slot name lists. + (when (or (some #'cdr slots) (cdr calls)) + (multiple-value-bind (slot-name-lists call-list) + (slot-name-lists-from-slots slots calls) + (let ((pv-table-symbol (make-symbol "pv-table"))) + ;; PV-TABLE-SYMBOL's symbol-value is later set + ;; to an actual PV table for the method + ;; function; see INITIALIZE-METHOD-FUNCTION. + (setq plist + `(,@(when slot-name-lists + `(:slot-name-lists ,slot-name-lists)) + ,@(when call-list + `(:call-list ,call-list)) + :pv-table-symbol ,pv-table-symbol + ,@plist)) + (setq walked-lambda-body + `((pv-binding (,required-parameters ,slot-name-lists + ,pv-table-symbol) + ,@walked-lambda-body)))))) + ;; + ;; When the lambda-list contains &KEY but not + ;; &ALLOW-OTHER-KEYS, insert an &ALLOW-OTHER-KEYS + ;; into the lambda-list. + (when (and (memq '&key lambda-list) + (not (memq '&allow-other-keys lambda-list))) + (let ((aux (memq '&aux lambda-list))) + (setq lambda-list (nconc (ldiff lambda-list aux) + (list '&allow-other-keys) + aux)))) + ;; + ;; First value is the resulting lambda. Second value + ;; is a list of initargs for the method instance being + ;; created. + (values `(lambda (.method-args. .next-methods.) + (simple-lexical-method-functions + (,lambda-list .method-args. .next-methods. + :method-name-declaration ,name-decl + :call-next-method-p ,call-next-method-p + :next-method-p-p ,next-method-p-p + :closurep ,closurep + :applyp ,applyp) + ,@walked-declarations + ,@walked-lambda-body)) + `(,@(when plist + `(:plist ,plist)) + ,@(when documentation + `(:documentation ,documentation))))))))))) + +#-loadable-pcl (unless (fboundp 'make-method-lambda) (setf (gdefinition 'make-method-lambda) (symbol-function 'real-make-method-lambda))) @@ -608,8 +685,8 @@ work during bootstrapping. (defmacro simple-lexical-method-functions ((lambda-list method-args next-methods &rest lmf-options) &body body) - `(progn - ,method-args ,next-methods + `(locally + (declare (ignorable ,method-args ,next-methods)) (bind-simple-lexical-method-macros (,method-args ,next-methods) (bind-lexical-method-functions (,@lmf-options) (bind-args (,lambda-list ,method-args) @@ -634,7 +711,7 @@ work during bootstrapping. `(macrolet ((call-next-method-bind (&body body) `(let ((.next-method. (car ,',next-methods)) (,',next-methods (cdr ,',next-methods))) - .next-method. ,',next-methods + (declare (ignorable .next-method. ,',next-methods)) ,@body)) (call-next-method-body (method-name-declaration cnm-args) `(if .next-method. @@ -660,8 +737,8 @@ work during bootstrapping. (.args. ,args) (.cm-args. ,cm-args)) (if (and .cm-args. (null (cdr .cm-args.))) - (funcall .function. .args. (car .cm-args.)) - (apply .function. .args. .cm-args.)))) + (funcall (the function .function.) .args. (car .cm-args.)) + (apply (the function .function.) .args. .cm-args.)))) (defmacro invoke-method-call (method-call restp &rest required-args+rest-arg) `(invoke-method-call1 (method-call-function ,method-call) @@ -678,108 +755,64 @@ work during bootstrapping. (declaim (ext:freeze-type fast-method-call)) -(defmacro fmc-funcall (fn pv-cell next-method-call &rest args) - `(funcall ,fn ,pv-cell ,next-method-call ,@args)) - (defmacro invoke-fast-method-call (method-call &rest required-args+rest-arg) - `(fmc-funcall (fast-method-call-function ,method-call) - (fast-method-call-pv-cell ,method-call) - (fast-method-call-next-method-call ,method-call) - ,@required-args+rest-arg)) + `(function-funcall (fast-method-call-function ,method-call) + (fast-method-call-pv-cell ,method-call) + (fast-method-call-next-method-call ,method-call) + ,@required-args+rest-arg)) (defstruct fast-instance-boundp (index 0 :type fixnum)) (declaim (ext:freeze-type fast-instance-boundp)) -(eval-when (:compile-toplevel :load-toplevel :execute) -(defvar *allow-emf-call-tracing-p* nil) -(defvar *enable-emf-call-tracing-p* #-testing nil #+testing t) -) - -(defvar *emf-call-trace-size* 200) -(defvar *emf-call-trace* nil) -(defvar emf-call-trace-index 0) - -(defun show-emf-call-trace () - (when *emf-call-trace* - (let ((j emf-call-trace-index) - (*enable-emf-call-tracing-p* nil)) - (format t "~&(The oldest entries are printed first)~%") - (dotimes (i *emf-call-trace-size*) - (declare (fixnum i)) - (let ((ct (aref *emf-call-trace* j))) - (when ct (print ct))) - (incf j) - (when (= j *emf-call-trace-size*) - (setq j 0)))))) - -(defun trace-emf-call-internal (emf format args) - (unless *emf-call-trace* - (setq *emf-call-trace* (make-array *emf-call-trace-size*))) - (setf (aref *emf-call-trace* emf-call-trace-index) - (list* emf format args)) - (incf emf-call-trace-index) - (when (= emf-call-trace-index *emf-call-trace-size*) - (setq emf-call-trace-index 0))) - -(defmacro trace-emf-call (emf format args) - (when *allow-emf-call-tracing-p* - `(when *enable-emf-call-tracing-p* - (trace-emf-call-internal ,emf ,format ,args)))) - (defmacro invoke-effective-method-function-fast (emf restp &rest required-args+rest-arg) + (declare (ignore restp)) `(progn - (trace-emf-call ,emf ,restp (list ,@required-args+rest-arg)) (invoke-fast-method-call ,emf ,@required-args+rest-arg))) -(defmacro invoke-effective-method-function (emf restp &rest required-args+rest-arg) - (unless (constantp restp) - (error "The restp argument to invoke-effective-method-function is not constant")) +(defmacro invoke-effective-method-function + (emf restp &rest required-args+rest-arg) + (assert (constantp restp)) (setq restp (eval restp)) `(progn - (trace-emf-call ,emf ,restp (list ,@required-args+rest-arg)) - (cond ((typep ,emf 'fast-method-call) - (invoke-fast-method-call ,emf ,@required-args+rest-arg)) - ,@(when (and (null restp) (= 1 (length required-args+rest-arg))) - `(((typep ,emf 'fixnum) - (let* ((.slots. (get-slots-or-nil - ,(car required-args+rest-arg))) - (value (when .slots. (%instance-ref .slots. ,emf)))) - (if (eq value +slot-unbound+) - (slot-unbound-internal ,(car required-args+rest-arg) - ,emf) - value))))) - ,@(when (and (null restp) (= 2 (length required-args+rest-arg))) - `(((typep ,emf 'fixnum) - (let ((.new-value. ,(car required-args+rest-arg)) - (.slots. (get-slots-or-nil - ,(car required-args+rest-arg)))) - (when .slots. ; just to avoid compiler wranings - (setf (%instance-ref .slots. ,emf) .new-value.)))))) - #|| - ,@(when (and (null restp) (= 1 (length required-args+rest-arg))) - `(((typep ,emf 'fast-instance-boundp) - (let ((.slots. (get-slots-or-nil + (etypecase ,emf + (fast-method-call + (invoke-fast-method-call ,emf ,@required-args+rest-arg)) + ,@(when (and (null restp) (= 1 (length required-args+rest-arg))) + `((fixnum + (let* ((.slots. (get-slots-or-nil + ,(car required-args+rest-arg))) + (value (when .slots. (%slot-ref .slots. ,emf)))) + (if (eq value +slot-unbound+) + (slot-unbound-internal ,(car required-args+rest-arg) ,emf) + value))))) + ;; + ,@(when (and (null restp) (= 2 (length required-args+rest-arg))) + `((fixnum + (let ((.new-value. ,(car required-args+rest-arg)) + (.slots. (get-slots-or-nil ,(cadr required-args+rest-arg)))) + (when .slots. ; just to avoid compiler wranings + (setf (%slot-ref .slots. ,emf) .new-value.)))))) + #|| + ,@(when (and (null restp) (= 1 (length required-args+rest-arg))) + `(((typep ,emf 'fast-instance-boundp) + (let ((.slots. (get-slots-or-nil ,(car required-args+rest-arg)))) (and .slots. - (not (eq (%instance-ref + (not (eq (%slot-ref .slots. (fast-instance-boundp-index ,emf)) +slot-unbound+))))))) - ||# - (t - (etypecase ,emf - (method-call - (invoke-method-call ,emf ,restp ,@required-args+rest-arg)) - (function - ,(if restp - `(apply (the function ,emf) ,@required-args+rest-arg) - `(funcall (the function ,emf) - ,@required-args+rest-arg)))))))) + ||# + (method-call + (invoke-method-call ,emf ,restp ,@required-args+rest-arg)) + (function + ,(if restp + `(apply (the function ,emf) ,@required-args+rest-arg) + `(funcall (the function ,emf) ,@required-args+rest-arg)))))) (defun invoke-emf (emf args) - (trace-emf-call emf t args) (etypecase emf (fast-method-call (let* ((arg-info (fast-method-call-arg-info emf)) @@ -795,15 +828,15 @@ work during bootstrapping. (cond ((null args) (if (eql nreq 0) (invoke-fast-method-call emf) - (error "wrong number of args"))) + (internal-error "Wrong number of args."))) ((null (cdr args)) (if (eql nreq 1) (invoke-fast-method-call emf (car args)) - (error "wrong number of args"))) + (internal-error "Wrong number of args."))) ((null (cddr args)) (if (eql nreq 2) (invoke-fast-method-call emf (car args) (cadr args)) - (error "wrong number of args"))) + (internal-error "Wrong number of args."))) (t (apply (fast-method-call-function emf) (fast-method-call-pv-cell emf) @@ -814,21 +847,23 @@ work during bootstrapping. args (method-call-call-method-args emf))) (fixnum - (cond ((null args) (error "1 or 2 args expected")) + (cond ((null args) + (internal-error "1 or 2 args expected.")) ((null (cdr args)) - (let ((value (%instance-ref (get-slots (car args)) emf))) + (let ((value (%slot-ref (get-slots (car args)) emf))) (if (eq value +slot-unbound+) (slot-unbound-internal (car args) emf) value))) ((null (cddr args)) - (setf (%instance-ref (get-slots (cadr args)) emf) + (setf (%slot-ref (get-slots (cadr args)) emf) (car args))) - (t (error "1 or 2 args expected")))) + (t + (internal-error "1 or 2 args expected.")))) (fast-instance-boundp (if (or (null args) (cdr args)) - (error "1 arg expected") - (not (eq (%instance-ref (get-slots (car args)) - (fast-instance-boundp-index emf)) + (internal-error "1 arg expected.") + (not (eq (%slot-ref (get-slots (car args)) + (fast-instance-boundp-index emf)) +slot-unbound+)))) (function (apply emf args)))) @@ -850,34 +885,41 @@ work during bootstrapping. ,',(not (null rest-arg)) ,@',args ,@',(when rest-arg `(,rest-arg))))) - `(if ,cnm-args - (bind-args ((,@',args - ,@',(when rest-arg - `(&rest ,rest-arg))) + `(if ,cnm-args + (bind-args ((,@',args ,@',(when rest-arg + `(&rest ,rest-arg))) ,cnm-args) - ,call) - ,call))) - ,(if (and (null ',rest-arg) - (consp cnm-args) - (eq (car cnm-args) 'list)) - `(call-no-next-method ',method-name-declaration - ,@(cdr cnm-args)) - `(call-no-next-method ',method-name-declaration - ,@',args - ,@',(when rest-arg - `(,rest-arg)))))) + ,call) + ,call))) + ,(if (and (null ',rest-arg) + (consp cnm-args) + (eq (car cnm-args) 'list)) + `(call-no-next-method ',method-name-declaration + ,@(cdr cnm-args)) + `(call-no-next-method ',method-name-declaration + ,@',args + ,@',(when rest-arg + `(,rest-arg)))))) (next-method-p-body () `(not (null ,',next-method-call)))) ,@body)) (defmacro bind-lexical-method-functions - ((&key method-name-declaration) &body body) - `(call-next-method-bind - (flet ((call-next-method (&rest cnm-args) - (call-next-method-body ,method-name-declaration cnm-args)) - (next-method-p () (next-method-p-body))) - (declare (ignorable #'call-next-method #'next-method-p)) - ,@body))) + ((&key call-next-method-p next-method-p-p closurep applyp + method-name-declaration) + &body body) + (if (and (null call-next-method-p) (null next-method-p-p) + (null closurep) (null applyp)) + `(let () ,@body) + `(call-next-method-bind + (flet (,@(and call-next-method-p + `((call-next-method (&rest cnm-args) + (call-next-method-body ,method-name-declaration + cnm-args)))) + ,@(and next-method-p-p + '((next-method-p () + (next-method-p-body))))) + ,@body)))) (defmacro bind-args ((lambda-list args) &body body) (let ((args-tail '.args-tail.) @@ -893,8 +935,9 @@ work during bootstrapping. (&rest (setq state 'rest)) (&aux (setq state 'aux)) (otherwise - (error "Encountered the non-standard lambda list keyword ~S." - var))) + (internal-error "Encountered the non-standard ~ + lambda list keyword ~S." + var))) nil) (case state (required `((,var (pop ,args-tail)))) @@ -911,18 +954,15 @@ work during bootstrapping. ,(cadr var))))))) (rest `((,var ,args-tail))) (key (cond ((not (consp var)) - `((,var (car - (get-key-arg-tail ,(make-keyword var) - ,args-tail))))) + `((,var (get-key-arg ,(make-keyword var) + ,args-tail)))) ((null (cddr var)) (multiple-value-bind (keyword variable) (if (consp (car var)) (values (caar var) (cadar var)) - (values (make-keyword (car var)) - (car var))) - `((,key (get-key-arg-tail ',keyword - ,args-tail)) - (,variable (if ,key + (values (make-keyword (car var)) (car var))) + `((,key (get-key-arg1 ',keyword ,args-tail)) + (,variable (if (consp ,key) (car ,key) ,(cadr var)))))) (t @@ -930,10 +970,9 @@ work during bootstrapping. (if (consp (car var)) (values (caar var) (cadar var)) (values (make-keyword (car var)) (car var))) - `((,key (get-key-arg-tail ',keyword - ,args-tail)) + `((,key (get-key-arg1 ',keyword ,args-tail)) (,(caddr var) ,key) - (,variable (if ,key + (,variable (if (consp ,key) (car ,key) ,(cadr var)))))))) (aux `(,var)))))) @@ -943,52 +982,82 @@ work during bootstrapping. (declare (ignorable ,args-tail)) ,@body))))) -(defun get-key-arg-tail (keyword list) - (loop for (key . tail) on list by #'cddr - when (null tail) do - (simple-program-error "Odd number of keyword arguments in ~S" list) +(defun get-key-arg (keyword list) + (loop for (key . more) on list by #'cddr + when (null more) do + (simple-program-error "Odd number of keyword arguments.") when (eq key keyword) - return tail)) + return (car more))) + +(defun get-key-arg1 (keyword list) + (loop for (key . more) on list by #'cddr + when (null more) do + (simple-program-error "Odd number of keyword arguments.") + when (eq key keyword) + return more)) (defun walk-method-lambda (method-lambda required-parameters env slots calls) - (flet ((walk-function (form context env) - (cond ((not (eq context :eval)) form) - ((not (listp form)) form) - ((and (or (eq (car form) 'slot-value) - (eq (car form) 'set-slot-value) - (eq (car form) 'slot-boundp)) - (constantp (caddr form))) - (let ((parameter - (can-optimize-access form required-parameters env))) - (ecase (car form) - (slot-value - (optimize-slot-value slots parameter form)) - (set-slot-value - (optimize-set-slot-value slots parameter form)) - (slot-boundp - (optimize-slot-boundp slots parameter form))))) - ((and (eq (car form) 'apply) - (consp (cadr form)) - (eq (car (cadr form)) 'function) - (generic-function-name-p (cadr (cadr form)))) - (optimize-generic-function-call - form required-parameters env slots calls)) - ((and (or (symbolp (car form)) - (and (consp (car form)) - (eq (caar form) 'setf))) - (generic-function-name-p (car form))) - (optimize-generic-function-call - form required-parameters env slots calls)) - ((and (eq (car form) 'asv-funcall) - *optimize-asv-funcall-p*) - (case (fourth form) - (reader (push (third form) *asv-readers*)) - (writer (push (third form) *asv-writers*)) - (boundp (push (third form) *asv-boundps*))) - `(,(second form) ,@(cddddr form))) - (t form)))) + (let ((call-next-method-p nil) ;flag indicating that call-next-method + ;should be in the method definition + (closurep nil) ;flag indicating that #'call-next-method + ;was seen in the body of a method + (next-method-p-p nil)) ;flag indicating that next-method-p + ;should be in the method definition + (flet ((walk-function (form context env) + (cond ((not (eq context :eval)) + form) + ((not (listp form)) + form) + ((eq (car form) 'call-next-method) + (setq call-next-method-p t) + form) + ((eq (car form) 'next-method-p) + (setq next-method-p-p t) + form) + ((and (eq (car form) 'function) + (cond ((eq (cadr form) 'call-next-method) + (setq call-next-method-p t) + (setq closurep t) + form) + ((eq (cadr form) 'next-method-p) + (setq next-method-p-p t) + (setq closurep t) + form) + (t nil)))) + ;; + ((and (memq (car form) + '(slot-value slot-boundp set-slot-value)) + (constantp (caddr form))) + (optimize-slot-access form env required-parameters slots)) + ;; + ((and (eq (car form) 'apply) + (consp (cadr form)) + (eq (car (cadr form)) 'function) + (info-gf-name-p (cadr (cadr form)))) + (optimize-gf-call form required-parameters calls env)) + ;; + ((and (symbolp (car form)) + (null (cddr form)) + (info-accessor-p (car form))) + (optimize-slot-reader form required-parameters slots env)) + ;; + ((and (eq (car form) 'setf) + (consp (cadr form)) + (= (length form) 3) + (= (length (cadr form)) 2) + (info-accessor-p `(setf ,(caadr form)))) + (optimize-slot-writer form required-parameters slots env)) + ;; + ((and (ext:valid-function-name-p (car form)) + (info-gf-name-p (car form))) + (optimize-gf-call form required-parameters calls env)) + (t + form)))) - (walk-form method-lambda env #'walk-function))) + (let ((walked-lambda (walk-form method-lambda env #'walk-function))) + (values walked-lambda + call-next-method-p closurep next-method-p-p))))) + (defun generic-function-name-p (name) (and (ext:valid-function-name-p name) @@ -999,7 +1068,7 @@ work during bootstrapping. -(defvar *method-function-plist* (make-hash-table :test #'eq)) +(defvar *method-function-plist* (make-hash-table :test 'eq)) (defvar *mf1* nil) (defvar *mf1p* nil) (defvar *mf1cp* nil) (defvar *mf2* nil) (defvar *mf2p* nil) (defvar *mf2cp* nil) @@ -1042,24 +1111,48 @@ work during bootstrapping. (defun method-function-method (method-function) (method-function-get method-function :method)) +(defun method-function-needs-next-methods-p (method-function) + (method-function-get method-function :needs-next-methods-p t)) - -(defmacro method-function-closure-generator (method-function) - `(method-function-get ,method-function 'closure-generator)) -(defun load-defmethod (class name quals specls ll initargs &optional pv-table-symbol) + +(defun load-defmethod (class name quals specls ll initargs + &optional pv-table-symbol inline-access + method-info) (setq initargs (copy-tree initargs)) (let ((method-spec (or (getf initargs :method-spec) (make-method-spec name quals specls)))) (setf (getf initargs :method-spec) method-spec) - (load-defmethod-internal class name quals specls ll initargs pv-table-symbol))) + (load-defmethod-internal class name quals specls ll initargs + pv-table-symbol inline-access + method-info))) + +(defvar *compile-interpreted-methods-p* t + "When true, compile interpreted method functions.") (defun load-defmethod-internal (method-class gf-spec qualifiers specializers lambda-list - initargs pv-table-symbol) + initargs pv-table-symbol inline-access method-info) (when pv-table-symbol (setf (getf (getf initargs :plist) :pv-table-symbol) pv-table-symbol)) + ;; + ;; Optionally compile method functions if they are interpreted. + (when *compile-interpreted-methods-p* + (flet ((maybe-compile (key) + (let ((fn (getf initargs key))) + (when (and (eval:interpreted-function-p fn) + ;; Can't compile closures. + (null (eval:interpreted-function-closure fn))) + (let* ((type (ecase key + (:fast-function 'fast-method) + (:function 'method))) + (name `(,type ,gf-spec ,@qualifiers ,specializers))) + (compile name fn) + (setf (getf initargs key) (fdefinition name))))))) + (maybe-compile :fast-function) + (maybe-compile :function))) + ;; (let ((method (apply #'add-named-method gf-spec qualifiers specializers lambda-list :definition-source `((defmethod ,gf-spec @@ -1067,14 +1160,17 @@ work during bootstrapping. ,specializers) ,*load-pathname*) initargs))) + ;; + (record-inline-access-info method inline-access method-info) + ;; (unless (or (eq method-class 'standard-method) (eq (find-class method-class nil) (class-of method))) (format *error-output* - "~&At the time the method with qualifiers ~:S and~%~ - specializers ~:S on the generic function ~S~%~ - was compiled, the method-class for that generic function was~%~ - ~S. But, the method class is now ~S, this~%~ - may mean that this method was compiled improperly.~%" + "~&~@<At the time the method with qualifiers ~S and ~ + specializers ~S on the generic function ~S ~ + was compiled, the method class for that generic function was ~ + ~S. But, the method class is now ~S, this ~ + may mean that this method was compiled improperly.~@:>" qualifiers specializers gf-spec method-class (class-name (class-of method)))) method)) @@ -1098,12 +1194,7 @@ work during bootstrapping. (when mf (setq mf (set-function-name mf method-spec))) (when mff - (let ((name `(,(or (get (car method-spec) 'fast-sym) - (setf (get (car method-spec) 'fast-sym) - (intern (format nil "FAST-~A" - (car method-spec)) - *the-pcl-package*))) - ,@(cdr method-spec)))) + (let ((name (cons 'fast-method (cdr method-spec)))) (set-function-name mff name) (unless mf (set-mf-property :name name))))) @@ -1125,15 +1216,14 @@ work during bootstrapping. (defun analyze-lambda-list (lambda-list) - ;;(declare (values nrequired noptional keysp restp allow-other-keys-p - ;; keywords keyword-parameters)) (multiple-value-bind (required optional restp rest keyp keys allow-other-keys-p aux morep more-context more-count) (kernel:parse-lambda-list lambda-list) (declare (ignore rest aux more-context more-count)) (when morep - (simple-program-error "Lambda list keyword &MORE not allowed here")) + (simple-program-error "Lambda list keyword ~s not allowed here." + '&more)) (flet ((keyword-parameter-keyword (x) (let ((key (if (atom x) x (car x)))) (if (atom key) @@ -1176,8 +1266,8 @@ work during bootstrapping. (defun proclaim-defgeneric (spec lambda-list) (let ((decl `(ftype ,(ftype-declaration-from-lambda-list lambda-list spec) ,spec))) - (proclaim decl) - )) + (set-gf-info spec lambda-list) + (proclaim decl))) ;;;; Early generic-function support ;;; @@ -1202,13 +1292,13 @@ work during bootstrapping. (defun generic-clobbers-function (function-specifier) (restart-case (simple-program-error - "~S already names an ordinary function or a macro.~%~ - If you want to replace it with a generic function, you should remove~%~ - the existing definition beforehand.~%" + "~@<~S already names an ordinary function or a macro. ~ + If you want to replace it with a generic function, you should remove ~ + the existing definition beforehand.~@:>" function-specifier) (continue () :report (lambda (stream) - (format stream "Discard the existing definition of ~S." + (format stream "~@<Discard the existing definition of ~S.~@:>" function-specifier)) (fmakunbound function-specifier)))) @@ -1231,20 +1321,20 @@ work during bootstrapping. (defun early-gf-p (x) (and (fsc-instance-p x) - (eq (instance-ref (get-slots x) *sgf-method-class-index*) + (eq (slot-ref (get-slots x) *sgf-method-class-index*) +slot-unbound+))) (defvar *sgf-methods-index* (bootstrap-slot-index 'standard-generic-function 'methods)) (defmacro early-gf-methods (gf) - `(instance-ref (get-slots ,gf) *sgf-methods-index*)) + `(slot-ref (get-slots ,gf) *sgf-methods-index*)) (defvar *sgf-arg-info-index* (bootstrap-slot-index 'standard-generic-function 'arg-info)) (defmacro early-gf-arg-info (gf) - `(instance-ref (get-slots ,gf) *sgf-arg-info-index*)) + `(slot-ref (get-slots ,gf) *sgf-arg-info-index*)) (defvar *sgf-dfun-state-index* (bootstrap-slot-index 'standard-generic-function 'dfun-state)) @@ -1283,15 +1373,8 @@ work during bootstrapping. (defun arg-info-nkeys (arg-info) (count-if (lambda (x) (neq x t)) (arg-info-metatypes arg-info))) -;;; Keep pages clean by not setting if the value is already the same. -(defmacro esetf (pos val) - (let ((valsym (gensym "value"))) - `(let ((,valsym ,val)) - (unless (equal ,pos ,valsym) - (setf ,pos ,valsym))))) - (defun set-arg-info (gf &key new-method (lambda-list nil lambda-list-p) - argument-precedence-order) + argument-precedence-order) (let* ((arg-info (if (eq *boot-state* 'complete) (gf-arg-info gf) (early-gf-arg-info gf))) @@ -1313,28 +1396,37 @@ work during bootstrapping. (unless (and (= nreq gf-nreq) (= nopt gf-nopt) (eq (or keysp restp) gf-key/rest-p)) - (error "The lambda-list ~S is incompatible with ~ - existing methods of ~S." + (error "~@<The lambda-list ~S is incompatible with ~ + existing methods of ~S.~@:>" lambda-list gf)))) (when lambda-list-p - (esetf (arg-info-lambda-list arg-info) lambda-list)) + (setf (arg-info-lambda-list arg-info) lambda-list)) (when (or lambda-list-p argument-precedence-order (null (arg-info-precedence arg-info))) - (esetf (arg-info-precedence arg-info) - (compute-precedence lambda-list nreq - argument-precedence-order))) - (esetf (arg-info-metatypes arg-info) (make-list nreq)) - (esetf (arg-info-number-optional arg-info) nopt) - (esetf (arg-info-key/rest-p arg-info) (not (null (or keysp restp)))) - (esetf (arg-info-keywords arg-info) - (if lambda-list-p - (if allow-other-keys-p t keywords) - (arg-info-key/rest-p arg-info))))) + (setf (arg-info-precedence arg-info) + (compute-precedence lambda-list nreq + argument-precedence-order))) + (setf (arg-info-metatypes arg-info) (make-list nreq)) + (setf (arg-info-number-optional arg-info) nopt) + (setf (arg-info-key/rest-p arg-info) (not (null (or keysp restp)))) + (setf (arg-info-keywords arg-info) + (if lambda-list-p + (if allow-other-keys-p t keywords) + (arg-info-key/rest-p arg-info))))) (when new-method (check-method-arg-info gf arg-info new-method)) (set-arg-info1 gf arg-info new-method methods was-valid-p first-p) arg-info)) +(defun compute-precedence (lambda-list nreq argument-precedence-order) + (if (null argument-precedence-order) + (let ((list nil)) + (dotimes (i nreq list) + (declare (fixnum i)) + (push (- (1- nreq) i) list))) + (mapcar (lambda (x) (position x lambda-list)) + argument-precedence-order))) + (defun check-method-arg-info (gf arg-info method) (multiple-value-bind (nreq nopt keysp restp allow-other-keys-p keywords) (analyze-lambda-list (if (consp method) @@ -1342,8 +1434,10 @@ work during bootstrapping. (method-lambda-list method))) (flet ((lose (format-control &rest format-args) (simple-program-error - "Attempt to add the method ~S to the generic function ~S.~%~ - But ~?" method gf format-control format-args)) + (format nil "~~@<Attempt to add the method ~~S to the generic ~ + function ~~S, but ~?.~~@:>" + format-control format-args) + method gf)) (compare (x y) (if (> x y) "more" "fewer"))) (let ((gf-nreq (arg-info-number-required arg-info)) @@ -1351,20 +1445,23 @@ work during bootstrapping. (gf-key/rest-p (arg-info-key/rest-p arg-info)) (gf-keywords (arg-info-keywords arg-info))) (unless (= nreq gf-nreq) - (lose "the method has ~A required arguments than the generic function." + (lose "the method has ~A required arguments than the ~ + generic function" (compare nreq gf-nreq))) (unless (= nopt gf-nopt) - (lose "the method has ~S optional arguments than the generic function." + (lose "the method has ~S optional arguments than the ~ + generic function" (compare nopt gf-nopt))) (unless (eq (or keysp restp) gf-key/rest-p) - (lose "the method and generic function differ in whether they accept~%~ - rest or keyword arguments.")) + (lose "the method and generic function differ in whether ~ + they accept rest or keyword arguments")) (when (consp gf-keywords) (unless (or (and restp (not keysp)) allow-other-keys-p (every (lambda (k) (memq k keywords)) gf-keywords)) - (lose "the method does not accept each of the keyword arguments~%~ - ~S." gf-keywords))))))) + (lose "the method does not accept each of the keyword ~ + arguments ~S" + gf-keywords))))))) (defun set-arg-info1 (gf arg-info new-method methods was-valid-p first-p) (let* ((existing-p (and methods (cdr methods) new-method)) @@ -1398,29 +1495,38 @@ work during bootstrapping. (setq type (cond ((null type) new-type) ((eq type new-type) type) (t nil))))) - (esetf (arg-info-metatypes arg-info) metatypes) - (esetf (gf-info-simple-accessor-type arg-info) type))) + (setf (arg-info-metatypes arg-info) metatypes) + (setf (gf-info-simple-accessor-type arg-info) type))) (when (or (not was-valid-p) first-p) (multiple-value-bind (c-a-m-emf std-p) (if (early-gf-p gf) (values t t) (compute-applicable-methods-emf gf)) - (esetf (gf-info-static-c-a-m-emf arg-info) c-a-m-emf) - (esetf (gf-info-c-a-m-emf-std-p arg-info) std-p) + (setf (gf-info-static-c-a-m-emf arg-info) c-a-m-emf) + (setf (gf-info-c-a-m-emf-std-p arg-info) std-p) (unless (gf-info-c-a-m-emf-std-p arg-info) - (esetf (gf-info-simple-accessor-type arg-info) t)))) + (setf (gf-info-simple-accessor-type arg-info) t)))) + ;; + ;; Let dfuns and emfs be pre-computed for "normal" PCL methods, not + ;; the ones generated in the course of optimizations. This + ;; implementation depends on the fact that the latter methods result + ;; in NIL being returned as second value of + ;; EXT:VALID-FUNCTION-NAME-P. (unless was-valid-p (let ((name (if (eq *boot-state* 'complete) (generic-function-name gf) (early-gf-name gf)))) - (esetf (gf-precompute-dfun-and-emf-p arg-info) - (let* ((sym (if (atom name) name (cadr name))) - (pkg-list (cons *the-pcl-package* - (package-use-list *the-pcl-package*)))) - (and sym (symbolp sym) - (not (null (memq (symbol-package sym) pkg-list))) - (not (find #\space (symbol-name sym)))))))) - (esetf (gf-info-fast-mf-p arg-info) + (setf (gf-precompute-dfun-and-emf-p arg-info) + (multiple-value-bind (valid sym) + (ext:valid-function-name-p name) + (and valid sym + (symbolp sym) + (let ((pkg (symbol-package sym)) + (pcl *the-pcl-package*)) + (or (eq pkg pcl) + (memq pkg (package-use-list pcl))))))))) + ;; + (setf (gf-info-fast-mf-p arg-info) (or (not (eq *boot-state* 'complete)) (let* ((method-class (generic-function-method-class gf)) (methods (compute-applicable-methods @@ -1446,28 +1552,30 @@ work during bootstrapping. ;;; contains a list whose: ;;; CAR - a list of the early methods on this early gf ;;; CADR - the early discriminator code for this method -;;; -(defun ensure-generic-function-using-class (existing spec &rest keys - &key (lambda-list nil lambda-list-p) - argument-precedence-order - &allow-other-keys) +;;; +#-loadable-pcl +(defun ensure-generic-function-using-class + (existing spec &rest keys + &key (lambda-list nil lambda-list-p) argument-precedence-order + &allow-other-keys) (declare (ignore keys)) (cond ((and existing (early-gf-p existing)) existing) ((assoc spec *generic-function-fixups* :test #'equal) (if existing (make-early-gf spec lambda-list lambda-list-p existing - argument-precedence-order) - (error "The function ~S is not already defined" spec))) + argument-precedence-order) + (error "~@<The function ~S is not already defined.~@:>" spec))) (existing - (error "~S should be on the list ~S" spec '*generic-function-fixups*)) + (error "~@<~S should be on the list ~S.~@:>" spec + '*generic-function-fixups*)) (t (pushnew spec *early-generic-functions* :test #'equal) (make-early-gf spec lambda-list lambda-list-p nil - argument-precedence-order)))) + argument-precedence-order)))) (defun make-early-gf (spec &optional lambda-list lambda-list-p function - argument-precedence-order) + argument-precedence-order) (let ((fin (allocate-funcallable-instance *sgf-wrapper* *sgf-slots-init*))) (set-funcallable-instance-function fin @@ -1478,8 +1586,8 @@ work during bootstrapping. (format stream "std-instance"))) #'(kernel:instance-lambda (&rest args) (declare (ignore args)) - (error "The function of the funcallable-instance ~S~ - has not been set" fin))))) + (error "~@<The function of the funcallable instance ~S ~ + has not been set.~@:>" fin))))) (setf (gdefinition spec) fin) (bootstrap-set-slot 'standard-generic-function fin 'name spec) (bootstrap-set-slot 'standard-generic-function fin 'source *load-pathname*) @@ -1487,14 +1595,34 @@ work during bootstrapping. (let ((arg-info (make-arg-info))) (setf (early-gf-arg-info fin) arg-info) (when lambda-list-p - (proclaim-defgeneric spec lambda-list) (if argument-precedence-order (set-arg-info fin - :lambda-list lambda-list - :argument-precedence-order argument-precedence-order) + :lambda-list lambda-list + :argument-precedence-order + argument-precedence-order) (set-arg-info fin :lambda-list lambda-list)))) fin)) +;;; +;;; When loading PCL on top of itself, generic dispatch functions and +;;; effective methods would normally be recomputed when methods are +;;; defined. This is a problem because many generic functions are +;;; called in the implementation of dispatch and effective method +;;; functions (the meta-circularity). These generic functions cannot +;;; be called until their dispatch functions and effective methods are +;;; computed. +;;; +;;; We prevent here the setting of GF-DFUN-STATE to NIL. This has the +;;; effect that COMPUTE-DISCRIMINATING-FUNCTION uses the existing +;;; discriminating function of the PCL on top of which the new PCL is +;;; loaded. The generic functions affected are collected in +;;; *GENERIC-FUNCTIONS-TO-RECOMPUTE* for later fixing. +;;; + +(defvar *loading-pcl-p* nil) + +(defvar *generic-functions-to-recompute* ()) + (defun set-dfun (gf &optional dfun cache info) (when cache (setf (cache-owner cache) gf)) @@ -1502,14 +1630,23 @@ work during bootstrapping. (list* dfun cache info) dfun))) (if (eq *boot-state* 'complete) + #+loadable-pcl + (if (and *loading-pcl-p* (null new-state)) + (pushnew gf *generic-functions-to-recompute*) + (setf (gf-dfun-state gf) new-state)) + #-loadable-pcl (setf (gf-dfun-state gf) new-state) - (setf (instance-ref (get-slots gf) *sgf-dfun-state-index*) new-state))) + (setf (slot-ref (get-slots gf) *sgf-dfun-state-index*) new-state))) dfun) +(defun recompute-generic-functions () + (let ((*loading-pcl-p* nil)) + (mapc #'update-dfun *generic-functions-to-recompute*))) + (defun gf-dfun-cache (gf) (let ((state (if (eq *boot-state* 'complete) (gf-dfun-state gf) - (instance-ref (get-slots gf) *sgf-dfun-state-index*)))) + (slot-ref (get-slots gf) *sgf-dfun-state-index*)))) (typecase state (function nil) (cons (cadr state))))) @@ -1517,7 +1654,7 @@ work during bootstrapping. (defun gf-dfun-info (gf) (let ((state (if (eq *boot-state* 'complete) (gf-dfun-state gf) - (instance-ref (get-slots gf) *sgf-dfun-state-index*)))) + (slot-ref (get-slots gf) *sgf-dfun-state-index*)))) (typecase state (function nil) (cons (cddr state))))) @@ -1526,7 +1663,7 @@ work during bootstrapping. (bootstrap-slot-index 'standard-generic-function 'name)) (defun early-gf-name (gf) - (instance-ref (get-slots gf) *sgf-name-index*)) + (slot-ref (get-slots gf) *sgf-name-index*)) (defun gf-lambda-list (gf) (let ((arg-info (if (eq *boot-state* 'complete) @@ -1538,7 +1675,7 @@ work during bootstrapping. (early-gf-methods gf)))) (if (null methods) (progn - (warn "No way to determine the lambda list for ~S." gf) + (warn "~@<No way to determine the lambda list for ~S.~@:>" gf) nil) (let* ((method (car (last methods))) (ll (if (consp method) @@ -1556,9 +1693,9 @@ work during bootstrapping. (setq ,gf-class (find-class ,gf-class t ,env))) ((classp ,gf-class)) (t - (error "The :GENERIC-FUNCTION-CLASS argument (~S) was neither a~%~ - class nor a symbol that names a class." - ,gf-class))) + (error "~@<The ~s argument (~S) was neither a class nor a ~ + symbol naming a class.~@:>" + :generic-function-class ,gf-class))) (remf ,all-keys :generic-function-class) (remf ,all-keys :environment) (let ((combin (getf ,all-keys :method-combination '.shes-not-there.))) @@ -1571,38 +1708,81 @@ work during bootstrapping. (unless (eq method-class '.shes-not-there.) (setf (getf ,all-keys :method-class) (find-class method-class t ,env)))))) + +#+loadable-pcl +(progn + (defmethod ensure-generic-function-using-class + ((existing generic-function) + function-specifier + &rest all-keys + &key environment + (lambda-list nil lambda-list-p) + (generic-function-class 'standard-generic-function gf-class-p) + &allow-other-keys) + (real-ensure-gf-internal generic-function-class all-keys environment) + (unless (or (null gf-class-p) + (eq (class-of existing) generic-function-class)) + (change-class existing generic-function-class)) + (prog1 + (apply #'reinitialize-instance existing all-keys) + (when lambda-list-p + (proclaim-defgeneric function-specifier lambda-list)))) -(defun real-ensure-gf-using-class--generic-function - (existing - function-specifier - &rest all-keys - &key environment (lambda-list nil lambda-list-p) - (generic-function-class 'standard-generic-function gf-class-p) - &allow-other-keys) - (real-ensure-gf-internal generic-function-class all-keys environment) - (unless (or (null gf-class-p) - (eq (class-of existing) generic-function-class)) - (change-class existing generic-function-class)) - (prog1 - (apply #'reinitialize-instance existing all-keys) - (when lambda-list-p - (proclaim-defgeneric function-specifier lambda-list)))) - -(defun real-ensure-gf-using-class--null - (existing - function-specifier - &rest all-keys - &key environment (lambda-list nil lambda-list-p) - (generic-function-class 'standard-generic-function) - &allow-other-keys) - (declare (ignore existing)) - (real-ensure-gf-internal generic-function-class all-keys environment) - (prog1 - (setf (gdefinition function-specifier) - (apply #'make-instance generic-function-class - :name function-specifier all-keys)) - (when lambda-list-p - (proclaim-defgeneric function-specifier lambda-list)))) + (defmethod ensure-generic-function-using-class + ((existing null) + function-specifier + &rest all-keys + &key environment (lambda-list nil lambda-list-p) + (generic-function-class 'standard-generic-function) + &allow-other-keys) + (declare (ignore existing)) + (real-ensure-gf-internal generic-function-class all-keys environment) + (prog1 + (setf (gdefinition function-specifier) + (apply #'make-instance generic-function-class + :name function-specifier all-keys)) + (when lambda-list-p + (proclaim-defgeneric function-specifier lambda-list))))) + +;;; +;;; These two are like the methods above, but used during bootstrapping. +;;; During the bootstrapping procedure they are added as methods +;;; to ENSURE-GENERIC-FUNCTION-USING-CLASS. +;;; + +#-loadable-pcl +(progn + (defun real-ensure-gf-using-class--generic-function + (existing + function-specifier + &rest all-keys + &key environment (lambda-list nil lambda-list-p) + (generic-function-class 'standard-generic-function gf-class-p) + &allow-other-keys) + (real-ensure-gf-internal generic-function-class all-keys environment) + (unless (or (null gf-class-p) + (eq (class-of existing) generic-function-class)) + (change-class existing generic-function-class)) + (prog1 + (apply #'reinitialize-instance existing all-keys) + (when lambda-list-p + (proclaim-defgeneric function-specifier lambda-list)))) + + (defun real-ensure-gf-using-class--null + (existing + function-specifier + &rest all-keys + &key environment (lambda-list nil lambda-list-p) + (generic-function-class 'standard-generic-function) + &allow-other-keys) + (declare (ignore existing)) + (real-ensure-gf-internal generic-function-class all-keys environment) + (prog1 + (setf (gdefinition function-specifier) + (apply #'make-instance generic-function-class + :name function-specifier all-keys)) + (when lambda-list-p + (proclaim-defgeneric function-specifier lambda-list))))) @@ -1620,6 +1800,7 @@ work during bootstrapping. (count-if (lambda (x) (neq x t)) metatypes) arg-info))) +#-loadable-pcl (defun early-make-a-method (class qualifiers arglist specializers initargs doc &optional slot-name) (initialize-method-function initargs) @@ -1660,9 +1841,9 @@ work during bootstrapping. slot-name) ))) -(defun real-make-a-method - (class qualifiers lambda-list specializers initargs doc - &optional slot-name) +(defun #+loadable-pcl make-a-method #-loadable-pcl real-make-a-method + (class qualifiers lambda-list specializers initargs doc + &optional slot-name) (setq specializers (parse-specializers specializers)) (apply #'make-instance class :qualifiers qualifiers @@ -1744,53 +1925,56 @@ work during bootstrapping. ;;; generic function. See fix-early-generic-functions which has special ;;; knowledge about add-method. ;;; -(defun add-method (generic-function method) - (when (not (fsc-instance-p generic-function)) - (error "Early add-method didn't get a funcallable instance.")) - (when (not (and (listp method) (eq (car method) :early-method))) - (error "Early add-method didn't get an early method.")) - (push method (early-gf-methods generic-function)) - (set-arg-info generic-function :new-method method) - (unless (assoc (early-gf-name generic-function) *generic-function-fixups* - :test #'equal) - (update-dfun generic-function))) - -;;; -;;; This is the early version of remove method. -;;; -(defun remove-method (generic-function method) - (when (not (fsc-instance-p generic-function)) - (error "Early remove-method didn't get a funcallable instance.")) - (when (not (and (listp method) (eq (car method) :early-method))) - (error "Early remove-method didn't get an early method.")) - (setf (early-gf-methods generic-function) - (remove method (early-gf-methods generic-function))) - (set-arg-info generic-function) - (unless (assoc (early-gf-name generic-function) *generic-function-fixups* - :test #'equal) - (update-dfun generic-function))) - -;;; -;;; And the early version of get-method. -;;; -(defun get-method (generic-function qualifiers specializers - &optional (errorp t)) - (if (early-gf-p generic-function) - (or (dolist (m (early-gf-methods generic-function)) - (when (and (or (equal (early-method-specializers m nil) - specializers) - (equal (early-method-specializers m t) - specializers)) - (equal (early-method-qualifiers m) qualifiers)) - (return m))) - (if errorp - (error "Can't get early method.") - nil)) - (real-get-method generic-function qualifiers specializers errorp))) +#-loadable-pcl +(progn + (defun add-method (generic-function method) + (when (not (fsc-instance-p generic-function)) + (error "Early add-method didn't get a funcallable instance.")) + (when (not (and (listp method) (eq (car method) :early-method))) + (error "Early add-method didn't get an early method.")) + (push method (early-gf-methods generic-function)) + (set-arg-info generic-function :new-method method) + (unless (assoc (early-gf-name generic-function) *generic-function-fixups* + :test #'equal) + (update-dfun generic-function))) + + ;; + ;; This is the early version of remove method. + ;; + (defun remove-method (generic-function method) + (when (not (fsc-instance-p generic-function)) + (error "Early remove-method didn't get a funcallable instance.")) + (when (not (and (listp method) (eq (car method) :early-method))) + (error "Early remove-method didn't get an early method.")) + (setf (early-gf-methods generic-function) + (remove method (early-gf-methods generic-function))) + (set-arg-info generic-function) + (unless (assoc (early-gf-name generic-function) *generic-function-fixups* + :test #'equal) + (update-dfun generic-function))) + + ;; + ;; And the early version of get-method. + ;; + (defun get-method (generic-function qualifiers specializers + &optional (errorp t)) + (if (early-gf-p generic-function) + (or (dolist (m (early-gf-methods generic-function)) + (when (and (or (equal (early-method-specializers m nil) + specializers) + (equal (early-method-specializers m t) + specializers)) + (equal (early-method-qualifiers m) qualifiers)) + (return m))) + (if errorp + (error "Can't get early method.") + nil)) + (real-get-method generic-function qualifiers specializers errorp)))) (defvar *fegf-debug-p* nil) -(defun fix-early-generic-functions (&optional (noisyp *fegf-debug-p*)) +(defun fix-early-generic-functions (&optional (noisyp t *fegf-debug-p*)) + (declare (ignore noisyp)) (let ((accessors nil)) ;; Rearrange *early-generic-functions* to speed up fix-early-generic-functions. (dolist (early-gf-spec *early-generic-functions*) @@ -1820,7 +2004,6 @@ work during bootstrapping. (cons spec (delete spec *early-generic-functions* :test #'equal)))) (dolist (early-gf-spec *early-generic-functions*) - (when noisyp (format t "~&~S..." early-gf-spec)) (let* ((gf (gdefinition early-gf-spec)) (methods (mapcar (lambda (early-method) (let ((args (copy-list (fifth early-method)))) @@ -1887,8 +2070,8 @@ work during bootstrapping. (if (specializerp result) result (if (symbolp spec) - (error "~S used as a specializer,~%~ - but is not the name of a class." + (error "~@<~S used as a specializer, ~ + but is not the name of a class.~@:>" spec) (error "~S is not a legal specializer." spec)))))) (mapcar #'parse specializers))) @@ -1911,44 +2094,38 @@ work during bootstrapping. (unparse-specializers (method-specializers specializers-or-method)))) (defun parse-method-or-spec (spec &optional (errorp t)) - ;;(declare (values generic-function method method-name)) (let (gf method name temp) (if (method-p spec) (setq method spec gf (method-generic-function method) temp (and gf (generic-function-name gf)) name (if temp - (intern-function-name - (make-method-spec temp - (method-qualifiers method) - (unparse-specializers - (method-specializers method)))) + (make-method-spec temp (method-qualifiers method) + (unparse-specializers + (method-specializers method))) (make-symbol (format nil "~S" method)))) (multiple-value-bind (gf-spec quals specls) (parse-defmethod spec) (and (setq gf (and (or errorp (fboundp gf-spec)) (gdefinition gf-spec))) - (let ((nreq (compute-discriminating-function-arglist-info gf))) + (let ((nreq (arg-info-number-required + (if (eq *boot-state* 'complete) + (gf-arg-info gf) + (early-gf-arg-info gf))))) (setq specls (append (parse-specializers specls) (make-list (- nreq (length specls)) :initial-element *the-class-t*))) (and (setq method (get-method gf quals specls errorp)) - (setq name - (intern-function-name (make-method-spec gf-spec - quals - specls)))))))) + (setq name (make-method-spec gf-spec quals + (unparse-specializers specls)))))))) (values gf method name))) - -(defun extract-parameters (specialized-lambda-list) - (multiple-value-bind (parameters ignore1 ignore2) - (parse-specialized-lambda-list specialized-lambda-list) - (declare (ignore ignore1 ignore2)) - parameters)) - +;;; +;;; The next two functions are part of AMOP. +;;; (defun extract-lambda-list (specialized-lambda-list) (multiple-value-bind (ignore1 lambda-list ignore2) (parse-specialized-lambda-list specialized-lambda-list) @@ -1961,68 +2138,46 @@ work during bootstrapping. (declare (ignore ignore1 ignore2)) specializers)) -(defun extract-required-parameters (specialized-lambda-list) - (multiple-value-bind (ignore1 ignore2 ignore3 required-parameters) - (parse-specialized-lambda-list specialized-lambda-list) - (declare (ignore ignore1 ignore2 ignore3)) - required-parameters)) - -(defun parse-specialized-lambda-list (arglist &optional post-keyword) - ;;(declare (values parameters lambda-list specializers required-parameters)) - (let ((arg (car arglist))) - (cond ((null arglist) (values nil nil nil nil)) - ((eq arg '&aux) - (values nil arglist nil)) - ((memq arg lambda-list-keywords) - (unless (memq arg '(&optional &rest &key &allow-other-keys &aux)) - ;; Warn about non-standard lambda-list-keywords, but then - ;; go on to treat them like a standard lambda-list-keyword - ;; what with the warning its probably ok. - (warn "Unrecognized lambda-list keyword ~S in arglist.~%~ - Assuming that the symbols following it are parameters,~%~ - and not allowing any parameter specializers to follow~%~ - to follow it." - arg)) - ;; When we are at a lambda-list-keyword, the parameters don't - ;; include the lambda-list-keyword; the lambda-list does include - ;; the lambda-list-keyword; and no specializers are allowed to - ;; follow the lambda-list-keywords (at least for now). - (multiple-value-bind (parameters lambda-list) - (parse-specialized-lambda-list (cdr arglist) t) - (values parameters - (cons arg lambda-list) - () - ()))) - (post-keyword - ;; After a lambda-list-keyword there can be no specializers. - (multiple-value-bind (parameters lambda-list) - (parse-specialized-lambda-list (cdr arglist) t) - (values (cons (if (listp arg) (car arg) arg) parameters) - (cons arg lambda-list) - () - ()))) - (t - (multiple-value-bind (parameters lambda-list specializers required) - (parse-specialized-lambda-list (cdr arglist)) - (values (cons (if (listp arg) (car arg) arg) parameters) - (cons (if (listp arg) (car arg) arg) lambda-list) - (cons (if (listp arg) (cadr arg) t) specializers) - (cons (if (listp arg) (car arg) arg) required))))))) +(defun parse-specialized-lambda-list (lambda-list) + (multiple-value-bind (required optional restp rest keyp keys + allow-other-keys-p aux morep + more-context more-count) + (kernel:parse-lambda-list lambda-list) + (declare (ignore more-context more-count)) + (when morep + (error "~@<~s is not allowed in specialized lambda-lists~@:>" :more)) + (ext:collect ((req) (spec)) + (dolist (x required) + (req (if (consp x) (car x) x)) + (spec (if (consp x) (cadr x) t))) + (values (mapcar (lambda (x) (if (consp x) (car x) x)) + (append required optional (and restp (list rest)) + keys aux)) + `(,@(req) + ,@(when optional `(&optional ,@optional)) + ,@(when restp `(&rest ,rest)) + ,@(when keyp `(&key ,@keys)) + ,@(when allow-other-keys-p `(&allow-other-keys)) + ,@(when aux `(&aux ,@aux))) + (spec) + (req))))) +#-loadable-pcl (eval-when (:load-toplevel :execute) + (/show "PCL boot state EARLY") (setq *boot-state* 'early)) (defmacro with-slots (slots instance &body body) (let ((in (gensym))) `(let ((,in ,instance)) (declare (ignorable ,in)) - ,@(let ((instance (if (and (consp instance) (eq (car instance) 'the)) + ,@(let ((instance (if (and (consp instance) + (eq (car instance) 'the)) (third instance) instance))) (and (symbolp instance) `((declare (variable-rebinding ,in ,instance))))) - ,in (symbol-macrolet ,(mapcar (lambda (slot-entry) (let ((variable-name (if (symbolp slot-entry) @@ -2037,17 +2192,16 @@ work during bootstrapping. slots) ,@body)))) - (defmacro with-accessors (slots instance &body body) (let ((in (gensym))) `(let ((,in ,instance)) (declare (ignorable ,in)) - ,@(let ((instance (if (and (consp instance) (eq (car instance) 'the)) + ,@(let ((instance (if (and (consp instance) + (eq (car instance) 'the)) (third instance) instance))) (and (symbolp instance) `((declare (variable-rebinding ,in ,instance))))) - ,in (symbol-macrolet ,(mapcar (lambda (slot-entry) (let ((variable-name (car slot-entry)) (accessor-name (cadr slot-entry))) @@ -2055,6 +2209,3 @@ work during bootstrapping. (,accessor-name ,in)))) slots) ,@body)))) - - - diff --git a/pcl/braid.lisp b/pcl/braid.lisp index 8def17ff3..d3e72692f 100644 --- a/pcl/braid.lisp +++ b/pcl/braid.lisp @@ -23,10 +23,10 @@ ;;; ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* -;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/braid.lisp,v 1.28 2002/12/18 19:16:27 pmai Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/braid.lisp,v 1.29 2003/03/22 16:15:18 gerd Exp $") + ;;; ;;; Bootstrapping the meta-braid. ;;; @@ -41,27 +41,23 @@ (in-package :pcl) (defun allocate-standard-instance (wrapper &optional (slots-init nil slots-init-p)) - (let ((instance (%%allocate-instance--class)) - (no-of-slots (wrapper-no-of-instance-slots wrapper))) + (declare #.*optImize-speed*) + (let* ((no-of-slots (kernel:layout-length wrapper)) + (instance (%%allocate-instance--class)) + (slots (make-array no-of-slots))) + (declare (fixnum no-of-slots)) + (if slots-init-p + (loop for i below no-of-slots + for init-value in slots-init do + (setf (%svref slots i) init-value)) + (loop for i below no-of-slots do + (setf (%svref slots i) +slot-unbound+))) (setf (std-instance-wrapper instance) wrapper) - (setf (std-instance-slots instance) - (cond (slots-init-p - ;; Inline the slots vector allocation and initialisation. - (let ((slots (make-array no-of-slots :initial-element 0))) - (do ((rem-slots slots-init (rest rem-slots)) - (i 0 (1+ i))) - ((>= i no-of-slots)) ;endp rem-slots)) - (declare (list rem-slots) - (type kernel:index i)) - (setf (aref slots i) (first rem-slots))) - slots)) - (t - (make-array no-of-slots - :initial-element pcl::+slot-unbound+)))) + (setf (std-instance-slots instance) slots) instance)) (defmacro allocate-funcallable-instance-slots (wrapper &optional - slots-init-p slots-init) + slots-init-p slots-init) `(let ((no-of-slots (wrapper-no-of-instance-slots ,wrapper))) ,(if slots-init-p `(if ,slots-init-p @@ -69,30 +65,21 @@ (make-array no-of-slots :initial-element +slot-unbound+)) `(make-array no-of-slots :initial-element +slot-unbound+)))) -(defun allocate-funcallable-instance (wrapper &optional (slots-init nil slots-init-p)) +(defun allocate-funcallable-instance (wrapper &optional + (slots-init nil slots-init-p)) (let ((fin (allocate-funcallable-instance-1))) (set-funcallable-instance-function fin #'(kernel:instance-lambda (&rest args) (declare (ignore args)) - (error "The function of the funcallable-instance ~S has not been set" + (error "~@<The function of the funcallable instance ~S ~ + has not been set.~@:>" fin))) (setf (fsc-instance-wrapper fin) wrapper (fsc-instance-slots fin) (allocate-funcallable-instance-slots wrapper slots-init-p slots-init)) fin)) -(defun allocate-structure-instance (wrapper &optional (slots-init nil slots-init-p)) - (let* ((class (wrapper-class wrapper)) - (constructor (class-defstruct-constructor class))) - (if constructor - (let ((instance (funcall constructor)) - (slots (class-slots class))) - (when slots-init-p - (dolist (slot slots) - (setf (slot-value-using-class class instance slot) (pop slots-init)))) - instance) - (error "Can't allocate an instance of class ~S" (class-name class))))) ;;; ;;; bootstrap-meta-braid @@ -102,8 +89,7 @@ (defmacro initial-classes-and-wrappers (&rest classes) `(progn ,@(mapcar (lambda (class) - (let ((wr (intern (format nil "~A-WRAPPER" class) - *the-pcl-package*))) + (let ((wr (symbolicate *the-pcl-package* class '-wrapper))) `(setf ,wr ,(if (eq class 'standard-generic-function) '*sgf-wrapper* `(boot-make-wrapper @@ -117,6 +103,20 @@ (find-class ',class) ,class))) classes))) +(defun set-class-translation (class name) + (let ((kernel-class (kernel::find-class name nil))) + (etypecase kernel-class + (null) + (kernel::built-in-class + (let ((translation (kernel::built-in-class-translation kernel-class))) + (setf (ext:info type translator class) + (if translation + (lambda (spec) (declare (ignore spec)) translation) + (lambda (spec) (declare (ignore spec)) kernel-class))))) + (kernel::class + (setf (ext:info type translator class) + (lambda (spec) (declare (ignore spec)) kernel-class)))))) + (defun bootstrap-meta-braid () (let* ((*create-classes-from-internal-structure-definitions-p* nil) std-class-wrapper std-class @@ -151,7 +151,8 @@ (structure-class structure-class-wrapper))) (class (or (find-class name nil) (allocate-standard-instance wrapper)))) - (when (or (eq meta 'standard-class) (eq meta 'funcallable-standard-class)) + (when (or (eq meta 'standard-class) + (eq meta 'funcallable-standard-class)) (inform-type-system-about-std-class name)) (setf (find-class name) class))) ;; @@ -193,12 +194,12 @@ (boot-make-wrapper (length slots) name)))) (proto nil)) (when (eq name t) (setq *the-wrapper-of-t* wrapper)) - (set (intern (format nil "*THE-CLASS-~A*" (symbol-name name)) - *the-pcl-package*) + (set (symbolicate *the-pcl-package* '*the-class- name '*) class) (dolist (slot slots) (unless (eq (getf slot :allocation :instance) :instance) - (error "Slot allocation ~S not supported in bootstrap."))) + (error "~@<Slot allocation ~S is not supported ~ + in bootstrap.~@:>"))) (when (typep wrapper 'wrapper) (setf (wrapper-instance-slots-layout wrapper) @@ -259,8 +260,10 @@ (defun bootstrap-initialize-class (metaclass-name class name class-eq-wrapper source direct-supers direct-subclasses cpl wrapper - &optional proto direct-slots slots direct-default-initargs default-initargs) - (flet ((classes (names) (mapcar #'find-class names)) + &optional (proto nil proto-p) + direct-slots slots direct-default-initargs default-initargs) + (flet ((classes (names) + (mapcar #'find-class names)) (set-slot (slot-name value) (bootstrap-set-slot metaclass-name class slot-name value))) (set-slot 'name name) @@ -294,6 +297,22 @@ (set-slot 'direct-slots direct-slots) (set-slot 'slots slots) (set-slot 'initialize-info nil)) + ;; + ;; For all direct superclasses SUPER of CLASS, make sure CLASS is + ;; a direct subclass of SUPER. Note that METACLASS-NAME doesn't + ;; matter here for the slot DIRECT-SUBCLASSES, since every class + ;; inherits the slot from class CLASS. + (dolist (super direct-supers) + (let* ((super (find-class super)) + (subclasses (bootstrap-get-slot metaclass-name super + 'direct-subclasses))) + (cond ((eq +slot-unbound+ subclasses) + (setf (bootstrap-get-slot metaclass-name super 'direct-subclasses) + (list class))) + ((not (memq class subclasses)) + (setf (bootstrap-get-slot metaclass-name super 'direct-subclasses) + (cons class subclasses)))))) + ;; (if (eq metaclass-name 'structure-class) (let ((constructor-sym '|STRUCTURE-OBJECT class constructor|)) (set-slot 'predicate-name (or (cadr (assoc name *early-class-predicates*)) @@ -304,7 +323,7 @@ (set-slot 'from-defclass-p t) (set-slot 'plist nil) (set-slot 'prototype (funcall constructor-sym))) - (set-slot 'prototype (or proto (allocate-standard-instance wrapper)))) + (set-slot 'prototype (if proto-p proto (allocate-standard-instance wrapper)))) class)) (defun bootstrap-make-slot-definitions (name class slots wrapper effective-p) @@ -370,9 +389,9 @@ (bootstrap-accessor-definitions1 'slot-object slot-name - (list (slot-reader-symbol slot-name)) - (list (slot-writer-symbol slot-name)) - (list (slot-boundp-symbol slot-name))))))))))) + (list (slot-reader-name slot-name)) + (list (slot-writer-name slot-name)) + (list (slot-boundp-name slot-name))))))))))) (defun bootstrap-accessor-definition (class-name accessor-name slot-name type) (multiple-value-bind (accessor-class make-method-function arglist specls doc) @@ -426,44 +445,39 @@ ;; First make sure that all the supers listed in *built-in-class-lattice* ;; are themselves defined by *built-in-class-lattice*. This is just to ;; check for typos and other sorts of brainos. - ;; (dolist (e *built-in-classes*) (dolist (super (cadr e)) (unless (or (eq super t) (assq super *built-in-classes*)) - (error "In *built-in-classes*: ~S has ~S as a super,~%~ + (error "In *built-in-classes*: ~S has ~S as a superclass,~%~ but ~S is not itself a class in *built-in-classes*." (car e) super super)))) - ;; ;; In the first pass, we create a skeletal object to be bound to the ;; class name. - ;; (let* ((built-in-class (find-class 'built-in-class)) (built-in-class-wrapper (class-wrapper built-in-class))) (dolist (e *built-in-classes*) (let ((class (allocate-standard-instance built-in-class-wrapper))) (setf (find-class (car e)) class)))) - ;; ;; In the second pass, we initialize the class objects. - ;; (let ((class-eq-wrapper (class-wrapper (find-class 'class-eq-specializer)))) (dolist (e *built-in-classes*) (destructuring-bind (name supers subs cpl prototype) e (let* ((class (find-class name)) - (lclass (lisp:find-class name)) - (wrapper (kernel:class-layout lclass))) + (lclass (kernel::find-class name)) + (wrapper (kernel:%class-layout lclass))) (set (get-built-in-class-symbol name) class) (set (get-built-in-wrapper-symbol name) wrapper) - (setf (kernel:class-pcl-class lclass) class) + (setf (kernel:%class-pcl-class lclass) class) (bootstrap-initialize-class 'built-in-class class name class-eq-wrapper nil supers subs (cons name cpl) wrapper prototype))))) - + ;; (dolist (e *built-in-classes*) (let* ((name (car e)) (class (find-class name))) @@ -485,35 +499,44 @@ (defun wrapper-of (x) (wrapper-of-macro x)) -(defvar find-structure-class nil) - (defun eval-form (form) (lambda () (eval form))) -(defun slot-initargs-from-structure-slotd (slotd) - `(:name ,(structure-slotd-name slotd) - :defstruct-accessor-symbol ,(structure-slotd-accessor-symbol slotd) - :internal-reader-function ,(structure-slotd-reader-function slotd) - :internal-writer-function ,(structure-slotd-writer-function slotd) - :type ,(or (structure-slotd-type slotd) t) - :initform ,(structure-slotd-init-form slotd) - :initfunction ,(eval-form (structure-slotd-init-form slotd)))) - -(defun find-structure-class (symbol) - (if (structure-type-p symbol) - (unless (eq find-structure-class symbol) - (let ((find-structure-class symbol)) - (ensure-class symbol - :metaclass 'structure-class - :name symbol - :direct-superclasses - (mapcar #'lisp:class-name - (kernel:class-direct-superclasses - (lisp:find-class symbol))) - :direct-slots - (mapcar #'slot-initargs-from-structure-slotd - (structure-type-slot-description-list symbol))))) - (error "~S is not a legal structure class name." symbol))) +;;; +;;; Make a non-STANDARD-CLASS for the thing with name NAME. The thing +;;; may currently either be a structure or a condition, in which +;;; case we construct either a STRUCTURE-CLASS or a CONDITION-CLASS +;;; for the corresponding KERNEL::CLASS. +;;; +(defun ensure-non-standard-class (name) + (flet ((ensure (metaclass &optional (slots nil slotsp)) + (let* ((class (kernel::find-class name)) + (kernel-supers (kernel:%class-direct-superclasses class)) + (supers (mapcar #'kernel:%class-name kernel-supers))) + (if slotsp + (ensure-class-using-class + name nil :metaclass metaclass :name name + :direct-superclasses supers + :direct-slots slots) + (ensure-class-using-class + name nil :metaclass metaclass :name name + :direct-superclasses supers)))) + (slot-initargs-from-structure-slotd (slotd) + `(:name ,(structure-slotd-name slotd) + :defstruct-accessor-symbol ,(structure-slotd-accessor-symbol slotd) + :internal-reader-function ,(structure-slotd-reader-function slotd) + :internal-writer-function ,(structure-slotd-writer-function slotd) + :type ,(or (structure-slotd-type slotd) t) + :initform ,(structure-slotd-init-form slotd) + :initfunction ,(eval-form (structure-slotd-init-form slotd))))) + (cond ((structure-type-p name) + (ensure 'structure-class + (mapcar #'slot-initargs-from-structure-slotd + (structure-type-slot-description-list name)))) + ((condition-type-p name) + (ensure 'condition-class)) + (t + (error "~@<~S is not the name of a class.~@:>" name))))) (defun method-function-returning-nil (args next-methods) @@ -561,7 +584,7 @@ ;;; (defun update-lisp-class-layout (class layout) (let ((lclass (kernel:layout-class layout))) - (unless (eq (kernel:class-layout lclass) layout) + (unless (eq (kernel:%class-layout lclass) layout) (setf (kernel:layout-inherits layout) (kernel:order-layout-inherits (map 'simple-vector #'class-wrapper @@ -572,82 +595,95 @@ ;; to lisp:find-class and also anonymous. This functionality moved ;; here from (setf find-class). (let ((name (class-name class))) - (setf (lisp:find-class name) lclass - (lisp:class-name lclass) name))))) + (setf (kernel::find-class name) lclass + (kernel:%class-name lclass) name))))) +(defun common-lisp::sxhash-instance (instance) + (get-hash instance)) + +#-loadable-pcl (eval-when (:load-toplevel :execute) + (/show "Bootstrapping PCL") (clrhash *find-class*) + (/show " meta braid") (bootstrap-meta-braid) + (/show " accessor definitions 1") (bootstrap-accessor-definitions t) + (/show " class predicates 1") (bootstrap-class-predicates t) + (/show " accessor definitions 2") (bootstrap-accessor-definitions nil) + (/show " class predicates 2") (bootstrap-class-predicates nil) + (/show " built-in classes") (bootstrap-built-in-classes) + (/show " class layouts") (ext:do-hash (name x *find-class*) (let* ((class (find-class-from-cell name x)) (layout (class-wrapper class)) (lclass (kernel:layout-class layout)) - (lclass-pcl-class (kernel:class-pcl-class lclass)) - (olclass (lisp:find-class name nil))) + (lclass-pcl-class (kernel:%class-pcl-class lclass)) + (olclass (kernel::find-class name nil))) (if lclass-pcl-class (assert (eq class lclass-pcl-class)) - (setf (kernel:class-pcl-class lclass) class)) + (setf (kernel:%class-pcl-class lclass) class)) (update-lisp-class-layout class layout) - (cond (olclass - (assert (eq lclass olclass))) - (t - (setf (lisp:find-class name) lclass))))) + (if olclass + (assert (eq lclass olclass)) + (setf (kernel::find-class name) lclass)) - (setq *boot-state* 'braid) - ) + (set-class-translation class name))) + (/show "Boot state BRAID reached") + (setq *boot-state* 'braid)) -(define-condition no-applicable-method (type-error) +(define-condition no-applicable-method-error (type-error) ((function :reader no-applicable-method-function :initarg :function) (arguments :reader no-applicable-method-arguments :initarg :arguments)) (:report (lambda (condition stream) - (format stream "No matching method for the generic-function ~S,~@ -when called with arguments ~S." + (format stream "~@<No matching method for the generic function ~ + ~S, when called with arguments ~S.~@:>" (no-applicable-method-function condition) (no-applicable-method-arguments condition))))) (defmethod no-applicable-method (generic-function &rest args) - (cerror "Retry call to ~S" - 'no-applicable-method + (cerror "Retry call to ~S." + 'no-applicable-method-error :function generic-function :arguments args) (apply generic-function args)) -(define-condition no-primary-method (no-applicable-method) - () - (:report (lambda (condition stream) - (format stream "Generic function ~S~%~ - No primary method given arguments ~S" - (no-applicable-method-function condition) - (no-applicable-method-arguments condition))))) - -(defmethod no-primary-method ((generic-function standard-generic-function) - &rest args) - (cerror "Try again." 'no-primary-method - :function generic-function :arguments args) - (apply generic-function args)) - -(define-condition no-next-method (type-error) +(define-condition no-next-method-error (type-error) ((method :reader no-next-method-method :initarg :method) (arguments :reader no-next-method-arguments :initarg :arguments)) (:report (lambda (condition stream) (format stream - "In method ~S:~%No next method for arguments ~S" + "~@<In method ~S: No next method for arguments ~S.~@:>" (no-next-method-method condition) (no-next-method-arguments condition))))) (defmethod no-next-method ((generic-function standard-generic-function) (method standard-method) &rest args) - (cerror "Try again." 'no-next-method :method method :arguments args) + (cerror "Try again." 'no-next-method-error :method method :arguments args) (apply generic-function args)) +(define-condition no-primary-method-error (no-applicable-method-error) + () + (:report (lambda (condition stream) + (format stream "~@<Generic function ~S: ~ + No primary method given arguments ~S~@:>" + (no-applicable-method-function condition) + (no-applicable-method-arguments condition))))) + +(defmethod no-primary-method ((generic-function standard-generic-function) + &rest args) + (cerror "Try again." 'no-primary-method-error + :function generic-function :arguments args) + (apply generic-function args)) +(defun %no-primary-method (gf args) + (apply #'no-primary-method gf args)) diff --git a/pcl/cache.lisp b/pcl/cache.lisp index 4fccbc03d..5bbb63c01 100644 --- a/pcl/cache.lisp +++ b/pcl/cache.lisp @@ -23,15 +23,16 @@ ;;; ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* -;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/cache.lisp,v 1.23 2002/12/18 00:57:04 pmai Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/cache.lisp,v 1.24 2003/03/22 16:15:18 gerd Exp $") + ;;; ;;; The basics of the PCL wrapper cache mechanism. ;;; (in-package :pcl) + ;;; ;;; The caching algorithm implemented: ;;; @@ -92,21 +93,27 @@ ;;; of caches will require corresponding port-specific modifications to the ;;; lap code assembler. ;;; -(defmacro cache-vector-ref (cache-vector location) - `(svref (the simple-vector ,cache-vector) - (ext:truly-the fixnum ,location))) -(defmacro cache-vector-size (cache-vector) - `(array-dimension (the simple-vector ,cache-vector) 0)) +(declaim (inline default-limit-fn)) -(defun allocate-cache-vector (size) - (make-array size :adjustable nil)) +(defun default-limit-fn (nlines) + (case nlines + ((1 2 4) 1) + ((8 16) 4) + (otherwise 6))) + +(defmacro cache-vector-ref (cache-vector location) + `(%svref ,cache-vector ,location)) + +(declaim (inline cache-vector-size)) +(defun cache-vector-size (cache-vector) + (array-dimension (the simple-vector cache-vector) 0)) (defmacro cache-vector-lock-count (cache-vector) `(cache-vector-ref ,cache-vector 0)) (defun flush-cache-vector-internal (cache-vector) - (with-pcl-lock + (with-pcl-lock (fill (the simple-vector cache-vector) nil) (setf (cache-vector-lock-count cache-vector) 0)) cache-vector) @@ -119,36 +126,57 @@ (declare (fixnum old-count)) (setf (cache-vector-lock-count ,cache-vector) (if (= old-count most-positive-fixnum) - 1 (the fixnum (1+ old-count)))))))) + 1 + (the fixnum (1+ old-count)))))))) -(deftype field-type () - '(integer 0 ;#.(position 'number wrapper-layout) - 7)) ;#.(position 'number wrapper-layout :from-end t) +(deftype layout-hash-index () + '(integer 0 #.(1- kernel:layout-hash-length))) (eval-when (:compile-toplevel :load-toplevel :execute) -(defun power-of-two-ceiling (x) - (declare (fixnum x)) - ;;(expt 2 (ceiling (log x 2))) - (the fixnum (ash 1 (integer-length (1- x))))) - -(defconstant *nkeys-limit* 256) -) + (defun power-of-two-ceiling (x) + (declare (fixnum x)) + (the fixnum (ash 1 (integer-length (1- x))))) + + (defconstant *nkeys-limit* 256)) (defstruct (cache (:print-function print-cache) (:constructor make-cache ()) (:copier copy-cache-internal)) (owner nil) + ;; + ;; Number of wrappers used as keys in each cache line. (nkeys 1 :type (integer 1 #.*nkeys-limit*)) + ;; + ;; True if keys are followed by a value in the cache. (valuep nil :type (member nil t)) + ;; + ;; Number of cache lines, that is, number of entries in the cache + ;; vector. (nlines 0 :type fixnum) - (field 0 :type field-type) - (limit-fn #'default-limit-fn :type function) + ;; + ;; Index with which to call KERNEL:LAYOUT-HASH when computing + ;; the position of a set of wrappers in the cache. + (field 0 :type layout-hash-index) + ;; + ;; Mask value with which to LOGAND the hash code of a set of + ;; wrappers. (mask 0 :type fixnum) + ;; + ;; The size of the cache vector. (size 0 :type fixnum) + ;; + ;; The size of a line in the cache. (line-size 1 :type (integer 1 #.(power-of-two-ceiling (1+ *nkeys-limit*)))) + ;; + ;; Start index of the last cache line (cache entry) in VECTOR. (max-location 0 :type fixnum) + ;; + ;; The cache vector itself, holding the cache lines. Empty entries + ;; are filled with NIL. (vector #() :type simple-vector) + ;; + ;; List of entries not fitting in VECTOR. (overflow nil :type list)) (declaim (ext:freeze-type cache)) @@ -159,44 +187,27 @@ (format stream "cache ~D ~S ~D" (cache-nkeys cache) (cache-valuep cache) (cache-nlines cache)))) -(defmacro cache-lock-count (cache) - `(cache-vector-lock-count (cache-vector ,cache))) - ;;; -;;; Return a cache that has had flush-cache-vector-internal called on it. This -;;; returns a cache of exactly the size requested, it won't ever return a -;;; larger cache. -;;; +;;; Return a cache that has had flush-cache-vector-internal called on +;;; it. This returns a cache of exactly the size requested, it won't +;;; ever return a larger cache. +;;; (defun get-cache-vector (size) (flush-cache-vector-internal (make-array size))) ;;; -;;; Wrapper cache numbers -;;; - -;;; -;;; The constant WRAPPER-CACHE-NUMBER-ADDS-OK controls the number of non-zero -;;; bits wrapper cache numbers will have. +;;; The constant +MAX-HASH-CODE-ADDITIONS+ controls the number of +;;; non-zero bits wrapper cache numbers will have. ;;; ;;; The value of this constant is the number of wrapper cache numbers which ;;; can be added and still be certain the result will be a fixnum. This is ;;; used by all the code that computes primary cache locations from multiple ;;; wrappers. -;;; -;;; The value of this constant is used to derive the next two which are the -;;; forms of this constant which it is more convenient for the runtime code -;;; to use. ;;; -(progn - (defconstant wrapper-cache-number-length - (integer-length kernel:layout-hash-max)) - - (defconstant wrapper-cache-number-mask kernel:layout-hash-max) - - (defconstant wrapper-cache-number-adds-ok - (truncate most-positive-fixnum kernel:layout-hash-max))) +(defconstant +max-hash-code-additions+ + (truncate most-positive-fixnum kernel:layout-hash-max)) ;;; @@ -221,47 +232,48 @@ ;;; idea. ;;; -; In CMUCL we want to do type checking as early as possible; structures help this. - -(eval-when (:compile-toplevel :load-toplevel :execute) - -(defconstant wrapper-cache-number-vector-length - kernel:layout-hash-length) - -(defconstant wrapper-layout (make-list wrapper-cache-number-vector-length - :initial-element 'number)) -) - +;;; In CMUCL we want to do type checking as early as possible; +;;; structures help this. -(progn +(unless (boundp '*the-class-t*) + (setq *the-class-t* nil)) -(unless (boundp '*the-class-t*) (setq *the-class-t* nil)) - -;;; Note that for CMU, the WRAPPER of a built-in or structure class will be -;;; some other kind of KERNEL:LAYOUT, but this shouldn't matter, since the only -;;; two slots that WRAPPER adds are meaningless in those cases. ;;; - +;;; Note that for CMU, the WRAPPER of a built-in or structure class +;;; will be some other kind of KERNEL:LAYOUT, but this shouldn't +;;; matter, since the only two slots that WRAPPER adds are meaningless +;;; in those cases. +;;; (defstruct (wrapper (:include kernel:layout) (:conc-name %wrapper-) (:print-function print-wrapper) (:constructor make-wrapper-internal)) + ;; + ;; List of all instance slot names. The position of a slot name + ;; in this list determines the location of its slot in an instance's + ;; slot value vector. (instance-slots-layout nil :type list) + ;; + ;; Alist of pairs (SLOT-NAME . VALUE) for class slots. Pairs are + ;; shared with subclasses inheriting a class slot. (class-slots nil :type list)) + (declaim (ext:freeze-type wrapper)) (defmacro wrapper-class (wrapper) - `(kernel:class-pcl-class (kernel:layout-class ,wrapper))) + `(kernel:%class-pcl-class (kernel:layout-class ,wrapper))) + (defmacro wrapper-no-of-instance-slots (wrapper) `(kernel:layout-length ,wrapper)) (defmacro wrapper-instance-slots-layout (wrapper) `(%wrapper-instance-slots-layout ,wrapper)) + (defmacro wrapper-class-slots (wrapper) `(%wrapper-class-slots ,wrapper)) -(defmacro wrapper-cache-number-vector (x) x)) +;;; ;;; BOOT-MAKE-WRAPPER -- Interface ;;; ;;; Called in BRAID when we are making wrappers for classes whose slots are @@ -269,13 +281,13 @@ ;;; class name in addition to the class. ;;; (defun boot-make-wrapper (length name &optional class) - (let ((found (lisp:find-class name nil))) + (let ((found (kernel::find-class name nil))) (cond (found - (unless (kernel:class-pcl-class found) - (setf (kernel:class-pcl-class found) class)) - (assert (eq (kernel:class-pcl-class found) class)) - (let ((layout (kernel:class-layout found))) + (unless (kernel:%class-pcl-class found) + (setf (kernel:%class-pcl-class found) class)) + (assert (eq (kernel:%class-pcl-class found) class)) + (let ((layout (kernel:%class-layout found))) (assert layout) layout)) (t @@ -300,63 +312,46 @@ ;;; lisp:class and pcl::class objects. ;;; (defun make-wrapper (length class) - (cond - ((typep class 'std-class) - (kernel:initialize-layout-hash - (make-wrapper-internal - :length length - :class - (let ((owrap (class-wrapper class))) - (cond (owrap - (kernel:layout-class owrap)) - ((*subtypep (class-of class) - *the-class-standard-class*) - (cond ((and *pcl-class-boot* - (eq (slot-value class 'name) *pcl-class-boot*)) - (let ((found (lisp:find-class (slot-value class 'name)))) - (unless (kernel:class-pcl-class found) - (setf (kernel:class-pcl-class found) class)) - (assert (eq (kernel:class-pcl-class found) class)) - found)) - (t - (kernel:make-standard-class :pcl-class class)))) - (t - (kernel:make-random-pcl-class :pcl-class class))))))) - (t - (let* ((found (lisp:find-class (slot-value class 'name))) - (layout (kernel:class-layout found))) - (unless (kernel:class-pcl-class found) - (setf (kernel:class-pcl-class found) class)) - (assert (eq (kernel:class-pcl-class found) class)) - (assert layout) - layout)))) + (cond ((typep class 'std-class) + (kernel:initialize-layout-hash + (make-wrapper-internal + :length length + :class + (let ((owrap (class-wrapper class))) + (cond (owrap + (kernel:layout-class owrap)) + ((*subtypep (class-of class) *the-class-standard-class*) + (cond ((and *pcl-class-boot* + (eq (slot-value class 'name) *pcl-class-boot*)) + (let ((found (kernel::find-class + (slot-value class 'name)))) + (unless (kernel:%class-pcl-class found) + (setf (kernel:%class-pcl-class found) class)) + (assert (eq (kernel:%class-pcl-class found) class)) + found)) + (t + (kernel:make-standard-class :pcl-class class)))) + (t + (kernel:make-random-pcl-class :pcl-class class))))))) + (t + (let* ((found (kernel::find-class (slot-value class 'name))) + (layout (kernel:%class-layout found))) + (unless (kernel:%class-pcl-class found) + (setf (kernel:%class-pcl-class found) class)) + (assert (eq (kernel:%class-pcl-class found) class)) + (assert layout) + layout)))) (defun print-wrapper (wrapper stream depth) (declare (ignore depth)) (printing-random-thing (wrapper stream) (format stream "Wrapper ~S" (wrapper-class wrapper)))) -(defmacro first-wrapper-cache-number-index () - 0) - -(defmacro next-wrapper-cache-number-index (field-number) - `(and (< ,field-number #.(1- wrapper-cache-number-vector-length)) - (1+ ,field-number))) - -(defmacro cache-number-vector-ref (cnv n) - `(wrapper-cache-number-vector-ref ,cnv ,n)) - -(defmacro wrapper-cache-number-vector-ref (wrapper n) - `(kernel:layout-hash ,wrapper ,n)) - -(defmacro class-no-of-instance-slots (class) - `(wrapper-no-of-instance-slots (class-wrapper ,class))) - (defmacro wrapper-class* (wrapper) `(let ((wrapper ,wrapper)) (or (wrapper-class wrapper) - (find-structure-class - (lisp:class-name (kernel:layout-class wrapper)))))) + (ensure-non-standard-class + (kernel:%class-name (kernel:layout-class wrapper)))))) ;;; ;;; The wrapper cache machinery provides general mechanism for trapping on @@ -369,10 +364,9 @@ ;;; it means that any attempt to do a wrapper cache lookup using the wrapper ;;; should trap. Also, methods on slot-value-using-class check the wrapper ;;; validity as well. This is done by calling check-wrapper-validity. -;;; +;;; (declaim (inline invalid-wrapper-p)) - (defun invalid-wrapper-p (wrapper) (not (null (kernel:layout-invalid wrapper)))) @@ -417,14 +411,12 @@ (obsolete-instance-trap owrapper (second state) instance)))))) (declaim (inline check-obsolete-instance)) - (defun check-obsolete-instance (instance) (when (invalid-wrapper-p (kernel:layout-of instance)) (check-wrapper-validity instance))) - -(defun get-cache (nkeys valuep limit-fn nlines) +(defun get-cache (nkeys valuep nlines) (let ((cache (make-cache))) (declare (type cache cache)) (multiple-value-bind (cache-mask actual-size line-size nlines) @@ -432,8 +424,7 @@ (setf (cache-nkeys cache) nkeys (cache-valuep cache) valuep (cache-nlines cache) nlines - (cache-field cache) (first-wrapper-cache-number-index) - (cache-limit-fn cache) limit-fn + (cache-field cache) 0 (cache-mask cache) cache-mask (cache-size cache) actual-size (cache-line-size cache) line-size @@ -445,8 +436,7 @@ (cache-overflow cache) nil) cache))) -(defun get-cache-from-cache (old-cache new-nlines - &optional (new-field (first-wrapper-cache-number-index))) +(defun get-cache-from-cache (old-cache new-nlines &optional (new-field 0)) (let ((nkeys (cache-nkeys old-cache)) (valuep (cache-valuep old-cache)) (cache (make-cache))) @@ -461,7 +451,6 @@ (cache-valuep cache) valuep (cache-nlines cache) nlines (cache-field cache) new-field - (cache-limit-fn cache) (cache-limit-fn old-cache) (cache-mask cache) cache-mask (cache-size cache) actual-size (cache-line-size cache) line-size @@ -489,7 +478,6 @@ (power-of-two-ceiling x)) (defun compute-cache-parameters (nkeys valuep nlines-or-cache-vector) - ;;(declare (values cache-mask actual-size line-size nlines)) (declare (fixnum nkeys)) (if (= nkeys 1) (let* ((line-size (if valuep 2 1)) @@ -501,7 +489,8 @@ nlines-or-cache-vector)))) (cache-vector-size nlines-or-cache-vector)))) (declare (fixnum line-size cache-size)) - (values (logxor (the fixnum (1- cache-size)) (the fixnum (1- line-size))) + (values (logxor (the fixnum (1- cache-size)) + (the fixnum (1- line-size))) cache-size line-size (the (values fixnum t) (floor cache-size line-size)))) @@ -514,13 +503,13 @@ nlines-or-cache-vector)))) (1- (cache-vector-size nlines-or-cache-vector))))) (declare (fixnum line-size cache-size)) - (values (logxor (the fixnum (1- cache-size)) (the fixnum (1- line-size))) + (values (logxor (the fixnum (1- cache-size)) + (the fixnum (1- line-size))) (the fixnum (1+ cache-size)) line-size (the (values fixnum t) (floor cache-size line-size)))))) - ;;; ;;; The various implementations of computing a primary cache location from ;;; wrappers. Because some implementations of this must run fast there are @@ -540,31 +529,42 @@ ;;; The basic functional version. This is used by the cache miss code to ;;; compute the primary location of an entry. ;;; -(defun compute-primary-cache-location (field mask wrappers) - (declare (type field-type field) (fixnum mask)) +#-pcl-xorhash +(defun compute-primary-cache-location (hash-index mask wrappers) + (declare (type layout-hash-index hash-index) (fixnum mask) + #.*optimize-speed*) (if (not (listp wrappers)) - (logand mask (the fixnum (wrapper-cache-number-vector-ref wrappers field))) - (let ((location 0) (i 0)) - (declare (fixnum location i)) - (dolist (wrapper wrappers) - ;; - ;; First add the cache number of this wrapper to location. - ;; - (let ((wrapper-cache-number (wrapper-cache-number-vector-ref wrapper field))) - (declare (fixnum wrapper-cache-number)) - (if (zerop wrapper-cache-number) - (return-from compute-primary-cache-location 0) - (setq location (the fixnum (+ location wrapper-cache-number))))) - ;; - ;; Then, if we are working with lots of wrappers, deal with - ;; the wrapper-cache-number-mask stuff. - ;; - (when (and (not (zerop i)) - (zerop (mod i wrapper-cache-number-adds-ok))) - (setq location - (logand location wrapper-cache-number-mask))) - (incf i)) - (the fixnum (1+ (logand mask location)))))) + (logand mask (the fixnum (kernel:layout-hash wrappers hash-index))) + (loop with location of-type fixnum = 0 + for i of-type fixnum from 0 and wrapper in wrappers + as hash of-type fixnum = (kernel:layout-hash wrapper hash-index) + if (zerop hash) do + ;; Invalid wrapper. + (return-from compute-primary-cache-location 0) + else do + (setq location (the fixnum (+ location hash))) + (when (and (not (zerop i)) + (zerop (mod i +max-hash-code-additions+))) + (setq location (logand location kernel:layout-hash-max))) + end + finally + (return (the fixnum (1+ (logand mask location))))))) + +#+pcl-xorhash +(defun compute-primary-cache-location (hash-index mask wrappers) + (declare (type layout-hash-index hash-index) (fixnum mask) + #.*optimize-speed*) + (if (not (listp wrappers)) + (logand mask (the fixnum (kernel:layout-hash wrappers hash-index))) + (loop with location of-type fixnum = 0 + for wrapper in wrappers + as hash of-type fixnum = (kernel:layout-hash wrapper hash-index) + if (invalid-wrapper-p wrapper) do + (return-from compute-primary-cache-location 0) + else do + (setq location (logxor location hash)) + finally + (return (the fixnum (1+ (logand mask location))))))) ;;; ;;; COMPUTE-PRIMARY-CACHE-LOCATION-FROM-LOCATION @@ -578,28 +578,44 @@ ;;; invalid to suggest to its caller that it would be provident to blow away ;;; the cache line in question. ;;; -(defun compute-primary-cache-location-from-location (to-cache from-location - &optional (from-cache to-cache)) +#-pcl-xorhash +(defun compute-primary-cache-location-from-location + (to-cache from-location &optional (from-cache to-cache)) (declare (type cache to-cache from-cache) (fixnum from-location)) - (let ((result 0) - (cache-vector (cache-vector from-cache)) - (field (cache-field to-cache)) - (mask (cache-mask to-cache)) - (nkeys (cache-nkeys to-cache))) - (declare (type field-type field) (fixnum result mask nkeys) - (simple-vector cache-vector)) - (dotimes (i nkeys) - (declare (fixnum i)) - (let* ((wrapper (cache-vector-ref cache-vector (+ i from-location))) - (wcn (wrapper-cache-number-vector-ref wrapper field))) - (declare (fixnum wcn)) - (setq result (+ result wcn))) - (when (and (not (zerop i)) - (zerop (mod i wrapper-cache-number-adds-ok))) - (setq result (logand result wrapper-cache-number-mask)))) - (if (= nkeys 1) - (logand mask result) - (the fixnum (1+ (logand mask result)))))) + (loop with result of-type fixnum = 0 + with hash-index of-type layout-hash-index = (cache-field to-cache) + with mask of-type fixnum = (cache-mask to-cache) + with nkeys of-type fixnum = (cache-nkeys to-cache) + with cache-vector of-type simple-vector = (cache-vector from-cache) + for i of-type fixnum below nkeys + for wrapper = (cache-vector-ref cache-vector (+ i from-location)) + for hash = (kernel:layout-hash wrapper hash-index) do + (setq result (+ result hash)) + (when (and (not (zerop i)) + (zerop (mod i +max-hash-code-additions+))) + (setq result (logand result kernel:layout-hash-max))) + finally + (return (if (= nkeys 1) + (logand mask result) + (the fixnum (1+ (logand mask result))))))) + +#+pcl-xorhash +(defun compute-primary-cache-location-from-location + (to-cache from-location &optional (from-cache to-cache)) + (declare (type cache to-cache from-cache) (fixnum from-location)) + (loop with result of-type fixnum = 0 + with hash-index of-type layout-hash-index = (cache-field to-cache) + with mask of-type fixnum = (cache-mask to-cache) + with nkeys of-type fixnum = (cache-nkeys to-cache) + with cache-vector of-type simple-vector = (cache-vector from-cache) + for i of-type fixnum below nkeys + for wrapper = (cache-vector-ref cache-vector (+ i from-location)) + as hash = (kernel:layout-hash wrapper hash-index) do + (setq result (logxor result hash)) + finally + (return (if (= nkeys 1) + (logand mask result) + (the fixnum (1+ (logand mask result))))))) ;;; @@ -618,6 +634,7 @@ (standard (find-class 'standard-class)) (fsc (find-class 'funcallable-standard-class)) (structure (find-class 'structure-class)) + (condition (find-class 'condition-class)) (built-in (find-class 'built-in-class))) (flet ((specializer->metatype (x) (let ((meta-specializer @@ -628,10 +645,12 @@ ((*subtypep meta-specializer std) 'standard-instance) ((*subtypep meta-specializer standard) 'standard-instance) ((*subtypep meta-specializer fsc) 'standard-instance) + ((*subtypep meta-specializer condition) 'condition-instance) ((*subtypep meta-specializer structure) 'structure-instance) ((*subtypep meta-specializer built-in) 'built-in-instance) ((*subtypep meta-specializer slot) 'slot-instance) - (t (error "PCL can not handle the specializer ~S (meta-specializer ~S)." + (t (error "~@<PCL cannot handle the specializer ~S ~ + (meta-specializer ~S).~@:>" new-specializer meta-specializer)))))) ;; ;; We implement the following table. The notation is @@ -691,9 +710,7 @@ (let* (,@(when wrappers `((,wrappers (nreverse wrappers-rev)) (,classes (nreverse classes-rev)) - (,types (mapcar (lambda (class) - `(class-eq ,class)) - ,classes))))) + (,types (nreverse types-rev))))) ,@body)))) @@ -754,7 +771,6 @@ (valuep () (cache-valuep .cache.)) (nlines () (cache-nlines .cache.)) (max-location () (cache-max-location .cache.)) - (limit-fn () (cache-limit-fn .cache.)) (size () (cache-size .cache.)) (mask () (cache-mask .cache.)) (field () (cache-field .cache.)) @@ -783,7 +799,7 @@ (line-location (line) (declare (fixnum line)) (when (line-reserved-p line) - (error "line is reserved")) + (internal-error "Line is reserved.")) (if (= (nkeys) 1) (the fixnum (* line (line-size))) (the fixnum (1+ (the fixnum (* line (line-size))))))) @@ -805,7 +821,8 @@ ;; (line-wrappers (line) (declare (fixnum line)) - (when (line-reserved-p line) (error "Line is reserved.")) + (when (line-reserved-p line) + (internal-error "Line is reserved.")) (location-wrappers (line-location line))) ;; (location-wrappers (location) ; avoid multiplies caused by line-location @@ -845,7 +862,8 @@ ;; (line-value (line) (declare (fixnum line)) - (when (line-reserved-p line) (error "Line is reserved.")) + (when (line-reserved-p line) + (internal-error "Line is reserved.")) (location-value (line-location line))) ;; (location-value (loc) @@ -857,7 +875,8 @@ ;; it. The state of the wrappers stored in the line is not ;; checked. An error is signalled if line is reserved. (line-full-p (line) - (when (line-reserved-p line) (error "Line is reserved.")) + (when (line-reserved-p line) + (internal-error "Line is reserved.")) (not (null (cache-vector-ref (vector) (line-location line))))) ;; ;; Given a line number, return true IFF the line is full and @@ -867,7 +886,8 @@ ;; (line-valid-p (line wrappers) (declare (fixnum line)) - (when (line-reserved-p line) (error "Line is reserved.")) + (when (line-reserved-p line) + (internal-error "Line is reserved.")) (location-valid-p (line-location line) wrappers)) ;; (location-valid-p (loc wrappers) @@ -888,7 +908,7 @@ ;; ;; How many unreserved lines separate line-1 and line-2. ;; - (line-separation (line-1 line-2) + (line-distance (line-1 line-2) (declare (fixnum line-1 line-2)) (let ((diff (the fixnum (- line-2 line-1)))) (declare (fixnum diff)) @@ -930,7 +950,7 @@ (compute-primary-cache-location-from-location (cache) (line-location line)))) (declare (ignorable #'cache #'nkeys #'line-size #'vector #'valuep - #'nlines #'max-location #'limit-fn #'size + #'nlines #'max-location #'size #'mask #'field #'overflow #'line-reserved-p #'location-reserved-p #'line-location #'location-line #'line-wrappers #'location-wrappers @@ -938,7 +958,7 @@ #'location-matches-wrappers-p #'line-value #'location-value #'line-full-p #'line-valid-p #'location-valid-p - #'line-separation #'next-line #'next-location + #'line-distance #'next-line #'next-location #'line-primary #'line-primary-location)) ,@body))) @@ -960,10 +980,7 @@ ;;; find an entry. Furthermore, adjusting has the nice property of throwing out ;;; any entries that are invalid. ;;; -(defvar *cache-expand-threshold* 1.25) - (defun fill-cache (cache wrappers value) - ;;(declare (values cache)) ;; fill-cache won't return if wrappers is nil, might as well check. (assert wrappers) (or (fill-cache-p nil cache wrappers value) @@ -985,7 +1002,7 @@ (defun check-cache (cache) (with-local-cache-functions (cache) (let ((location (if (= (nkeys) 1) 0 1)) - (limit (funcall (limit-fn) (nlines)))) + (limit (default-limit-fn (nlines)))) (dotimes (i (nlines) cache) (declare (fixnum i)) (when (and (not (location-reserved-p location)) @@ -995,33 +1012,166 @@ (home (location-line (if (location-reserved-p home-loc) (next-location home-loc) home-loc))) - (sep (when home (line-separation home i)))) + (sep (when home (line-distance home i)))) (when (and sep (> sep limit)) - (error "bad cache ~S ~@ - value at location ~D is ~D lines from its home. limit is ~D." - cache location sep limit)))) + (internal-error "~@<Bad cache ~S: Value at location ~D is ~D ~ + lines from its home, limit is ~D.~@:>" + cache location sep limit)))) (setq location (next-location location)))))) -(defun probe-cache (cache wrappers &optional default limit-fn) - ;;(declare (values value)) - (unless wrappers (error "probe-cache: wrappers arg is NIL!")) - (with-local-cache-functions (cache) - (let* ((location (compute-primary-cache-location (field) (mask) wrappers)) - (limit (funcall (or limit-fn (limit-fn)) (nlines)))) - (declare (fixnum location limit)) - (when (location-reserved-p location) - (setq location (next-location location))) - (dotimes (i (1+ limit)) - (declare (fixnum i)) - (when (location-matches-wrappers-p location wrappers) - (return-from probe-cache (or (not (valuep)) - (location-value location)))) - (setq location (next-location location))) - (dolist (entry (overflow)) - (when (equal (car entry) wrappers) - (return-from probe-cache (or (not (valuep)) - (cdr entry))))) - default))) +#+nil +(defun probe-cache (cache wrappers default) + (declare #.*optimize-speed*) + (assert wrappers) + (macrolet ((probe (nwrappers) + `(loop with primary of-type fixnum + = (compute-primary-cache-location (cache-field cache) + (cache-mask cache) + wrappers) + with line-size of-type fixnum + = (cache-line-size cache) + with max-location of-type fixnum + = (cache-max-location cache) + with nkeys of-type fixnum + = (cache-nkeys cache) + with cache-vector of-type simple-vector + = (cache-vector cache) + for location of-type fixnum = primary + then (if (= location max-location) + 1 + (the fixnum (+ location line-size))) + for i of-type fixnum upto limit + for w = wrappers do + (when (and ,@(loop for i below nwrappers + collect `(eq (%svref cache-vector (+ ,i location)) + (pop w)))) + (return-from probe-cache + (or (not (cache-valuep cache)) + (%svref cache-vector + (+ location ,nwrappers)))))))) + (let ((limit (default-limit-fn (cache-nlines cache)))) + (declare (fixnum limit)) + (case (cache-nkeys cache) + (1 + (loop with primary of-type fixnum + = (logand (cache-mask cache) + (the fixnum (kernel:layout-hash + (if (listp wrappers) + (car wrappers) + wrappers) + (cache-field cache)))) + with line-size of-type fixnum = (cache-line-size cache) + with max-location of-type fixnum = (cache-max-location cache) + with cache-vector of-type simple-vector = (cache-vector cache) + for location of-type fixnum + = (if (zerop primary) + (if (= primary max-location) + line-size + (the fixnum (+ primary line-size))) + primary) + then (if (= location max-location) + line-size + (the fixnum (+ location line-size))) + for i of-type fixnum upto limit + when (eq wrappers (%svref cache-vector location)) do + (return-from probe-cache + (or (not (cache-valuep cache)) + (%svref cache-vector (1+ location)))))) + (2 (probe 2)) + (3 (probe 3)) + (4 (probe 4)) + (5 (probe 5)) + (6 (probe 6)) + (otherwise + (loop with primary of-type fixnum + = (compute-primary-cache-location (cache-field cache) + (cache-mask cache) + wrappers) + with line-size of-type fixnum = (cache-line-size cache) + with max-location of-type fixnum = (cache-max-location cache) + with nkeys of-type fixnum = (cache-nkeys cache) + with cache-vector of-type simple-vector = (cache-vector cache) + for location of-type fixnum = primary + then (if (= location max-location) + 1 + (the fixnum (+ location line-size))) + for i of-type fixnum upto limit do + (loop with w = wrappers + for i of-type fixnum from location + repeat nkeys + while (eq (%svref cache-vector i) (pop w)) + finally + (when (null w) + (return-from probe-cache + (or (not (cache-valuep cache)) + (%svref cache-vector (+ location nkeys)))))))))) + (loop for entry in (cache-overflow cache) + when (equal (car entry) wrappers) do + (return-from probe-cache (or (not (cache-valuep cache)) + (cdr entry)))) + default)) + +#-nil +(defun probe-cache (cache wrappers &optional default) + (declare #.*optimize-speed*) + (assert wrappers) + (let ((limit (default-limit-fn (cache-nlines cache)))) + (declare (fixnum limit)) + (if (= (cache-nkeys cache) 1) + (loop with primary of-type fixnum + = (logand (cache-mask cache) + (the fixnum (kernel:layout-hash + (if (listp wrappers) + (car wrappers) + wrappers) + (cache-field cache)))) + with line-size of-type fixnum = (cache-line-size cache) + with max-location of-type fixnum = (cache-max-location cache) + with cache-vector of-type simple-vector = (cache-vector cache) + for location of-type fixnum + = (if (zerop primary) + (if (= primary max-location) + line-size + (the fixnum (+ primary line-size))) + primary) + then (if (= location max-location) + line-size + (the fixnum (+ location line-size))) + for i of-type fixnum upto limit + when (eq wrappers (%svref cache-vector location)) do + (return-from probe-cache + (or (not (cache-valuep cache)) + (%svref cache-vector (1+ location))))) + (loop with primary of-type fixnum + = (compute-primary-cache-location (cache-field cache) + (cache-mask cache) + wrappers) + with line-size of-type fixnum = (cache-line-size cache) + with max-location of-type fixnum = (cache-max-location cache) + with nkeys of-type fixnum = (cache-nkeys cache) + with cache-vector of-type simple-vector = (cache-vector cache) + for location of-type fixnum = primary + then (if (= location max-location) + 1 + (the fixnum (+ location line-size))) + for i of-type fixnum upto limit do + (loop with found? = t + repeat nkeys + for i of-type fixnum from location + for wrapper in wrappers + unless (eq (%svref cache-vector i) wrapper) do + (setq found? nil) + (loop-finish) + finally + (when found? + (return-from probe-cache + (or (not (cache-valuep cache)) + (%svref cache-vector (+ location nkeys))))))))) + (loop for entry in (cache-overflow cache) + when (equal (car entry) wrappers) do + (return-from probe-cache (or (not (cache-valuep cache)) + (cdr entry)))) + default) (defun map-cache (function cache &optional set-p) (with-local-cache-functions (cache) @@ -1041,22 +1191,9 @@ (defun cache-count (cache) (with-local-cache-functions (cache) - (let ((count 0)) - (declare (fixnum count)) - (dotimes (i (nlines) count) - (declare (fixnum i)) - (unless (line-reserved-p i) - (when (line-full-p i) - (incf count))))))) - -(defun entry-in-cache-p (cache wrappers value) - (declare (ignore value)) - (with-local-cache-functions (cache) - (dotimes (i (nlines)) - (declare (fixnum i)) - (unless (line-reserved-p i) - (when (equal (line-wrappers i) wrappers) - (return t)))))) + (loop for i of-type fixnum below (nlines) + count (and (not (line-reserved-p i)) + (line-full-p i))))) ;;; ;;; returns T or NIL @@ -1076,7 +1213,7 @@ (let ((line free)) (declare (fixnum line)) (when (line-reserved-p line) - (error "Attempt to fill a reserved line.")) + (internal-error "Attempt to fill a reserved cache line.")) (let ((loc (line-location line)) (cache-vector (vector))) (declare (fixnum loc) (simple-vector cache-vector)) @@ -1113,7 +1250,8 @@ (to-line free)) (declare (fixnum to-line)) (if (line-reserved-p to-line) - (error "transfering something into a reserved cache line.") + (internal-error + "Transfering something into a reserved cache line.") (let ((from-loc (line-location from-line)) (to-loc (line-location to-line))) (declare (fixnum from-loc to-loc)) @@ -1161,12 +1299,12 @@ (progn (return (maybe-check-cache ncache))) (flush-cache-vector-internal (cache-vector ncache)))))))) + ;;; ;;; returns: (values <cache>) ;;; (defun expand-cache (cache wrappers value) - ;;(declare (values cache)) (with-local-cache-functions (cache) (let ((ncache (get-cache-from-cache cache (* (nlines) 2)))) (labels ((do-one-fill-from-line (line) @@ -1191,8 +1329,8 @@ ;;; -;;; This is the heart of the cache filling mechanism. It implements the decisions -;;; about where entries are placed. +;;; This is the heart of the cache filling mechanism. It implements +;;; the decisions about where entries are placed. ;;; ;;; Find a line in the cache at which a new entry can be inserted. ;;; @@ -1200,11 +1338,11 @@ ;;; <empty?> is <line> in fact empty? ;;; (defun find-free-cache-line (primary cache &optional wrappers) - ;;(declare (values line empty?)) (declare (fixnum primary)) (with-local-cache-functions (cache) - (when (line-reserved-p primary) (setq primary (next-line primary))) - (let ((limit (funcall (limit-fn) (nlines))) + (when (line-reserved-p primary) + (setq primary (next-line primary))) + (let ((limit (default-limit-fn (nlines))) (wrappedp nil) (lines nil) (p primary) (s primary)) @@ -1215,16 +1353,17 @@ ;; primary line of the entry we are finding a free ;; line for, it is used to compute the seperations. (do* ((line s (next-line line)) - (nsep (line-separation p s) (1+ nsep))) + (nsep (line-distance p s) (1+ nsep))) (()) (declare (fixnum line nsep)) - (when (null (line-valid-p line wrappers)) ;If this line is empty or - (push line lines) ;invalid, just use it. + ;;If this line is empty or invalid, just use it. + (when (null (line-valid-p line wrappers)) + (push line lines) (return-from find-free)) (when (and wrappedp (>= line primary)) ;; have gone all the way around the cache, time to quit (return-from find-free-cache-line (values primary nil))) - (let ((osep (line-separation (line-primary line) line))) + (let ((osep (line-distance (line-primary line) line))) (when (>= osep limit) (return-from find-free-cache-line (values primary nil))) (when (cond ((= nsep limit) t) @@ -1233,15 +1372,18 @@ (t nil)) ;; See if we can displace what is in this line so that we ;; can use the line. - (when (= line (the fixnum (1- (nlines)))) (setq wrappedp t)) + (when (= line (the fixnum (1- (nlines)))) + (setq wrappedp t)) (setq p (line-primary line)) (setq s (next-line line)) (push line lines) (return nil))) - (when (= line (the fixnum (1- (nlines)))) (setq wrappedp t))))) + (when (= line (the fixnum (1- (nlines)))) + (setq wrappedp t))))) ;; Do all the displacing. (loop - (when (null (cdr lines)) (return nil)) + (when (null (cdr lines)) + (return nil)) (let ((dline (pop lines)) (line (car lines))) (declare (fixnum dline line)) @@ -1259,10 +1401,3 @@ nil)))))) (values (car lines) t)))) -(defun default-limit-fn (nlines) - (case nlines - ((1 2 4) 1) - ((8 16) 4) - (otherwise 6))) - -(defvar *empty-cache* (make-cache)) ; for defstruct slot initial value forms diff --git a/pcl/clos-bench.lisp b/pcl/clos-bench.lisp new file mode 100644 index 000000000..608725207 --- /dev/null +++ b/pcl/clos-bench.lisp @@ -0,0 +1,731 @@ +;;; Copyright (C) 2002, 2003 Gerd Moellmann <gerd.moellmann@t-online.de> +;;; All rights reserved. +;;; +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: +;;; +;;; 1. Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. +;;; 2. Redistributions in binary form must reproduce the above copyright +;;; notice, this list of conditions and the following disclaimer in the +;;; documentation and/or other materials provided with the distribution. +;;; 3. The name of the author may not be used to endorse or promote +;;; products derived from this software without specific prior written +;;; permission. +;;; +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE +;;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +;;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT +;;; OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR +;;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE +;;; USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH +;;; DAMAGE. + +;;; This is a hacked version of bench.lisp originally found in PCL, +;;; which contained the following comment: + +;;;Here are a few homebrew benchmarks for testing out Lisp performance. +;;; BENCH-THIS-LISP: benchmarks for common lisp. +;;; BENCH-THIS-CLOS: benchmarks for CLOS. +;;; BENCH-FLAVORS: ditto for Symbolics flavors. +;;; BE SURE TO CHANGE THE PACKAGE DEFINITION TO GET THE CLOS + LISP YOU WANT TO TEST. +;;; +;;;Each benchmark is reported as operations per second. Without-interrupts is used, +;;; so the scheduler isn't supposed to get in the way. Accuracy is generally +;;; between one and five percent. +;;; +;;;Elapsed time is measured using get-internal-run-time. Because the accuracy of +;;; this number is fairly crude, it is important to use a large number of +;;; iterations to get an accurate benchmark. The function median-time may +;;; complain to you if you didn't pick enough iterations. +;;; +;;;July 1992. Watch out! In some cases the instruction being timed will be +;;; optimized away by a clever compiler. Beware of benchmarks that are +;;; nearly as fast as *speed-of-empty-loop*. +;;; +;;;Thanks to Ken Anderson for much of this code. +;;; +;;; jeff morrill +;;; jmorrill@bbn.com + +#+cmu +(ext:file-comment "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/clos-bench.lisp,v 1.2 2003/03/22 16:15:18 gerd Exp $") + +#+cmu +(eval-when (:compile-toplevel :load-toplevel :execute) + (import '(pcl:allocate-instance pcl::allocate-standard-instance))) + +#+nil +(declaim (optimize (speed 3) (safety 1) (space 0) + (compilation-speed 0))) + +(declaim (single-float *min-time*)) + +(defvar *min-time* (/ 10 (float internal-time-units-per-second)) + "At least 2 orders of magnitude larger than our time resolution.") + +#-cmu +(defmacro elapsed-time (form) + "Returns (1) the result of form and (2) the time (seconds) it takes to evaluate form." + ;; Note that this function is completely portable. + (let ((start-time (gensym)) (end-time (gensym))) + `(let ((,start-time (get-internal-run-time))) + (declare (type (unsigned-byte 31) ,start-time)) + (values ,form + (let ((,end-time (get-internal-run-time))) + (declare (type (unsigned-byte 31) ,end-time)) + (/ (abs (- ,end-time ,start-time)) + ,(float internal-time-units-per-second))))))) + +#+cmu +(defmacro elapsed-time (form) + "Returns (1) the result of form and (2) the time (seconds) it takes to evaluate form." + ;; Note that this function is completely portable. + (let ((start-time (gensym)) (end-time (gensym)) + (gc-start-time (gensym)) + (gc-end-time (gensym))) + `(let ((,start-time (get-internal-run-time)) + (,gc-start-time lisp::*gc-run-time*)) + (declare (type (unsigned-byte 31) ,start-time)) + (values ,form + (let ((,end-time (get-internal-run-time)) + (,gc-end-time lisp::*gc-run-time*)) + (declare (type (unsigned-byte 31) ,end-time)) + (/ (- (abs (- ,end-time ,start-time)) + (max 0 (- ,gc-end-time ,gc-start-time))) + ,(float internal-time-units-per-second))))))) + +(defmacro without-interruption (&body forms) + #+genera `(scl:without-interrupts ,@forms) + #+lucid `(lcl::with-scheduling-inhibited ,@forms) + #+allegro `(excl:without-interrupts ,@forms) + #+lispworks `(without-interrupts ,@forms) + #+(and (not genera) (not lucid) (not allegro)) `(progn ,@forms)) + +(defmacro median-time (form &optional (I 5)) + "Return the median time it takes to evaluate form." + ;; I: number of samples to take. + `(without-interruption + (let ((results nil)) + (dotimes (ignore ,I) + (declare (fixnum ignore)) + (multiple-value-bind (ignore time) (elapsed-time ,form) + (declare (ignore ignore) + (single-float time)) + (if (< time *min-time*) + (format t "~% Warning. Evaluating ~S took only ~S seconds.~ + ~% You should probably use more iterations." ',form time)) + (push time results))) + (nth ,(truncate I 2) (sort results #'<))))) + +#+debug +(defun test () (median-time (sleep 1.0))) + +;;;********************************************************************* + +;;;OPERATIONS-PER-SECOND actually does the work of computing a benchmark. The amount +;;; of time it takes to execute the form N times is recorded, minus the time it +;;; takes to execute the empty loop. OP/S = N/time. This quantity is recomputed +;;; five times and the median value is returned. Variance in the numbers increases +;;; when memory is being allocated (cons, make-instance, etc). + +(defmacro repeat (form N) + ;; Minimal loop + (let ((count (gensym)) (result (gensym))) + `(let ((,count ,N) ,result) + (declare (fixnum ,count)) + (loop + ;; If you don't use the setq, the compiler may decide that since the + ;; result is ignored, FORM can be "compiled out" of the loop. + (setq ,result ,form) + (if (zerop (decf ,count)) (return ,result)))))) + +(defun nempty (N) + (declare (fixnum N)) + "The empty loop." + (repeat nil N)) + +(defun empty-speed (N) (median-time (nempty N))) + +(defun compute-empty-iterations (&optional (default 10000000)) + (format t "~%Computing speed of empty loop...") + (let ((time 0.0)) + (declare (single-float time)) + (loop + (setq time (empty-speed default)) + (if (< time *min-time*) (setq default (* default 10)) (return))) + (format t "done.") + default)) + +(declaim (fixnum *empty-iterations*)) +(defvar *empty-iterations*) +(declaim (single-float *speed-of-empty-loop*)) +(defvar *speed-of-empty-loop*) + +(eval-when (:load-toplevel :execute) + (setq *empty-iterations* (compute-empty-iterations)) + (setq *speed-of-empty-loop* (/ (empty-speed *empty-iterations*) + (float *empty-iterations*)))) + +(defmacro operations-per-second (form N &optional (I 5)) + "Return the number of times FORM can evaluate in one second." + `(let ((time (progn (gc) (median-time (repeat ,form ,N) ,I)))) + (declare (single-float time) (fixnum ,N)) + (/ (float ,N) (- time (* *speed-of-empty-loop* ,N))))) + +(defmacro bench (pretty-name name N &optional (stream t)) + `(progn + (format ,stream "~&~A:~40T" ,pretty-name) + (force-output ,stream) + (format ,stream "~10,2,1E~%" (,name ,N)))) + +;;;**************************************************************************** +;;;BENCH-THIS-LISP + +(defun Nmult (N) + (let ((a 2.1)) + (operations-per-second (* a a) N))) + +(defun Nadd (N) + (let ((a 2.1)) + (operations-per-second (+ a a) N))) + +(defun square (x) (* x x)) + +(defun funcall-1 (N) + (let ((x 2.1)) + (operations-per-second (funcall #'(lambda (a) (* a a)) x) N))) + +(defun f1 (n) n) + +(defun funcall-2 (N) + (let ((f #'f1) + (x 2.1)) + (operations-per-second (funcall f x) N))) + +(defun funcall-3 (N) + (let ((x 2.1)) + (operations-per-second (f1 x) N))) + +(defun funcall-4 (N) + (let ((x 2.1)) + (operations-per-second (funcall #'square x) N))) + +(defun funcall-5 (N) + (let ((x 2.1) + (f #'square)) + (let ((g #'(lambda (x) + (operations-per-second (funcall f x) N)))) + (funcall g x)))) + +(defun Nsetf (N) + (let ((array (make-array 15))) + (operations-per-second (setf (aref array 5) t) N))) + +(defun Nsymeval (N) (operations-per-second (eval T) N)) + +(defun Repeatuations (N) (operations-per-second (eval '(* 2.1 2.1)) N)) + +(defun n-cons (N) (let ((a 1)) (operations-per-second (cons a a) N))) + +(defvar *object* t) +(Defun nspecial (N) (operations-per-second (null *object*) N)) + +(defun nlexical (N) + (let ((o t)) + (operations-per-second (null o) N))) + +(defun nfree (N) + (let ((o t)) + (let ((g #'(lambda () + #+genera (declare (sys:downward-function)) + (operations-per-second (null o) N)))) + (funcall g)))) + +(defun nfree2 (N) + (let ((o t)) + (let ((g #'(lambda () + (let ((f #'(lambda () + #+genera (declare (sys:downward-function)) + (operations-per-second (null o) N)))) + (funcall f))))) + (funcall g)))) + +(defun ncompilations (N) + (let ((lambda-expression + '(lambda (bar) (let ((baz t)) (if baz (cons bar nil)))))) + (operations-per-second (compile 'bob lambda-expression) N))) + +(defun bench-this-lisp () + (let ((N (/ *empty-iterations* 1))) + (bench "(* 2.1 2.1)" nmult N) + (bench "(+ 2.1 2.1)" nadd N) + (bench "funcall & (* 2.1 2.1)" funcall-3 N) + (bench "special reference" nspecial *empty-iterations*) + (bench "lexical reference" nlexical *empty-iterations*) + ;; (bench "ivar reference" n-ivar-ref N) + (bench "(setf (aref array 5) t)" nsetf N) + (bench "(funcall lexical-f x)" funcall-2 N) + (bench "(f x)" funcall-3 N) + ;; (Bench "(eval t)" nsymeval 10000) + ;; (bench "(eval '(* 2.1 2.1))" repeatuations 10000) + ;; (bench "(cons 1 2)" n-cons 100000) + ;; (bench "compile simple function" ncompilations 50) + )) + +;(bench-this-lisp) + +;;;************************************************************** +;;;BENCH-THIS-CLOS +;;; (evolved from Ken Anderson's tests of Symbolics CLOS) + +(defmethod strange ((x t)) t) ; default method +(defmethod area ((x number)) 'green) ; builtin class + +(defun strange-defun (x) (declare (ignore x)) t) + +(defclass point () + ((x :initform 0 :accessor x :initarg :x) + (y :initform 0 :accessor y :initarg :y))) + +(defclass large-class () + ((a0 :initform 0 :accessor a0 :initarg :a0) + (a1 :initform 0 :accessor a1 :initarg :a1) + (a2 :initform 0 :accessor a2 :initarg :a2) + (a3 :initform 0 :accessor a3 :initarg :a3) + (a4 :initform 0 :accessor a4 :initarg :a4) + (a5 :initform 0 :accessor a5 :initarg :a5) + (a6 :initform 0 :accessor a6 :initarg :a6) + (a7 :initform 0 :accessor a7 :initarg :a7) + (a8 :initform 0 :accessor a8 :initarg :a8) + (a9 :initform 0 :accessor a9 :initarg :a9))) + +#+gerds-pcl +(declaim (pcl:slots (inline inline-point inline-large-class))) + +(defclass inline-point () + ((x :initform 0 :accessor x :initarg :x) + (y :initform 0 :accessor y :initarg :y))) + +(defclass inline-large-class () + ((a0 :initform 0 :accessor a0 :initarg :a0) + (a1 :initform 0 :accessor a1 :initarg :a1) + (a2 :initform 0 :accessor a2 :initarg :a2) + (a3 :initform 0 :accessor a3 :initarg :a3) + (a4 :initform 0 :accessor a4 :initarg :a4) + (a5 :initform 0 :accessor a5 :initarg :a5) + (a6 :initform 0 :accessor a6 :initarg :a6) + (a7 :initform 0 :accessor a7 :initarg :a7) + (a8 :initform 0 :accessor a8 :initarg :a8) + (a9 :initform 0 :accessor a9 :initarg :a9))) + +(defstruct large-struct + (a0 0) + (a1 0) + (a2 0) + (a3 0) + (a4 0) + (a5 0) + (a6 0) + (a7 0) + (a8 0) + (a9 0)) + +(defmethod color ((thing point)) 'red) +(defmethod address ((thing point)) 'boston) +(defmethod area ((thing point)) 0) +(defmethod move-to ((p1 point) (p2 point)) 0) + +(defmethod large-class/with-slots ((thing large-class)) + (dotimes (i 1000) + (with-slots (a0 a1 a2 a3 a4 a5 a6 a7 a8 a9) thing + (+ a0 a1 a2 a3 a4 a5 a6 a7 a8 a9)))) + +(defmethod large-class/slot-value ((thing large-class)) + (dotimes (i 1000) + (+ (slot-value thing 'a0) + (slot-value thing 'a1) + (slot-value thing 'a2) + (slot-value thing 'a3) + (slot-value thing 'a4) + (slot-value thing 'a5) + (slot-value thing 'a6) + (slot-value thing 'a7) + (slot-value thing 'a8) + (slot-value thing 'a9)))) + +(defmethod x-offset ((thing point)) + (with-slots (x y) thing x)) + +(defmethod x-offset/slot-value ((thing point)) + (slot-value thing 'x)) + +(defmethod x-offset/reader ((thing point)) + (x thing)) + +(defmethod x-offset/reader/inline ((thing inline-point)) + #+gerds-pcl + (declare (pcl:slots (slot-boundp inline-point) + (inline inline-point))) + (x thing)) + +(defmethod set-x-offset ((thing point) new-x) + (with-slots (x y) thing (setq x new-x))) + +(defmethod set-x-offset/slot-value ((thing point) new-x) + (setf (slot-value thing 'x) new-x)) + +(defmethod set-x-offset/writer ((thing point) new-x) + (setf (x thing) new-x)) + +(defmethod set-x-offset/writer/inline ((thing inline-point) new-x) + #+gerds-pcl + (declare (pcl:slots (inline inline-point))) + (setf (x thing) new-x)) + +(defclass box (point) + ((width :initform 10 :accessor width :initarg :width) + (height :initform 10 :accessor height :initarg :height))) + +(defmethod area ((thing box)) 0) +(defmethod move-to ((box box) (point point)) 0) +(defmethod address :around ((thing box)) (call-next-method)) +(defmethod area2 ((x box) (y box)) 0) + +(defvar p (make-instance 'point)) +(defvar b (make-instance 'box)) + +(defvar inline-point (make-instance 'inline-point)) + +(defmethod x-offset-inline ((thing inline-point)) + #+gerds-pcl + (declare (pcl:slots (slot-boundp inline-point) + (inline inline-point))) + (with-slots (x y) thing x)) + +(defmethod large-class/with-slots/inline ((thing inline-large-class)) + #+gerds-pcl + (declare (pcl:slots (slot-boundp inline-large-class) + (inline inline-large-class))) + (dotimes (i 1000) + (with-slots (a0 a1 a2 a3 a4 a5 a6 a7 a8 a9) thing + (+ a0 a1 a2 a3 a4 a5 a6 a7 a8 a9)))) + +(defmethod large-class/with-slots/struct ((thing large-struct)) + (dotimes (i 1000) + (+ (large-struct-a0 thing) + (large-struct-a1 thing) + (large-struct-a2 thing) + (large-struct-a3 thing) + (large-struct-a4 thing) + (large-struct-a5 thing) + (large-struct-a6 thing) + (large-struct-a7 thing) + (large-struct-a8 thing) + (large-struct-a9 thing)))) + +(defmethod gf-call ((x box)) + (area x)) + +(defmethod gf-call-2 ((x box) (y box)) + (area2 x y)) + +(defun n-gf-call (n) + (let ((instance b)) + (operations-per-second (gf-call instance) n))) + +(defun n-gf-call-2 (n) + (let ((instance b)) + (operations-per-second (gf-call-2 instance instance) n))) + +(defun n-strange (N) (operations-per-second (strange 5) N)) +(defun n-strange-defun (N) (operations-per-second (strange-defun 5) N)) +(defun n-accesses (N) + (let ((instance p)) + (operations-per-second (x instance) N))) +(defun n-color (N) + (let ((instance p)) + (operations-per-second (color instance) n))) +(defun n-call-next-method (N) + (let ((instance b)) + (operations-per-second (address instance) n))) +(defun n-area-1 (N) + (let ((instance p)) + (operations-per-second (area instance) n))) +(defun n-area-2 (N) + (operations-per-second (area 5) n)) +(defun n-move-1 (N) + (let ((instance p)) + (operations-per-second (move-to instance instance) n))) +(defun n-move-2 (N) + (let ((x p) (y b)) + (operations-per-second (move-to x y) n))) +(defun n-off (N) + (let ((instance p)) + (operations-per-second (x-offset instance) n))) +(defun n-off-inline (N) + (let ((instance inline-point)) + (operations-per-second (x-offset-inline instance) n))) +(defun n-off/reader (N) + (let ((instance p)) + (operations-per-second (x-offset/reader instance) n))) +(defun n-off/reader/inline (N) + (let ((instance inline-point)) + (operations-per-second (x-offset/reader/inline instance) n))) +(defun n-off/slot-value (N) + (let ((instance p)) + (operations-per-second (x-offset/slot-value instance) n))) +(defun n-setoff (N) + (let ((instance p)) + (operations-per-second (set-x-offset instance 500) n))) + +(defun n-setoff/writer (N) + (let ((instance p)) + (operations-per-second (set-x-offset/writer instance 700) n))) + +(defun n-setoff/writer/inline (N) + (let ((instance inline-point)) + (operations-per-second (set-x-offset/writer/inline instance 700) n))) + +(defun n-setoff/slot-value (N) + (let ((instance p)) + (operations-per-second (set-x-offset/slot-value instance 700) n))) + +(defun n-large-class/with-slots (n) + (let ((instance (make-instance 'large-class))) + (operations-per-second (large-class/with-slots instance) n))) + +(defun n-large-class/with-slots/inline (n) + (let ((instance (make-instance 'inline-large-class))) + (operations-per-second (large-class/with-slots/inline instance) n))) + +(defun n-large-class/with-slots/struct (n) + (let ((instance (make-large-struct))) + (operations-per-second (large-class/with-slots/struct instance) n))) + +(defun n-large-class/slot-value (n) + (let ((instance (make-instance 'large-class))) + (operations-per-second (large-class/slot-value instance) n))) + +(defun n-slot-value (N) + (let ((instance p)) + (operations-per-second (slot-value instance 'x) n))) + +(defun n-slot-boundp (N) + (let ((instance p)) + (operations-per-second (slot-boundp instance 'x) n))) + +(defun n-class-of-1 (N) + (let ((instance p)) + (operations-per-second (class-of instance) n))) +(defun n-class-of-2 (N) + (operations-per-second (class-of 5) n)) + +(defun n-alloc (N) + (let ((c (#+pcl pcl:find-class + #+sbcl sb-pcl:find-class + #-pcl find-class 'point))) + (operations-per-second (allocate-instance c) n))) + +#+pcl +(defun n-alloc-standard (N) + (let* ((c (pcl:find-class 'point)) + (wrapper (pcl::class-wrapper c))) + (operations-per-second (allocate-standard-instance wrapper) + n))) + +#+pcl +(defun n-alloc-instance (n) + (operations-per-second (pcl::%%allocate-instance--class) n)) + +#+pcl +(defun n-%make-instance (n) + (operations-per-second (kernel::%make-instance 2) n)) + +(defun n-alloc-vector (n) + (operations-per-second (make-array 2) n)) + +(defun n-make (N) + (operations-per-second (make-instance 'point) n)) + +(defun n-make-non-constant (N) + (let ((class (find-class 'point))) + (operations-per-second (make-instance class) n))) + +(defun n-make-initargs (N) + (operations-per-second (make-instance 'point :x 0 :y 5) n)) + +(defun n-make-variable-initargs (N) + (let ((x 0) + (y 5)) + (operations-per-second (make-instance 'point :x x :y y) n))) + +(defmethod many-specializers ((p1 point) (p2 point) (b1 box) (b2 box) + (x integer) (y integer)) + p1) + +(defun n-many-specializers (n) + (let ((p (make-instance 'point)) + (b (make-instance 'box))) + (operations-per-second (many-specializers p p b b 1 2) n))) + +(defmethod two-specializers ((p1 point) (p2 point)) + t) + +(defun n-2-specializers (n) + (let ((instance p)) + (operations-per-second (two-specializers instance instance) n))) + +(defmethod three-specializers ((p1 point) (p2 point) (p3 point)) + t) + +(defun n-3-specializers (n) + (let ((instance p)) + (operations-per-second (three-specializers instance instance instance) n))) + +(defmethod four-specializers ((p1 point) (p2 point) (p3 point) (p4 point)) + t) + +(defun n-4-specializers (n) + (let ((instance p)) + (operations-per-second (four-specializers instance instance instance + instance) n))) + +(defmethod five-specializers ((p1 point) (p2 point) (p3 point) (p4 point) + (p5 point)) + t) + +(defun n-5-specializers (n) + (let ((instance p)) + (operations-per-second (five-specializers instance instance instance + instance + instance) n))) + +(defmethod 2/4-specializers ((p1 point) (p2 point) a b1 c d) + (declare (ignore a b1 c d)) + t) + +(defmethod 2/3-specializers ((p1 point) (p2 point) a b1 c) + (declare (ignore a b1 c)) + t) + +(defmethod 2/2-specializers ((p1 point) (p2 point) a b1) + (declare (ignore a b1)) + t) + +(defmethod 2/1-specializers ((p1 point) (p2 point) a) + (declare (ignore a)) + t) + +(defun n-2/1-specializers (n) + (let ((instance p)) + (operations-per-second (2/1-specializers instance instance t) + n))) + +(defun n-2/2-specializers (n) + (let ((instance p)) + (operations-per-second (2/2-specializers instance instance t t) + n))) + +(defun n-2/3-specializers (n) + (let ((instance p)) + (operations-per-second (2/3-specializers instance instance t t t) + n))) + +(defun n-2/4-specializers (n) + (let ((instance p)) + (operations-per-second (2/4-specializers instance instance t t t t) + n))) + +#+pcl +(pcl::precompile-random-code-segments) + +(defun bench-this-clos () + (bench-gf-call) + (bench-slot-accessors) + #+nil (bench-allocations) + (bench-make-instance) + (bench-dispatch)) + +(defun bench-dispatch (&optional n) + (when (null n) (setq n 10000000)) + (bench "1 default method" n-strange n) + (bench "equivalent defun" n-strange-defun n) + (bench "1 dispatch, 1 method" n-color n) + (bench "1 dispatch, :around + primary" n-call-next-method n) + (bench "1 dispatch, 3 methods, instance" n-area-1 n) + (bench "1 dispatch, 3 methods, noninstance" n-area-2 n) + (bench "2 dispatch, 2 methods" n-move-1 n) + (bench "2 specializers" n-2-specializers n) + (bench "2/1 specializers" n-2/2-specializers n) + (bench "2/2 specializers" n-2/2-specializers n) + (bench "2/3 specializers" n-2/3-specializers n) + (bench "2/4 specializers" n-2/4-specializers n) + (bench "3 specializers" n-3-specializers n) + (bench "4 specializers" n-4-specializers n) + (bench "5 specializers" n-5-specializers n) + (bench "6 specializers" n-many-specializers n)) + +(defun bench-make-instance (&optional n) + (when (null n) (setq n 5000000)) + #+cmu (gc :full t) + ;; The first test, whatever it is, gets a penalty from something I + ;; don't understand. + (bench "make-instance (2 slots)" n-make n) + (bench "make-instance (2 slots)" n-make n) + (bench "make-instance (2 slots, non-constant class)" n-make-non-constant n) + (bench "make-instance (2 constant initargs)" n-make-initargs n) + (bench "make-instance (2 variable initargs)" n-make-variable-initargs n)) + +(defun bench-allocations (&optional n) + (when (null n) (setq n 50000000)) + ;(bench "class-of instance" n-class-of-1 n) + ;(bench "class-of noninstance" n-class-of-2 n) + (bench "allocate-instance (2 slots)" n-alloc n) + (bench "allocate-standard-instance (2 slots)" n-alloc-standard n) + (bench "%%allocate-instance--class" n-alloc-instance n) + (bench "%make-instance" n-%make-instance n) + (bench "make-array" n-alloc-vector n)) + +;;; +;;; Note that this depends in some way on compile-time knowledge of +;;; class or what; I haven't investigated. Fact is that compiling +;;; this with known classes gives faster results. +;;; +(defun bench-slot-accessors (&optional n) + (when (null n) (setq n 100000000)) + (bench "slot reader method" n-accesses n) + (bench "naked slot-value" n-slot-value n) + (bench "naked slot-boundp" n-slot-boundp n) + (bench "large class with-slots" n-large-class/with-slots (/ n 1000)) + (bench "large class with-slots, inline" n-large-class/with-slots/inline + (/ n 100)) + (bench "large class with-slots, struct" n-large-class/with-slots/struct + (/ n 100)) + (bench "large class slot-value" n-large-class/slot-value (/ n 1000)) + (bench "with-slots, 1 read" n-off n) + (bench "same with slot-value" n-off/slot-value n) + (bench "same with reader method" n-off/reader n) + (bench "with-slots, 1 read, inline" n-off-inline n) + (bench "same with reader method, inline" n-off/reader/inline n) + (bench "with-slots, 1 modify" n-setoff n) + (bench "same with (setf slot-value)" n-setoff/slot-value n) + (bench "same with writer method" n-setoff/writer n) + (bench "same with writer method, inline" n-setoff/writer/inline n)) + +(defun bench-gf-call (&optional n) + (when (null n) (setq n 100000000)) + (bench "optimizable gf call (1)" n-gf-call n) + (bench "optimizable gf call (2)" n-gf-call-2 n)) + +#+pcl +(pcl::precompile-random-code-segments) + + + diff --git a/pcl/cmucl-documentation.lisp b/pcl/cmucl-documentation.lisp index 511081f16..45e2f404d 100644 --- a/pcl/cmucl-documentation.lisp +++ b/pcl/cmucl-documentation.lisp @@ -2,9 +2,9 @@ ;;; ********************************************************************** ;;; This code was written by Douglas T. Crosher and has been placed in ;;; the public domain, and is provided 'as is'. -;;; + (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/cmucl-documentation.lisp,v 1.10 2003/02/06 15:47:35 gerd Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/cmucl-documentation.lisp,v 1.11 2003/03/22 16:15:18 gerd Exp $") ;;; ;;; ********************************************************************** ;;; @@ -63,26 +63,26 @@ (setf (lisp::package-doc-string x) new-value)) ;;; Types, classes, and structure names. -(defmethod documentation ((x lisp:structure-class) (doc-type (eql 't))) - (values (ext:info type documentation (lisp:class-name x)))) +(defmethod documentation ((x kernel::structure-class) (doc-type (eql 't))) + (values (ext:info type documentation (kernel:%class-name x)))) (defmethod documentation ((x structure-class) (doc-type (eql 't))) (values (ext:info type documentation (class-name x)))) -(defmethod documentation ((x lisp:standard-class) (doc-type (eql 't))) - (or (values (ext:info type documentation (lisp:class-name x))) - (let ((pcl-class (kernel:class-pcl-class x))) +(defmethod documentation ((x kernel::standard-class) (doc-type (eql 't))) + (or (values (ext:info type documentation (kernel:%class-name x))) + (let ((pcl-class (kernel:%class-pcl-class x))) (and pcl-class (plist-value pcl-class 'documentation))))) -(defmethod documentation ((x lisp:structure-class) (doc-type (eql 'type))) - (values (ext:info type documentation (lisp:class-name x)))) +(defmethod documentation ((x kernel::structure-class) (doc-type (eql 'type))) + (values (ext:info type documentation (kernel:%class-name x)))) (defmethod documentation ((x structure-class) (doc-type (eql 'type))) (values (ext:info type documentation (class-name x)))) -(defmethod documentation ((x lisp:standard-class) (doc-type (eql 'type))) - (or (values (ext:info type documentation (lisp:class-name x))) - (let ((pcl-class (kernel:class-pcl-class x))) +(defmethod documentation ((x kernel::standard-class) (doc-type (eql 'type))) + (or (values (ext:info type documentation (kernel:%class-name x))) + (let ((pcl-class (kernel:%class-pcl-class x))) (and pcl-class (plist-value pcl-class 'documentation))))) (defmethod documentation ((x symbol) (doc-type (eql 'type))) @@ -95,20 +95,20 @@ (when (eq (ext:info type kind x) :instance) (values (ext:info type documentation x)))) -(defmethod (setf documentation) (new-value (x lisp:structure-class) (doc-type (eql 't))) - (setf (ext:info type documentation (lisp:class-name x)) new-value)) +(defmethod (setf documentation) (new-value (x kernel::structure-class) (doc-type (eql 't))) + (setf (ext:info type documentation (kernel:%class-name x)) new-value)) (defmethod (setf documentation) (new-value (x structure-class) (doc-type (eql 't))) (setf (ext:info type documentation (class-name x)) new-value)) -(defmethod (setf documentation) (new-value (x lisp:structure-class) (doc-type (eql 'type))) - (setf (ext:info type documentation (lisp:class-name x)) new-value)) +(defmethod (setf documentation) (new-value (x kernel::structure-class) (doc-type (eql 'type))) + (setf (ext:info type documentation (kernel:%class-name x)) new-value)) (defmethod (setf documentation) (new-value (x structure-class) (doc-type (eql 'type))) (setf (ext:info type documentation (class-name x)) new-value)) (defmethod (setf documentation) (new-value (x symbol) (doc-type (eql 'type))) - (if (structure-type-p x) ; Catch structures first. + (if (or (structure-type-p x) (condition-type-p x)) (setf (ext:info type documentation x) new-value) (let ((class (find-class x nil))) (if class @@ -117,7 +117,7 @@ (defmethod (setf documentation) (new-value (x symbol) (doc-type (eql 'structure))) (unless (eq (ext:info type kind x) :instance) - (error "~S is not the name of a structure type." x)) + (error "~@<~S is not the name of a structure type.~@:>" x)) (setf (ext:info type documentation x) new-value)) ;;; Variables. diff --git a/pcl/combin.lisp b/pcl/combin.lisp index 2c11eb50f..077432d4f 100644 --- a/pcl/combin.lisp +++ b/pcl/combin.lisp @@ -23,313 +23,66 @@ ;;; ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* -;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/combin.lisp,v 1.13 2003/01/03 18:50:23 pmai Exp $") -;;; - -(in-package :pcl) - -(defun get-method-function (method &optional method-alist wrappers) - (let ((fn (cadr (assoc method method-alist)))) - (if fn - (values fn nil nil nil) - (multiple-value-bind (mf fmf) - (if (listp method) - (early-method-function method) - (values nil (method-fast-function method))) - (let* ((pv-table (and fmf (method-function-pv-table fmf)))) - (if (and fmf (or (null pv-table) wrappers)) - (let* ((pv-wrappers (when pv-table - (pv-wrappers-from-all-wrappers - pv-table wrappers))) - (pv-cell (when (and pv-table pv-wrappers) - (pv-table-lookup pv-table pv-wrappers)))) - (values mf t fmf pv-cell)) - (values - (or mf (if (listp method) - (setf (cadr method) - (method-function-from-fast-function fmf)) - (method-function method))) - t nil nil))))))) - -(defun make-effective-method-function (generic-function form &optional - method-alist wrappers) - (funcall (make-effective-method-function1 generic-function form - (not (null method-alist)) - (not (null wrappers))) - method-alist wrappers)) - -(defun make-effective-method-function1 (generic-function form - method-alist-p wrappers-p) - (if (and (listp form) - (eq (car form) 'call-method)) - (make-effective-method-function-simple generic-function form) - ;; - ;; We have some sort of `real' effective method. Go off and get a - ;; compiled function for it. Most of the real hair here is done by - ;; the GET-FUNCTION mechanism. - ;; - (make-effective-method-function-internal generic-function form - method-alist-p wrappers-p))) - -(defun make-effective-method-function-type (generic-function form - method-alist-p wrappers-p) - (if (and (listp form) - (eq (car form) 'call-method)) - (let* ((cm-args (cdr form)) - (method (car cm-args))) - (when method - (if (if (listp method) - (eq (car method) :early-method) - (method-p method)) - (if method-alist-p - t - (multiple-value-bind (mf fmf) - (if (listp method) - (early-method-function method) - (values nil (method-fast-function method))) - (declare (ignore mf)) - (let* ((pv-table (and fmf (method-function-pv-table fmf)))) - (if (and fmf (or (null pv-table) wrappers-p)) - 'fast-method-call - 'method-call)))) - (if (and (consp method) (eq (car method) 'make-method)) - (make-effective-method-function-type - generic-function (cadr method) method-alist-p wrappers-p) - (type-of method))))) - 'fast-method-call)) - -(defun make-effective-method-function-simple (generic-function form - &optional no-fmf-p) - ;; - ;; The effective method is just a call to call-method. This opens up - ;; the possibility of just using the method function of the method as - ;; the effective method function. - ;; - ;; But we have to be careful. If that method function will ask for - ;; the next methods we have to provide them. We do not look to see - ;; if there are next methods, we look at whether the method function - ;; asks about them. If it does, we must tell it whether there are - ;; or aren't to prevent the leaky next methods bug. - ;; - (let* ((cm-args (cdr form)) - (fmf-p (and (null no-fmf-p) - (or (not (eq *boot-state* 'complete)) - (gf-fast-method-function-p generic-function)) - (null (cddr cm-args)))) - (method (car cm-args)) - (cm-args1 (cdr cm-args))) - (lambda (method-alist wrappers) - (make-effective-method-function-simple1 generic-function method cm-args1 fmf-p - method-alist wrappers)))) - -(defun make-emf-from-method (method cm-args &optional gf fmf-p method-alist wrappers) - (multiple-value-bind (mf real-mf-p fmf pv-cell) - (get-method-function method method-alist wrappers) - (if fmf - (let* ((next-methods (car cm-args)) - (next (make-effective-method-function-simple1 - gf (car next-methods) - (list* (cdr next-methods) (cdr cm-args)) - fmf-p method-alist wrappers)) - (arg-info (method-function-get fmf :arg-info))) - (make-fast-method-call :function fmf - :pv-cell pv-cell - :next-method-call next - :arg-info arg-info)) - (if real-mf-p - (make-method-call :function mf - :call-method-args cm-args) - mf)))) - -(defun make-effective-method-function-simple1 (gf method cm-args fmf-p - &optional method-alist wrappers) - (when method - (if (if (listp method) - (eq (car method) :early-method) - (method-p method)) - (make-emf-from-method method cm-args gf fmf-p method-alist wrappers) - (if (and (consp method) (eq (car method) 'make-method)) - (make-effective-method-function gf (cadr method) method-alist wrappers) - method)))) - -(defvar *global-effective-method-gensyms* ()) -(defvar *rebound-effective-method-gensyms*) - -(defun get-effective-method-gensym () - (or (pop *rebound-effective-method-gensyms*) - (let ((new (intern (format nil "EFFECTIVE-METHOD-GENSYM-~D" - (length *global-effective-method-gensyms*)) - "PCL"))) - (setq *global-effective-method-gensyms* - (append *global-effective-method-gensyms* (list new))) - new))) - -(let ((*rebound-effective-method-gensyms* ())) - (dotimes (i 10) (get-effective-method-gensym))) - -(defun expand-effective-method-function (gf effective-method &optional env) - (declare (ignore env)) - (multiple-value-bind (nreq applyp metatypes nkeys arg-info) - (get-generic-function-info gf) - (declare (ignore nreq nkeys arg-info)) - (let ((ll (make-fast-method-call-lambda-list metatypes applyp))) - (cond - ;; When there are no primary methods and a next-method call - ;; occurs effective-method is (%no-primary-method <gf>), - ;; which we define here to collect all gf arguments, to pass - ;; those together with the GF to no-primary-method: - ((eq (first effective-method) '%no-primary-method) - `(lambda (.pv-cell. .next-method-call. &rest .args.) - (declare (ignore .pv-cell. .next-method-call.)) - (flet ((%no-primary-method (gf) - (apply #'no-primary-method gf .args.))) - ,effective-method))) - ;; When the method combination uses the :arguments option - ((and (eq *boot-state* 'complete) - ;; Otherwise the METHOD-COMBINATION slot is not bound. - (let ((combin (generic-function-method-combination gf))) - (and (long-method-combination-p combin) - (long-method-combination-arguments-lambda-list combin)))) - (let* ((required (dfun-arg-symbol-list metatypes)) - (gf-args (if applyp - `(list* ,@required .dfun-rest-arg.) - `(list ,@required)))) - `(lambda ,ll - (declare (ignore .pv-cell. .next-method-call.)) - (let ((.gf-args. ,gf-args)) - (declare (ignorable .gf-args.)) - ,effective-method)))) - (t - `(lambda ,ll - (declare (ignore .pv-cell. .next-method-call.)) - ,effective-method)))))) - -(defun expand-emf-call-method (gf form metatypes applyp env) - (declare (ignore gf metatypes applyp env)) - `(call-method ,(cdr form))) + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/combin.lisp,v 1.14 2003/03/22 16:15:17 gerd Exp $") -(defmacro call-method (&rest args) - (declare (ignore args)) - `(error "~S outsize of a effective method form" 'call-method)) - -(defun memf-test-converter (form generic-function method-alist-p wrappers-p) - (cond ((and (consp form) (eq (car form) 'call-method)) - (case (make-effective-method-function-type - generic-function form method-alist-p wrappers-p) - (fast-method-call - '.fast-call-method.) - (t - '.call-method.))) - ((and (consp form) (eq (car form) 'call-method-list)) - (case (if (every (lambda (form) - (eq 'fast-method-call - (make-effective-method-function-type - generic-function form - method-alist-p wrappers-p))) - (cdr form)) - 'fast-method-call - t) - (fast-method-call - '.fast-call-method-list.) - (t - '.call-method-list.))) - (t - (default-test-converter form)))) - -(defun memf-code-converter (form generic-function - metatypes applyp method-alist-p wrappers-p) - (cond ((and (consp form) (eq (car form) 'call-method)) - (let ((gensym (get-effective-method-gensym))) - (values (make-emf-call metatypes applyp gensym - (make-effective-method-function-type - generic-function form method-alist-p wrappers-p)) - (list gensym)))) - ((and (consp form) (eq (car form) 'call-method-list)) - (let ((gensym (get-effective-method-gensym)) - (type (if (every (lambda (form) - (eq 'fast-method-call - (make-effective-method-function-type - generic-function form - method-alist-p wrappers-p))) - (cdr form)) - 'fast-method-call - t))) - (values `(dolist (emf ,gensym nil) - ,(make-emf-call metatypes applyp 'emf type)) - (list gensym)))) - (t - (default-code-converter form)))) - -(defun memf-constant-converter (form generic-function) - (cond ((and (consp form) (eq (car form) 'call-method)) - (list (cons '.meth. - (make-effective-method-function-simple - generic-function form)))) - ((and (consp form) (eq (car form) 'call-method-list)) - (list (cons '.meth-list. - (mapcar (lambda (form) - (make-effective-method-function-simple - generic-function form)) - (cdr form))))) - (t - (default-constant-converter form)))) +(in-package "PCL") -(defun make-effective-method-function-internal (generic-function effective-method - method-alist-p wrappers-p) - (multiple-value-bind (nreq applyp metatypes nkeys arg-info) - (get-generic-function-info generic-function) - (declare (ignore nkeys arg-info)) - (let* ((*rebound-effective-method-gensyms* *global-effective-method-gensyms*) - (name (if (early-gf-p generic-function) - (early-gf-name generic-function) - (generic-function-name generic-function))) - (arg-info (cons nreq applyp)) - (effective-method-lambda (expand-effective-method-function - generic-function effective-method))) - (multiple-value-bind (cfunction constants) - (get-function1 effective-method-lambda - (lambda (form) - (memf-test-converter form generic-function - method-alist-p wrappers-p)) - (lambda (form) - (memf-code-converter form generic-function - metatypes applyp - method-alist-p wrappers-p)) - (lambda (form) - (memf-constant-converter form generic-function))) - (lambda (method-alist wrappers) - (let* ((constants - (mapcar (lambda (constant) - (if (consp constant) - (case (car constant) - (.meth. - (funcall (cdr constant) - method-alist wrappers)) - (.meth-list. - (mapcar (lambda (fn) - (funcall fn method-alist wrappers)) - (cdr constant))) - (t constant)) - constant)) - constants)) - (function (set-function-name - (apply cfunction constants) - `(combined-method ,name)))) - (make-fast-method-call :function function - :arg-info arg-info))))))) +;;; +;;; In the following: +;;; +;;; Something "callable" is either a function, a FAST-METHOD-CALL or +;;; a METHOD-CALL instance, which can all be "invoked" by PCL. +;;; +;;; A generator for a "callable" is a function (closure) taking two +;;; arguments METHOD-ALIST and WRAPPERS and returning a callable. +;;; -(defmacro call-method-list (&rest calls) - `(progn ,@calls)) + +;;; ********************************************* +;;; The STANDARD method combination type ******* +;;; ********************************************* +;;; +;;; This is coded by hand (rather than with DEFINE-METHOD-COMBINATION) +;;; for bootstrapping and efficiency reasons. Note that the +;;; definition of the find-method-combination-method appears in the +;;; file defcombin.lisp, this is because EQL methods can't appear in +;;; the bootstrap. +;;; +;;; This code must conform to the code in the file defcombin, look +;;; there for more details. +;;; -(defun make-call-methods (methods) - `(call-method-list - ,@(mapcar (lambda (method) `(call-method ,method ())) methods))) +;;; +;;; When adding a method to COMPUTE-EFFECTIVE-METHOD for the standard +;;; method combination, COMPUTE-EFFECTIVE-METHOD is called for +;;; determining the effective method of COMPUTE-EFFECTIVE-METHOD. +;;; That's a chicken and egg problem. It's solved in dfun.lisp by +;;; always calling STANDARD-COMPUTE-EFFECTIVE-METHOD for the case of +;;; COMPUTE-EFFECTIVE-METHOD. +;;; +;;; A similar problem occurs with all generic functions used to compute +;;; an effective method. For example, if a method for METHOD-QUALIFIERS +;;; is performed, the generic function METHOD-QUALIFIERS will be called, +;;; and it's not ready for use. +;;; +;;; That's actually the well-known meta-circularity of PCL. +;;; +;;; Can we use an existing definition in the compiling PCL, if any, +;;; until the effective method is ready? +;;; +#+loadable-pcl +(defmethod compute-effective-method ((gf generic-function) + (combin standard-method-combination) + applicable-methods) + (standard-compute-effective-method gf combin applicable-methods)) + +#-loadable-pcl +(defun compute-effective-method (gf combin applicable-methods) + (standard-compute-effective-method gf combin applicable-methods)) -(defun standard-compute-effective-method - (generic-function combin applicable-methods) +(defun standard-compute-effective-method (gf combin applicable-methods) (declare (ignore combin)) (let ((before ()) (primary ()) @@ -338,45 +91,37 @@ (flet ((lose (method why) (invalid-method-error method - "The method ~S ~A.~%~ - Standard method combination requires all methods to have one~%~ - of the single qualifiers :AROUND, :BEFORE and :AFTER or to~%~ - have no qualifier at all." - method why))) + "~@<The method ~S ~A. ~ + Standard method combination requires all methods to have one ~ + of the single qualifiers ~s, ~s and ~s or to have no qualifier ~ + at all.~@:>" + method why :around :before :after))) (dolist (m applicable-methods) (let ((qualifiers (if (listp m) (early-method-qualifiers m) (method-qualifiers m)))) - (cond - ((null qualifiers) (push m primary)) - ((cdr qualifiers) - (lose m "has more than one qualifier")) - ((eq (car qualifiers) :around) - (push m around)) - ((eq (car qualifiers) :before) - (push m before)) - ((eq (car qualifiers) :after) - (push m after)) - (t - (lose m "has an illegal qualifier")))))) + (cond ((null qualifiers) + (push m primary)) + ((cdr qualifiers) + (lose m "has more than one qualifier")) + ((eq (car qualifiers) :around) + (push m around)) + ((eq (car qualifiers) :before) + (push m before)) + ((eq (car qualifiers) :after) + (push m after)) + (t + (lose m "has an illegal qualifier")))))) (setq before (reverse before) after (reverse after) primary (reverse primary) around (reverse around)) (cond ((null primary) - ;; - ;; This form is recognized by expand-effective-method-function, - ;; which provides a definition for %no-primary-method that - ;; collects all gf arguments, and passes them together with the - ;; generic function to no-primary-method for more informative - ;; error reporting. - ;; - `(%no-primary-method ',generic-function)) + `(%no-primary-method ',gf .args.)) ((and (null before) (null after) (null around)) ;; - ;; By returning a single call-method `form' here we enable an + ;; By returning a single CALL-METHOD form here, we enable an ;; important implementation-specific optimization. - ;; `(call-method ,(first primary) ,(rest primary))) (t (let ((main-effective-method @@ -390,73 +135,383 @@ (if around `(call-method ,(first around) (,@(rest around) - (make-method ,main-effective-method))) + (make-method ,main-effective-method))) main-effective-method)))))) -;;; -;;; The STANDARD method combination type. This is coded by hand (rather than -;;; with define-method-combination) for bootstrapping and efficiency reasons. -;;; Note that the definition of the find-method-combination-method appears in -;;; the file defcombin.lisp, this is because EQL methods can't appear in the -;;; bootstrap. -;;; -;;; The defclass for the METHOD-COMBINATION and STANDARD-METHOD-COMBINATION -;;; classes has to appear here for this reason. This code must conform to -;;; the code in the file defcombin, look there for more details. -;;; - -(defun compute-effective-method (generic-function combin applicable-methods) - (standard-compute-effective-method generic-function combin applicable-methods)) - (defvar *invalid-method-error* (lambda (&rest args) (declare (ignore args)) (error - "INVALID-METHOD-ERROR was called outside the dynamic scope~%~ - of a method combination function (inside the body of~%~ - DEFINE-METHOD-COMBINATION or a method on the generic~%~ - function COMPUTE-EFFECTIVE-METHOD)."))) + "~@<~s was called outside the dynamic scope ~ + of a method combination function (inside the body of ~ + ~s or a method on the generic function ~s).~@:>" + 'invalid-method-error 'define-method-combination + 'compute-effective-method))) (defvar *method-combination-error* (lambda (&rest args) (declare (ignore args)) (error - "METHOD-COMBINATION-ERROR was called outside the dynamic scope~%~ - of a method combination function (inside the body of~%~ - DEFINE-METHOD-COMBINATION or a method on the generic~%~ - function COMPUTE-EFFECTIVE-METHOD)."))) - -;This definition appears in defcombin.lisp. -; -;(defmethod compute-effective-method :around ;issue with magic -; ((generic-function generic-function) ;generic functions -; (method-combination method-combination) -; applicable-methods) -; (declare (ignore applicable-methods)) -; (flet ((real-invalid-method-error (method format-string &rest args) -; (declare (ignore method)) -; (apply #'error format-string args)) -; (real-method-combination-error (format-string &rest args) -; (apply #'error format-string args))) -; (let ((*invalid-method-error* #'real-invalid-method-error) -; (*method-combination-error* #'real-method-combination-error)) -; (call-next-method)))) + "~@<~s was called outside the dynamic scope ~ + of a method combination function (inside the body of ~ + ~s or a method on the generic function ~s).~@:>" + 'method-combination-error 'define-method-combination + 'compute-effective-method))) (defun invalid-method-error (&rest args) - (declare (arglist method format-string &rest format-arguments)) (apply *invalid-method-error* args)) (defun method-combination-error (&rest args) - (declare (arglist format-string &rest format-arguments)) (apply *method-combination-error* args)) -;This definition appears in defcombin.lisp. -; -;(defmethod find-method-combination ((generic-function generic-function) -; (type (eql 'standard)) -; options) -; (when options -; (method-combination-error -; "The method combination type STANDARD accepts no options.")) -; *standard-method-combination*) +(defmacro call-method (&rest args) + (declare (ignore args)) + `(error "~@<~S used outsize of a effective method form.~@:>" 'call-method)) + +(defmacro call-method-list (&rest calls) + `(progn ,@calls)) + +(defun make-call-methods (methods) + `(call-method-list + ,@(mapcar (lambda (method) `(call-method ,method ())) methods))) + + +;;; **************************************************** +;;; Translating effective method bodies to Code ******* +;;; **************************************************** + +(defun get-callable (gf form method-alist wrappers) + (funcall (callable-generator gf form method-alist wrappers) + method-alist wrappers)) + +(defun callable-generator (gf form method-alist-p wrappers-p) + (if (eq 'call-method (car-safe form)) + (callable-generator-for-call-method gf form) + (callable-generator-for-emf gf form method-alist-p wrappers-p))) + +;;; +;;; If the effective method is just a call to CALL-METHOD, this opens +;;; up the possibility of just using the method function of the method +;;; as the effective method function. +;;; +;;; But we have to be careful. If that method function will ask for +;;; the next methods we have to provide them. We do not look to see +;;; if there are next methods, we look at whether the method function +;;; asks about them. If it does, we must tell it whether there are +;;; or aren't to prevent the leaky next methods bug. +;;; +(defun callable-generator-for-call-method (gf form) + (let* ((cm-args (cdr form)) + (fmf-p (and (or (not (eq *boot-state* 'complete)) + (gf-fast-method-function-p gf)) + (null (cddr cm-args)))) + (method (car cm-args)) + (cm-args1 (cdr cm-args))) + (lambda (method-alist wrappers) + (callable-for-call-method gf method cm-args1 fmf-p method-alist + wrappers)))) + +(defun callable-for-call-method (gf method cm-args fmf-p method-alist wrappers) + (cond ((null method) + nil) + ((if (listp method) + (eq (car method) :early-method) + (method-p method)) + (get-method-callable method cm-args gf fmf-p method-alist wrappers)) + ((eq 'make-method (car-safe method)) + (get-callable gf (cadr method) method-alist wrappers)) + (t + method))) + +;;; +;;; Return a FAST-METHOD-CALL structure, a METHOD-CALL structure, or a +;;; method function for calling METHOD. +;;; +(defun get-method-callable (method cm-args gf fmf-p method-alist wrappers) + (multiple-value-bind (mf real-mf-p fmf pv-cell) + (get-method-function method method-alist wrappers) + (cond (fmf + (let* ((next-methods (car cm-args)) + (next (callable-for-call-method gf (car next-methods) + (list* (cdr next-methods) + (cdr cm-args)) + fmf-p method-alist wrappers)) + (arg-info (method-function-get fmf :arg-info))) + (make-fast-method-call :function fmf + :pv-cell pv-cell + :next-method-call next + :arg-info arg-info))) + (real-mf-p + (make-method-call :function mf :call-method-args cm-args)) + (t mf)))) + +(defun get-method-function (method method-alist wrappers) + (let ((fn (cadr (assoc method method-alist)))) + (if fn + (values fn nil nil nil) + (multiple-value-bind (mf fmf) + (if (listp method) + (early-method-function method) + (values nil (method-fast-function method))) + (let ((pv-table (and fmf (method-function-pv-table fmf)))) + (if (and fmf + (not (and pv-table (pv-table-computing-cache-p pv-table))) + (or (null pv-table) wrappers)) + (let* ((pv-wrappers (when pv-table + (pv-wrappers-from-all-wrappers + pv-table wrappers))) + (pv-cell (when (and pv-table pv-wrappers) + (pv-table-lookup pv-table pv-wrappers)))) + (values mf t fmf pv-cell)) + (values + (or mf (if (listp method) + (setf (cadr method) + (method-function-from-fast-function fmf)) + (method-function method))) + t nil nil))))))) + + +;;; +;;; Return a closure returning a FAST-METHOD-CALL instance for the +;;; call of the effective method of generic function GF with body +;;; BODY. +;;; +(defun callable-generator-for-emf (gf body method-alist-p wrappers-p) + (multiple-value-bind (nreq applyp metatypes nkeys arg-info) + (get-generic-function-info gf) + (declare (ignore nkeys arg-info)) + (let* ((name (if (early-gf-p gf) + (early-gf-name gf) + (generic-function-name gf))) + (arg-info (cons nreq applyp)) + (effective-method-lambda (make-effective-method-lambda gf body))) + (multiple-value-bind (cfunction constants) + (get-function1 effective-method-lambda + (lambda (form) + (memf-test-converter form gf method-alist-p + wrappers-p)) + (lambda (form) + (memf-code-converter form gf metatypes applyp + method-alist-p wrappers-p)) + (lambda (form) + (memf-constant-converter form gf))) + (lambda (method-alist wrappers) + (let* ((constants + (mapcar (lambda (constant) + (case (car-safe constant) + (.meth. + (funcall (cdr constant) method-alist wrappers)) + (.meth-list. + (mapcar (lambda (fn) + (funcall fn method-alist wrappers)) + (cdr constant))) + (t constant))) + constants)) + (function (set-function-name (apply cfunction constants) + `(effective-method ,name)))) + (make-fast-method-call :function function + :arg-info arg-info))))))) + +;;; +;;; Return a lambda-form for an effective method of generic function +;;; GF with body BODY. +;;; +(defun make-effective-method-lambda (gf body) + (multiple-value-bind (nreq applyp metatypes nkeys arg-info) + (get-generic-function-info gf) + (declare (ignore nreq nkeys arg-info)) + (let ((ll (make-fast-method-call-lambda-list metatypes applyp)) + (error-p (eq (first body) '%no-primary-method)) + (mc-args-p + (when (eq *boot-state* 'complete) + ;; Otherwise the METHOD-COMBINATION slot is not bound. + (let ((combin (generic-function-method-combination gf))) + (and (long-method-combination-p combin) + (long-method-combination-args-lambda-list combin)))))) + (cond (error-p + `(lambda (.pv-cell. .next-method-call. &rest .args.) + (declare (ignore .pv-cell. .next-method-call.)) + ,body)) + (mc-args-p + (let* ((required (dfun-arg-symbol-list metatypes)) + (gf-args (if applyp + `(list* ,@required .dfun-rest-arg.) + `(list ,@required)))) + `(lambda ,ll + (declare (ignore .pv-cell. .next-method-call.)) + (let ((.gf-args. ,gf-args)) + (declare (ignorable .gf-args.)) + ,body)))) + (t + `(lambda ,ll + (declare (ignore .pv-cell. .next-method-call.)) + ,body)))))) + +(defun memf-test-converter (form gf method-alist-p wrappers-p) + (case (car-safe form) + (call-method + (case (get-method-call-type gf form method-alist-p wrappers-p) + (fast-method-call '.fast-call-method.) + (t '.call-method.))) + (call-method-list + (case (get-method-list-call-type gf form method-alist-p wrappers-p) + (fast-method-call '.fast-call-method-list.) + (t '.call-method-list.))) + (t + (default-test-converter form)))) + +(defun memf-code-converter (form gf metatypes applyp method-alist-p + wrappers-p) + (case (car-safe form) + (call-method + (let ((gensym (gensym "MEMF"))) + (values (make-emf-call metatypes applyp gensym + (get-method-call-type gf form method-alist-p + wrappers-p)) + (list gensym)))) + (call-method-list + (let ((gensym (gensym "MEMF")) + (type (get-method-list-call-type gf form method-alist-p + wrappers-p))) + (values `(dolist (emf ,gensym nil) + ,(make-emf-call metatypes applyp 'emf type)) + (list gensym)))) + (t + (default-code-converter form)))) + +(defun memf-constant-converter (form gf) + (case (car-safe form) + (call-method + (list (cons '.meth. + (callable-generator-for-call-method gf form)))) + (call-method-list + (list (cons '.meth-list. + (mapcar (lambda (form) + (callable-generator-for-call-method gf form)) + (cdr form))))) + (t + (default-constant-converter form)))) + +(defun get-method-list-call-type (gf form method-alist-p wrappers-p) + (if (every (lambda (form) + (eq 'fast-method-call + (get-method-call-type gf form method-alist-p wrappers-p))) + (cdr form)) + 'fast-method-call + t)) + +(defun get-method-call-type (gf form method-alist-p wrappers-p) + (if (eq 'call-method (car-safe form)) + (destructuring-bind (method &rest cm-args) (cdr form) + (declare (ignore cm-args)) + (when method + (if (if (listp method) + (eq (car method) :early-method) + (method-p method)) + (if method-alist-p + t + (multiple-value-bind (mf fmf) + (if (listp method) + (early-method-function method) + (values nil (method-fast-function method))) + (declare (ignore mf)) + (let ((pv-table (and fmf (method-function-pv-table fmf)))) + (if (and fmf (or (null pv-table) wrappers-p)) + 'fast-method-call + 'method-call)))) + (if (eq 'make-method (car-safe method)) + (get-method-call-type gf (cadr method) method-alist-p + wrappers-p) + (type-of method))))) + 'fast-method-call)) + + +;;; ************************************** +;;; Generating Callables for EMFs ******* +;;; ************************************** + +;;; +;;; Turned off until problems with method tracing caused by it are +;;; solved (reason unknown). Will be needed once inlining of methods +;;; in effective methods and inlining of effective method in callers +;;; gets accute. +;;; +(defvar *named-emfs-p* nil) + +;;; +;;; Return a callable object for an emf of generic function GF, with +;;; applicable methods METHODS. GENERATOR is a function returned from +;;; CALLABLE-GENERATOR. Call it with two args METHOD-ALIST and +;;; WRAPPERS to obtain the actual callable. +;;; +(defun make-callable (gf methods generator method-alist wrappers) + (let ((callable (function-funcall generator method-alist wrappers))) + (set-emf-name gf methods callable))) + +;;; +;;; When *NAME-EMFS-P* is true, give the effective method represented +;;; by CALLABLE a suitable global name of the form (EFFECTIVE-METHOD +;;; ...). GF is the generic function the effective method is for, and +;;; METHODS is the list of applicable methods. +;;; +(defun set-emf-name (gf methods callable) + (when *named-emfs-p* + (let ((function (typecase callable + (fast-method-call (fast-method-call-function callable)) + (method-call (method-call-function callable)) + (t callable))) + (name (make-emf-name gf methods))) + (setf (fdefinition name) function) + (set-function-name function name))) + callable) + +;;; +;;; Return a name for an effective method of generic function GF, +;;; composed of applicable methods METHODS. +;;; +;;; In general, the name cannot be based on the methods alone, because +;;; that doesn't take method combination arguments into account. +;;; +;;; It is possible to do better for the standard method combination, +;;; though. The current name format is +;;; +;;; (EFFECTIVE-METHOD gf-name around-methods before-methods +;;; primary-method after-methods) +;;; +;;; where each method is a list (METHOD qualifiers specializers). +;;; +(defvar *emf-name-table* (make-hash-table :test 'equal)) + +(defun make-emf-name (gf methods) + (let* ((early-p (early-gf-p gf)) + (gf-name (if early-p + (early-gf-name gf) + (generic-function-name gf))) + (emf-name + (if (or early-p + (eq (generic-function-method-combination gf) + *standard-method-combination*)) + (let (primary around before after) + (dolist (m methods) + (let ((qual (if early-p + (early-method-qualifiers m) + (method-qualifiers m))) + (specl (if early-p + (early-method-specializers m) + (unparse-specializers + (method-specializers m))))) + (case (car-safe qual) + (:around (push `(method :around ,specl) around)) + (:before (push `(method :before ,specl) before)) + (:after (push `(method :after ,specl) after)) + (t (push `(method ,specl) primary))))) + `(effective-method ,gf-name + ,@(nreverse around) + ,@(nreverse before) + ,@(list (last primary)) + ,@after)) + `(effective-method ,gf-name ,(gensym))))) + (or (gethash emf-name *emf-name-table*) + (setf (gethash emf-name *emf-name-table*) emf-name)))) +;;; end of combin.lisp diff --git a/pcl/construct.lisp b/pcl/construct.lisp deleted file mode 100644 index b9d5e6bec..000000000 --- a/pcl/construct.lisp +++ /dev/null @@ -1,1064 +0,0 @@ -;;;-*-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. -;;; ************************************************************************* -;;; - -(ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/Attic/construct.lisp,v 1.14 2002/10/19 14:32:43 pmai Exp $") -;;; -;;; This file defines the defconstructor and other make-instance optimization -;;; mechanisms. -;;; - -(in-package :pcl) - -;;; -;;; defconstructor is used to define special purpose functions which just -;;; call make-instance with a symbol as the first argument. The semantics -;;; of defconstructor is that it is equivalent to defining a function which -;;; just calls make-instance. The purpose of defconstructor is to provide -;;; PCL with a way of noticing these calls to make-instance so that it can -;;; optimize them. Specific ports of PCL could just have their compiler -;;; spot these calls to make-instance and then call this code. Having the -;;; special defconstructor facility is the best we can do portably. -;;; -;;; -;;; A call to defconstructor like: -;;; -;;; (defconstructor make-foo foo (a b &rest r) a a :mumble b baz r) -;;; -;;; Is equivalent to a defun like: -;;; -;;; (defun make-foo (a b &rest r) -;;; (make-instance 'foo 'a a ':mumble b 'baz r)) -;;; -;;; Calls like the following are also legal: -;;; -;;; (defconstructor make-foo foo ()) -;;; (defconstructor make-bar bar () :x *x* :y *y*) -;;; (defconstructor make-baz baz (a b c) a-b (list a b) b-c (list b c)) -;;; -;;; -;;; The general idea of this implementation is that the expansion of the -;;; defconstructor form includes the creation of closure generators which -;;; can be called to create constructor code for the class. The ways that -;;; a constructor can be optimized depends not only on the defconstructor -;;; form, but also on the state of the class and the generic functions in -;;; the initialization protocol. Because of this, the determination of the -;;; form of constructor code to be used is a two part process. -;;; -;;; At compile time, make-constructor-code-generators looks at the actual -;;; defconstructor form and makes a list of appropriate constructor code -;;; generators. All that is really taken into account here is whether -;;; any initargs are supplied in the call to make-instance, and whether -;;; any of those are constant. -;;; -;;; At constructor code generation time (see note about lazy evaluation) -;;; compute-constructor-code calls each of the constructor code generators -;;; to try to get code for this constructor. Each generator looks at the -;;; state of the class and initialization protocol generic functions and -;;; decides whether its type of code is appropriate. This depends on things -;;; like whether there are any applicable methods on initialize-instance, -;;; whether class slots are affected by initialization etc. -;;; -;;; -;;; Constructor objects are funcallable instances, the protocol followed to -;;; to compute the constructor code for them is quite similar to the protocol -;;; followed to compute the discriminator code for a generic function. When -;;; the constructor is first loaded, we install as its code a function which -;;; will compute the actual constructor code the first time it is called. -;;; -;;; If there is an update to the class structure which might invalidate the -;;; optimized constructor, the special lazy constructor installer is put back -;;; so that it can compute the appropriate constructor when it is called. -;;; This is the same kind of lazy evaluation update strategy used elswhere -;;; in PCL. -;;; -;;; To allow for flexibility in the PCL implementation and to allow PCL users -;;; to specialize this constructor facility for their own metaclasses, there -;;; is an internal protocol followed by the code which loads and installs -;;; the constructors. This is documented in the comments in the code. -;;; -;;; This code is also designed so that one of its levels, can be used to -;;; implement optimization of calls to make-instance which can't go through -;;; the defconstructor facility. This has not been implemented yet, but the -;;; hooks are there. -;;; -;;; - -(defmacro defconstructor - (name class lambda-list &rest initialization-arguments) - (expand-defconstructor class - name - lambda-list - (copy-list initialization-arguments))) - -(defun expand-defconstructor (class-name name lambda-list supplied-initargs) - (let ((class (find-class class-name nil)) - (supplied-initarg-names (loop for name in supplied-initargs by #'cddr - collect name))) - (when (null class) - (error "defconstructor form being compiled (or evaluated) before~@ - class ~S is defined." - class-name)) - `(progn - ;; In order to avoid undefined function warnings, we want to - ;; tell the compile time environment that a function with this - ;; name and this argument list has been defined. The portable - ;; way to do this is with defun. - ;; But the derived result type for the above is wrong under CMUCL. - (proclaim '(ftype ,(ftype-declaration-from-lambda-list lambda-list name) - ,name)) - - ,(make-top-level-form `(defconstructor ,name) - '(load eval) - `(load-constructor - ',class-name - ',(class-name (class-of class)) - ',name - ',supplied-initarg-names - ;; make-constructor-code-generators is called to return a list - ;; of constructor code generators. The actual interpretation - ;; of this list is left to compute-constructor-code, but the - ;; general idea is that it should be an plist where the keys - ;; name a kind of constructor code and the values are generator - ;; functions which return the actual constructor code. The - ;; constructor code is usually a closures over the arguments - ;; to the generator. - ,(make-constructor-code-generators class - name - lambda-list - supplied-initarg-names - supplied-initargs)))))) - -(defun load-constructor (class-name metaclass-name constructor-name - supplied-initarg-names code-generators) - (let ((class (find-class class-name nil))) - (cond ((null class) - (error "defconstructor form being loaded (or evaluated) before~@ - class ~S is defined." - class-name)) - ((neq (class-name (class-of class)) metaclass-name) - (error "When defconstructor ~S was compiled, the metaclass of the~@ - class ~S was ~S. The metaclass is now ~S.~@ - The constructor must be recompiled." - constructor-name - class-name - metaclass-name - (class-name (class-of class)))) - (t - (load-constructor-internal class - constructor-name - supplied-initarg-names - code-generators) - constructor-name)))) - -;;; -;;; The actual constructor objects. -;;; -(defclass constructor (funcallable-standard-object) - ((class ;The class with which this - :initarg :class ;constructor is associated. - :reader constructor-class) ;The actual class object, - ;not the class name. - ; - (name ;The name of this constructor. - :initform nil ;This is the symbol in whose - :initarg :name ;function cell the constructor - :reader constructor-name) ;usually sits. Of course, this - ;is optional. defconstructor - ;makes named constructors, but - ;it is possible to manipulate - ;anonymous constructors also. - ; - (code-type ;The type of code currently in - :initform nil ;use by this constructor. This - :accessor constructor-code-type) ;is mostly for debugging and - ;analysis purposes. - ;The lazy installer sets this - ;to LAZY. The most basic and - ;least optimized type of code - ;is called FALLBACK. - ; - (supplied-initarg-names ;The names of the initargs this - :initarg :supplied-initarg-names ;constructor supplies when it - :reader ;"calls" make-instance. - constructor-supplied-initarg-names) ; - ; - (code-generators ;Generators for the different - :initarg :code-generators ;types of code this constructor - :reader constructor-code-generators)) ;could use. - (:metaclass funcallable-standard-class)) - - -;;; -;;; Because the value in the code-type slot should always correspond to the -;;; funcallable-instance-function of the constructor, this function should -;;; always be used to set the both at the same time. -;;; -(defun set-constructor-code (constructor code type) - (set-funcallable-instance-function constructor code) - (set-function-name constructor (constructor-name constructor)) - (setf (constructor-code-type constructor) type)) - - -(defmethod print-object ((constructor constructor) stream) - (printing-random-thing (constructor stream) - (format stream - "~S ~S (~S)" - (or (class-name (class-of constructor)) "Constructor") - (or (slot-value-or-default constructor 'name) "Anonymous") - (slot-value-or-default constructor 'code-type)))) - -(defmethod describe-object ((constructor constructor) stream) - (format stream - "~S is a constructor for the class ~S.~%~ - The current code type is ~S.~%~ - Other possible code types are ~S." - constructor (constructor-class constructor) - (constructor-code-type constructor) - (let ((collected ())) - (doplist (key val) (constructor-code-generators constructor) - (push key collected)) - (nreverse collected)))) - -;;; -;;; I am not in a hairy enough mood to make this implementation be metacircular -;;; enough that it can support a defconstructor for constructor objects. -;;; -(defun make-constructor (class name supplied-initarg-names code-generators) - (make-instance 'constructor - :class class - :name name - :supplied-initarg-names supplied-initarg-names - :code-generators code-generators)) - -; This definition actually appears in std-class.lisp. -;(defmethod class-constructors ((class std-class)) -; (with-slots (plist) class (getf plist 'constructors))) - -(defmethod add-constructor ((class slot-class) - (constructor constructor)) - (with-slots (plist) class - (pushnew constructor (getf plist 'constructors)))) - -(defmethod remove-constructor ((class slot-class) - (constructor constructor)) - (with-slots (plist) class - (setf (getf plist 'constructors) - (delete constructor (getf plist 'constructors))))) - -(defmethod get-constructor ((class slot-class) name &optional (error-p t)) - (or (dolist (c (class-constructors class)) - (when (eq (constructor-name c) name) (return c))) - (if error-p - (error "Couldn't find a constructor with name ~S for class ~S." - name class) - ()))) - -;;; -;;; This is called to actually load a defconstructor constructor. It must -;;; install the lazy installer in the function cell of the constructor name, -;;; and also add this constructor to the list of constructors the class has. -;;; -(defmethod load-constructor-internal - ((class slot-class) name initargs generators) - (let ((constructor (make-constructor class name initargs generators)) - (old (get-constructor class name nil))) - (when old (remove-constructor class old)) - (install-lazy-constructor-installer constructor) - (add-constructor class constructor) - (setf (gdefinition name) constructor))) - -(defmethod install-lazy-constructor-installer ((constructor constructor)) - (let ((class (constructor-class constructor))) - (set-constructor-code constructor - #'(kernel:instance-lambda (&rest args) - (multiple-value-bind (code type) - (compute-constructor-code class constructor) - (set-constructor-code constructor code type) - (apply constructor args))) - 'lazy))) - -;;; -;;; The interface to keeping the constructors updated. -;;; -;;; add-method and remove-method (for standard-generic-function and -method), -;;; promise to call maybe-update-constructors on the generic function and -;;; the method. -;;; -;;; The class update code promises to call update-constructors whenever the -;;; class is changed. That is, whenever the supers, slots or options change. -;;; If user defined classes of constructor needs to be updated in more than -;;; these circumstances, they should use the dependent updating mechanism to -;;; make sure update-constructors is called. -;;; -;;; Bootstrapping concerns force the definitions of maybe-update-constructors -;;; and update-constructors to be in the file std-class. For clarity, they -;;; also appear below. Be sure to keep the definition here and there in sync. -;;; -;(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)) -; ()) - - - -;;; -;;; Here is the actual smarts for making the code generators and then trying -;;; each generator to get constructor code. This extensible mechanism allows -;;; new kinds of constructor code types to be added. A programmer defining a -;;; specialization of the constructor class can either use this mechanism to -;;; define new code types, or can override this mechanism by overriding the -;;; methods on make-constructor-code-generators and compute-constructor-code. -;;; -;;; The function defined by define-constructor-code-type will receive the -;;; class object, and the 4 original arguments to defconstructor. It can -;;; return a constructor code generator, or return nil if this type of code -;;; is determined to not be appropriate after looking at the defconstructor -;;; arguments. -;;; -;;; When compute-constructor-code is called, it first performs basic checks -;;; to make sure that the basic assumptions common to all the code types are -;;; valid. (For details see method definition). If any of the tests fail, -;;; the fallback constructor code type is used. If none of the tests fail, -;;; the constructor code generators are called in order. They receive 5 -;;; arguments: -;;; -;;; CLASS the class the constructor is making instances of -;;; WRAPPER that class's wrapper -;;; DEFAULTS the result of calling class-default-initargs on class -;;; INITIALIZE the applicable methods on initialize-instance -;;; SHARED the applicable methosd on shared-initialize -;;; -;;; The first code generator to return code is used. The code generators are -;;; called in reverse order of definition, so define-constructor-code-type -;;; forms which define better code should appear after ones that define less -;;; good code. The fallback code type appears first. Note that redefining a -;;; code type does not change its position in the list. To do that, define -;;; a new type at the end with the behavior. -;;; - -(defvar *constructor-code-types* ()) - -(defmacro define-constructor-code-type (type arglist &body body) - (let ((fn-name (intern (format nil - "CONSTRUCTOR-CODE-GENERATOR ~A ~A" - (package-name (symbol-package type)) - (symbol-name type)) - *the-pcl-package*))) - `(progn - (defun ,fn-name ,arglist .,body) - (load-define-constructor-code-type ',type ',fn-name)))) - -(defun load-define-constructor-code-type (type generator) - (let ((old-entry (assq type *constructor-code-types*))) - (if old-entry - (setf (cadr old-entry) generator) - (push (list type generator) *constructor-code-types*)) - type)) - -(defmethod make-constructor-code-generators - ((class slot-class) - name lambda-list supplied-initarg-names supplied-initargs) - (cons 'list - (loop for (type generator-generator) in *constructor-code-types* - for generator = (funcall generator-generator - class name lambda-list - supplied-initarg-names - supplied-initargs) - when generator - collect `',type - and collect generator))) - -(defmethod compute-constructor-code ((class slot-class) - (constructor constructor)) - (let* ((proto (class-prototype class)) - (wrapper (class-wrapper class)) - (defaults (class-default-initargs class)) - (make - (compute-applicable-methods (gdefinition 'make-instance) (list class))) - (supplied-initarg-names - (constructor-supplied-initarg-names constructor)) - (default - (compute-applicable-methods (gdefinition 'default-initargs) - (list class supplied-initarg-names))) ;? - (allocate - (compute-applicable-methods (gdefinition 'allocate-instance) - (list class))) - (initialize - (compute-applicable-methods (gdefinition 'initialize-instance) - (list proto))) - (shared - (compute-applicable-methods (gdefinition 'shared-initialize) - (list proto t))) - (code-generators - (constructor-code-generators constructor))) - (flet ((call-code-generator (generator) - (when (null generator) - (unless (setq generator (getf code-generators 'fallback)) - (error "No FALLBACK generator?"))) - (funcall generator class wrapper defaults initialize shared))) - (if (or (cdr make) - (cdr default) - (cdr allocate) - (not (check-initargs-1 class - supplied-initarg-names - (append initialize shared) - nil nil))) - ;; These are basic shared assumptions, if one of the - ;; has been violated, we have to resort to the fallback - ;; case. Any of these assumptions could be moved out - ;; of here and into the individual code types if there - ;; was a need to do so. - (values (call-code-generator nil) 'fallback) - ;; Otherwise try all the generators until one produces - ;; code for us. - (doplist (type generator) code-generators - (let ((code (call-code-generator generator))) - (when code (return (values code type))))))))) - -;;; -;;; The facilities are useful for debugging, and to measure the performance -;;; boost from constructors. -;;; - -(defun map-constructors (fn) - (let ((nclasses 0) - (nconstructors 0)) - (labels ((recurse (class) - (incf nclasses) - (dolist (constructor (class-constructors class)) - (incf nconstructors) - (funcall fn constructor)) - (dolist (subclass (class-direct-subclasses class)) - (recurse subclass)))) - (recurse (find-class t)) - (values nclasses nconstructors)))) - -(defun reset-constructors () - (multiple-value-bind (nclass ncons) - (map-constructors #'install-lazy-constructor-installer ) - (format t "~&~D classes, ~D constructors." nclass ncons))) - -(defun disable-constructors () - (multiple-value-bind (nclass ncons) - (map-constructors - (lambda (c) - (let ((gen (getf (constructor-code-generators c) 'fallback))) - (if (null gen) - (error "No fallback constructor for ~S." c) - (set-constructor-code c - (funcall gen - (constructor-class c) - () () () ()) - 'fallback))))) - (format t "~&~D classes, ~D constructors." nclass ncons))) - -(defun enable-constructors () - (reset-constructors)) - - -;;; -;;; Helper functions and utilities that are shared by all of the code types -;;; and by the main compute-constructor-code method as well. -;;; - -(defvar *standard-initialize-instance-method* - (get-method #'initialize-instance - () - (list *the-class-slot-object*))) - -(defvar *standard-shared-initialize-method* - (get-method #'shared-initialize - () - (list *the-class-slot-object* *the-class-t*))) - -(defun non-pcl-initialize-instance-methods-p (methods) - (notevery (lambda (m) (eq m *standard-initialize-instance-method*)) - methods)) - -(defun non-pcl-shared-initialize-methods-p (methods) - (notevery (lambda (m) (eq m *standard-shared-initialize-method*)) - methods)) - -(defun non-pcl-or-after-initialize-instance-methods-p (methods) - (notevery (lambda (m) (or (eq m *standard-initialize-instance-method*) - (equal '(:after) (method-qualifiers m)))) - methods)) - -(defun non-pcl-or-after-shared-initialize-methods-p (methods) - (notevery (lambda (m) (or (eq m *standard-shared-initialize-method*) - (equal '(:after) (method-qualifiers m)))) - methods)) - -;;; -;;; This returns two values. The first is a vector which can be used as the -;;; initial value of the slots vector for the instance. The second is a symbol -;;; describing the initforms this class has. -;;; -;;; If the first value is: -;;; -;;; :unsupplied no slot has an initform -;;; :constants all slots have either a constant initform -;;; or no initform at all -;;; t there is at least one non-constant initform -;;; -(defun compute-constant-vector (class) - ;;(declare (values constants flag)) - (let* ((wrapper (class-wrapper class)) - (layout (wrapper-instance-slots-layout wrapper)) - (flag :unsupplied) - (constants ())) - (dolist (slotd (class-slots class)) - (let ((name (slot-definition-name slotd)) - (initform (slot-definition-initform slotd)) - (initfn (slot-definition-initfunction slotd))) - (cond ((null (memq name layout))) - ((null initfn) - (push (cons name +slot-unbound+) constants)) - ((constantp initform) - (push (cons name (eval initform)) constants) - (when (eq flag :unsupplied) (setq flag :constants))) - (t - (push (cons name +slot-unbound+) constants) - (setq flag t))))) - (let* ((constants-alist (sort constants (lambda (x y) - (memq (car y) - (memq (car x) layout))))) - (constants-list (mapcar #'cdr constants-alist))) - (values constants-list flag)))) - - -;;; -;;; This takes a class and a list of initarg-names, and returns an alist -;;; indicating the positions of the slots those initargs may fill. The -;;; order of the initarg-names argument is important of course, since we -;;; have to respect the rules about the leftmost initarg that fills a slot -;;; having precedence. This function allows initarg names to appear twice -;;; in the list, it only considers the first appearance. -;;; -(defun compute-initarg-positions (class initarg-names) - (let* ((layout (wrapper-instance-slots-layout (class-wrapper class))) - (positions (loop for position from 0 and slot-name in layout - collect (cons slot-name position))) - (slot-initargs-positions - (loop for slotd in (class-slots class) - collect - (list (slot-definition-initargs slotd) - (or (cdr (assq (slot-definition-name slotd) positions)) - :class))))) - ;; Go through each of the initargs, and figure out what position it - ;; fills by replacing the entries in slot-initargs-positions it fills. - (dolist (initarg initarg-names) - (dolist (slot-entry slot-initargs-positions) - (let ((slot-initargs (car slot-entry))) - (when (and (listp slot-initargs) - (not (null slot-initargs)) - (memq initarg slot-initargs)) - (setf (car slot-entry) initarg))))) - ;; Now collect all possible positions for each initarg - (loop for initarg in initarg-names - for positions = (loop for (arg position) in slot-initargs-positions - when (eq arg initarg) - collect position) - when positions - collect (cons initarg positions)))) - - -;;; -;;; The FALLBACK case allows anything. This always works, and always appears -;;; as the last of the generators for a constructor. It does a full call to -;;; make-instance. -;;; - -(define-constructor-code-type fallback - (class name arglist supplied-initarg-names supplied-initargs) - (declare (ignore name supplied-initarg-names)) - `(function - (lambda (&rest ignore) - (declare (ignore ignore)) - (function - (kernel:instance-lambda ,arglist - (make-instance - ',(class-name class) - ,@(loop for (name value) on supplied-initargs by #'cddr - collect `',name - collect value))))))) - - -;;; -;;; The GENERAL case allows: -;;; constant, unsupplied or non-constant initforms -;;; constant or non-constant default initargs -;;; supplied initargs -;;; slot-filling initargs -;;; :after methods on shared-initialize and initialize-instance -;;; -(define-constructor-code-type general - (class name arglist supplied-initarg-names supplied-initargs) - (declare (ignore name)) - (let ((raw-allocator (raw-instance-allocator class)) - (slots-fetcher (slots-fetcher class))) - `(function - (lambda (class .wrapper. defaults init shared) - (multiple-value-bind (.constants. - .constant-initargs. - .initfns-initargs-and-positions. - .supplied-initarg-positions. - .shared-initfns. - .initfns.) - (general-generator-internal class - defaults - init - shared - ',supplied-initarg-names - ',supplied-initargs) - .supplied-initarg-positions. - (when (and .constants. - (null (non-pcl-or-after-initialize-instance-methods-p - init)) - (null (non-pcl-or-after-shared-initialize-methods-p - shared))) - (function - (kernel:instance-lambda ,arglist - (declare #.*optimize-speed*) - (let* ((.instance. (,raw-allocator .wrapper. .constants.)) - (.slots. (,slots-fetcher .instance.)) - (.positions. .supplied-initarg-positions.) - (.initargs. .constant-initargs.)) - .positions. - - (dolist (entry .initfns-initargs-and-positions.) - (let ((val (funcall (car entry))) - (initarg (cadr entry))) - (when initarg - (push val .initargs.) - (push initarg .initargs.)) - (dolist (pos (cddr entry)) - (setf (%instance-ref .slots. pos) val)))) - - ,@(let ((collected ())) - (doplist (initarg value) supplied-initargs - (unless (constantp value) - (push `(let ((.value. ,value)) - (push .value. .initargs.) - (push ',initarg .initargs.) - (dolist (.p. (pop .positions.)) - (setf (%instance-ref .slots. .p.) - .value.))) - collected))) - (nreverse collected)) - - (dolist (fn .shared-initfns.) - (apply fn .instance. t .initargs.)) - (dolist (fn .initfns.) - (apply fn .instance. .initargs.)) - - .instance.))))))))) - -(defun general-generator-internal - (class defaults init shared supplied-initarg-names supplied-initargs) - (flet ((bail-out () (return-from general-generator-internal nil))) - (let* ((constants (compute-constant-vector class)) - (layout (wrapper-instance-slots-layout (class-wrapper class))) - (initarg-positions - (compute-initarg-positions class - (append supplied-initarg-names - (mapcar #'car defaults)))) - (initfns-initargs-and-positions ()) - (supplied-initarg-positions ()) - (constant-initargs ()) - (used-positions ())) - - ;; - ;; Go through each of the supplied initargs for three reasons. - ;; - ;; - If it fills a class slot, bail out. - ;; - If its a constant form, fill the constant vector. - ;; - Otherwise remember the positions no two initargs - ;; will try to fill the same position, since compute - ;; initarg positions already took care of that, but - ;; we do need to know what initforms will and won't - ;; be needed. - ;; - (doplist (initarg val) supplied-initargs - (let ((positions (cdr (assq initarg initarg-positions)))) - (cond ((memq :class positions) (bail-out)) - ((constantp val) - (setq val (eval val)) - (push val constant-initargs) - (push initarg constant-initargs) - (dolist (pos positions) (setf (svref constants pos) val))) - (t - (push positions supplied-initarg-positions))) - (setq used-positions (append positions used-positions)))) - ;; - ;; Go through each of the default initargs, for three reasons. - ;; - ;; - If it fills a class slot, bail out. - ;; - If it is a constant, and it does fill a slot, put that - ;; into the constant vector. - ;; - If it isn't a constant, record its initfn and position. - ;; - (dolist (default defaults) - (let* ((name (car default)) - (initfn (cadr default)) - (form (caddr default)) - (value ()) - (positions (cdr (assq name initarg-positions)))) - (unless (memq name supplied-initarg-names) - (cond ((memq :class positions) (bail-out)) - ((constantp form) - (setq value (eval form)) - (push value constant-initargs) - (push name constant-initargs) - (dolist (pos positions) - (setf (svref constants pos) value))) - (t - (push (list* initfn name positions) - initfns-initargs-and-positions))) - (setq used-positions (append positions used-positions))))) - ;; - ;; Go through each of the slot initforms: - ;; - ;; - If its position has already been filled, do nothing. - ;; The initfn won't need to be called, and the slot won't - ;; need to be touched. - ;; - If it is a class slot, and has an initform, bail out. - ;; - If its a constant or unsupplied, ignore it, it is - ;; already in the constant vector. - ;; - Otherwise, record its initfn and position - ;; - (dolist (slotd (class-slots class)) - (let* ((alloc (slot-definition-allocation slotd)) - (name (slot-definition-name slotd)) - (form (slot-definition-initform slotd)) - (initfn (slot-definition-initfunction slotd)) - (position (position name layout))) - (cond ((neq alloc :instance) - (unless (null initfn) - (bail-out))) - ((member position used-positions)) - ((or (constantp form) - (null initfn))) - (t - (push (list initfn nil position) - initfns-initargs-and-positions))))) - - (values constants - constant-initargs - (nreverse initfns-initargs-and-positions) - (nreverse supplied-initarg-positions) - (mapcar #'method-function - (remove *standard-shared-initialize-method* shared)) - (mapcar #'method-function - (remove *standard-initialize-instance-method* init)))))) - - -;;; -;;; The NO-METHODS case allows: -;;; constant, unsupplied or non-constant initforms -;;; constant or non-constant default initargs -;;; supplied initargs that are arguments to constructor, or constants -;;; slot-filling initargs -;;; - -(define-constructor-code-type no-methods - (class name arglist supplied-initarg-names supplied-initargs) - (declare (ignore name)) - (let ((raw-allocator (raw-instance-allocator class)) - (slots-fetcher (slots-fetcher class))) - `(function - (lambda (class .wrapper. defaults init shared) - (multiple-value-bind (.constants. - .initfns-and-positions. - .supplied-initarg-positions.) - (no-methods-generator-internal class - defaults - ',supplied-initarg-names - ',supplied-initargs) - .initfns-and-positions. - .supplied-initarg-positions. - (when (and .constants. - (null (non-pcl-initialize-instance-methods-p init)) - (null (non-pcl-shared-initialize-methods-p shared))) - #'(kernel:instance-lambda ,arglist - (declare #.*optimize-speed*) - (let* ((.instance. (,raw-allocator .wrapper. .constants.)) - (.slots. (,slots-fetcher .instance.)) - (.positions. .supplied-initarg-positions.)) - .positions. - - (dolist (entry .initfns-and-positions.) - (let ((val (funcall (car entry)))) - (dolist (pos (cdr entry)) - (setf (%instance-ref .slots. pos) val)))) - - ,@(let ((collected ())) - (doplist (initarg value) supplied-initargs - (unless (constantp value) - (push `(let ((.value. ,value)) - (dolist (.p. (pop .positions.)) - (setf (%instance-ref .slots. .p.) - .value.))) - collected))) - (nreverse collected)) - - .instance.)))))))) - -(defun no-methods-generator-internal - (class defaults supplied-initarg-names supplied-initargs) - (flet ((bail-out () (return-from no-methods-generator-internal nil))) - (let* ((constants (compute-constant-vector class)) - (layout (wrapper-instance-slots-layout (class-wrapper class))) - (initarg-positions - (compute-initarg-positions class - (append supplied-initarg-names - (mapcar #'car defaults)))) - (initfns-and-positions ()) - (supplied-initarg-positions ()) - (used-positions ())) - ;; - ;; Go through each of the supplied initargs for three reasons. - ;; - ;; - If it fills a class slot, bail out. - ;; - If its a constant form, fill the constant vector. - ;; - Otherwise remember the positions, no two initargs - ;; will try to fill the same position, since compute - ;; initarg positions already took care of that, but - ;; we do need to know what initforms will and won't - ;; be needed. - ;; - (doplist (initarg val) supplied-initargs - (let ((positions (cdr (assq initarg initarg-positions)))) - (cond ((memq :class positions) (bail-out)) - ((constantp val) - (setq val (eval val)) - (dolist (pos positions) - (setf (svref constants pos) val))) - (t - (push positions supplied-initarg-positions))) - (setq used-positions (append positions used-positions)))) - ;; - ;; Go through each of the default initargs, for three reasons. - ;; - ;; - If it fills a class slot, bail out. - ;; - If it is a constant, and it does fill a slot, put that - ;; into the constant vector. - ;; - If it isn't a constant, record its initfn and position. - ;; - (dolist (default defaults) - (let* ((name (car default)) - (initfn (cadr default)) - (form (caddr default)) - (value ()) - (positions (cdr (assq name initarg-positions)))) - (unless (memq name supplied-initarg-names) - (cond ((memq :class positions) (bail-out)) - ((constantp form) - (setq value (eval form)) - (dolist (pos positions) - (setf (svref constants pos) value))) - (t - (push (cons initfn positions) - initfns-and-positions))) - (setq used-positions (append positions used-positions))))) - ;; - ;; Go through each of the slot initforms: - ;; - ;; - If its position has already been filled, do nothing. - ;; The initfn won't need to be called, and the slot won't - ;; need to be touched. - ;; - If it is a class slot, and has an initform, bail out. - ;; - If its a constant or unsupplied, do nothing, we know - ;; that it is already in the constant vector. - ;; - Otherwise, record its initfn and position - ;; - (dolist (slotd (class-slots class)) - (let* ((alloc (slot-definition-allocation slotd)) - (name (slot-definition-name slotd)) - (form (slot-definition-initform slotd)) - (initfn (slot-definition-initfunction slotd)) - (position (position name layout))) - (cond ((neq alloc :instance) - (unless (null initfn) - (bail-out))) - ((member position used-positions)) - ((or (constantp form) - (null initfn))) - (t - (push (list initfn position) initfns-and-positions))))) - - (values constants - (nreverse initfns-and-positions) - (nreverse supplied-initarg-positions))))) - - -;;; -;;; The SIMPLE-SLOTS case allows: -;;; constant or unsupplied initforms -;;; constant default initargs -;;; supplied initargs -;;; slot filling initargs -;;; - -(define-constructor-code-type simple-slots - (class name arglist supplied-initarg-names supplied-initargs) - (declare (ignore name)) - (let ((raw-allocator (raw-instance-allocator class)) - (slots-fetcher (slots-fetcher class))) - `(function - (lambda (class .wrapper. defaults init shared) - (when (and (null (non-pcl-initialize-instance-methods-p init)) - (null (non-pcl-shared-initialize-methods-p shared))) - (multiple-value-bind (.constants. .supplied-initarg-positions.) - (simple-slots-generator-internal class - defaults - ',supplied-initarg-names - ',supplied-initargs) - (when .constants. - (function - (kernel:instance-lambda ,arglist - (declare #.*optimize-speed*) - (let* ((.instance. (,raw-allocator .wrapper. .constants.)) - (.slots. (,slots-fetcher .instance.)) - (.positions. .supplied-initarg-positions.)) - .positions. - - ,@(let ((collected ())) - (doplist (initarg value) supplied-initargs - (unless (constantp value) - (push `(let ((.value. ,value)) - (dolist (.p. (pop .positions.)) - (setf (%instance-ref .slots. .p.) - .value.))) - collected))) - (nreverse collected)) - - .instance.)))))))))) - -(defun simple-slots-generator-internal - (class defaults supplied-initarg-names supplied-initargs) - (flet ((bail-out () (return-from simple-slots-generator-internal nil))) - (let* ((constants (compute-constant-vector class)) - (layout (wrapper-instance-slots-layout (class-wrapper class))) - (initarg-positions - (compute-initarg-positions class - (append supplied-initarg-names - (mapcar #'car defaults)))) - (supplied-initarg-positions ()) - (used-positions ())) - ;; - ;; Go through each of the supplied initargs for three reasons. - ;; - ;; - If it fills a class slot, bail out. - ;; - If its a constant form, fill the constant vector. - ;; - Otherwise remember the positions, no two initargs - ;; will try to fill the same position, since compute - ;; initarg positions already took care of that, but - ;; we do need to know what initforms will and won't - ;; be needed. - ;; - (doplist (initarg val) supplied-initargs - (let ((positions (cdr (assq initarg initarg-positions)))) - (cond ((memq :class positions) (bail-out)) - ((constantp val) - (setq val (eval val)) - (dolist (pos positions) - (setf (svref constants pos) val))) - (t - (push positions supplied-initarg-positions))) - (setq used-positions (append used-positions positions)))) - ;; - ;; Go through each of the default initargs for three reasons. - ;; - ;; - If it isn't a constant form, bail out. - ;; - If it fills a class slot, bail out. - ;; - If it is a constant, and it does fill a slot, put that - ;; into the constant vector. - ;; - (dolist (default defaults) - (let* ((name (car default)) - (form (caddr default)) - (value ()) - (positions (cdr (assq name initarg-positions)))) - (unless (memq name supplied-initarg-names) - (cond ((memq :class positions) (bail-out)) - ((not (constantp form)) - (bail-out)) - (t - (setq value (eval form)) - (dolist (pos positions) - (setf (svref constants pos) value))))))) - ;; - ;; Go through each of the slot initforms: - ;; - ;; - If its position has already been filled, do nothing. - ;; The initfn won't need to be called, and the slot won't - ;; need to be touched, we are OK. - ;; - If it has a non-constant initform, bail-out. This - ;; case doesn't handle those. - ;; - If it has a constant or unsupplied initform we don't - ;; really need to do anything, the value is in the - ;; constants vector. - ;; - (dolist (slotd (class-slots class)) - (let* ((alloc (slot-definition-allocation slotd)) - (name (slot-definition-name slotd)) - (form (slot-definition-initform slotd)) - (initfn (slot-definition-initfunction slotd)) - (position (position name layout))) - (cond ((neq alloc :instance) - (unless (null initfn) - (bail-out))) - ((member position used-positions)) - ((or (constantp form) - (null initfn))) - (t - (bail-out))))) - - (values constants (nreverse supplied-initarg-positions))))) - diff --git a/pcl/cpl.lisp b/pcl/cpl.lisp index 5c5547917..5c4c00651 100644 --- a/pcl/cpl.lisp +++ b/pcl/cpl.lisp @@ -26,7 +26,7 @@ ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/cpl.lisp,v 1.10 2002/08/26 02:23:11 pmai Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/cpl.lisp,v 1.11 2003/03/22 16:15:17 gerd Exp $") ;;; (in-package :pcl) @@ -84,11 +84,12 @@ ;;; rule is used to choose among them. ;;; -(defmethod compute-class-precedence-list ((root slot-class)) +(defmethod compute-class-precedence-list ((root class)) (compute-std-cpl root (class-direct-superclasses root))) (defstruct (class-precedence-description (:conc-name nil) + #-bootable-pcl (:print-function (lambda (obj str depth) (declare (ignore depth)) (format str @@ -102,9 +103,14 @@ (cpd-count 0)) (defun compute-std-cpl (class supers) - (cond ((null supers) ;First two branches of COND - (list class)) ;are implementing the single - ((null (cdr supers)) ;inheritance optimization. + ;; First two branches of COND are implementing the single + ;; inheritance optimization. + (cond ((and (null supers) + (not (forward-referenced-class-p class))) + (list class)) + ((and (car supers) + (null (cdr supers)) + (not (forward-referenced-class-p (car supers)))) (cons class (compute-std-cpl (car supers) (class-direct-superclasses (car supers))))) @@ -207,38 +213,43 @@ ;;; (defun cpl-error (class format-string &rest format-args) - (error "While computing the class precedence list of the class ~A.~%~A" - (if (class-name class) - (format nil "named ~S" (class-name class)) - class) - (apply #'format nil format-string format-args))) - + (error + (format nil "~~@<While computing the class precedence list ~ + of the class ~A: ~?.~~@:>" + (if (class-name class) + (format nil "named ~S" (class-name class)) + class) + format-string format-args))) (defun cpl-forward-referenced-class-error (class forward-class) (flet ((class-or-name (class) (if (class-name class) (format nil "named ~S" (class-name class)) class))) - (let ((names (mapcar #'class-or-name - (cdr (find-superclass-chain class forward-class))))) - (cpl-error class - "The class ~A is a forward referenced class.~@ - The class ~A is ~A." - (class-or-name forward-class) - (class-or-name forward-class) - (if (null (cdr names)) - (format nil - "a direct superclass of the class ~A" - (class-or-name class)) - (format nil - "reached from the class ~A by following~@ - the direct superclass chain through: ~A~ - ~% ending at the class ~A" - (class-or-name class) - (format nil - "~{~% the class ~A,~}" - (butlast names)) - (car (last names)))))))) + (if (eq class forward-class) + (cpl-error class + "The class ~A is a forward referenced class" + (class-or-name class)) + (let ((names (mapcar #'class-or-name + (cdr (find-superclass-chain class forward-class))))) + (cpl-error class + "The class ~A is a forward referenced class. ~ + The class ~A is ~A." + (class-or-name forward-class) + (class-or-name forward-class) + (if (null (cdr names)) + (format nil + "a direct superclass of the class ~A" + (class-or-name class)) + (format nil + "reached from the class ~A by following~@ + the direct superclass chain through: ~A~ + ~% ending at the class ~A" + (class-or-name class) + (format nil + "~{~% the class ~A,~}" + (butlast names)) + (car (last names))))))))) (defun find-superclass-chain (bottom top) (labels ((walk (c chain) @@ -252,8 +263,8 @@ (defun cpl-inconsistent-error (class all-cpds) (let ((reasons (find-cycle-reasons all-cpds))) (cpl-error class - "It is not possible to compute the class precedence list because~@ - there ~A in the local precedence relations.~@ + "It is not possible to compute the class precedence list because ~ + there ~A in the local precedence relations. ~ ~A because:~{~% ~A~}." (if (cdr reasons) "are circularities" "is a circularity") (if (cdr reasons) "These arise" "This arises") diff --git a/pcl/ctor.lisp b/pcl/ctor.lisp new file mode 100644 index 000000000..47875a65f --- /dev/null +++ b/pcl/ctor.lisp @@ -0,0 +1,772 @@ +;;; Copyright (C) 2002, 2003 Gerd Moellmann <gerd.moellmann@t-online.de> +;;; All rights reserved. +;;; +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: +;;; +;;; 1. Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. +;;; 2. Redistributions in binary form must reproduce the above copyright +;;; notice, this list of conditions and the following disclaimer in the +;;; documentation and/or other materials provided with the distribution. +;;; 3. The name of the author may not be used to endorse or promote +;;; products derived from this software without specific prior written +;;; permission. +;;; +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE +;;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +;;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT +;;; OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR +;;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE +;;; USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH +;;; DAMAGE. + +;;; *************** +;;; Overview ***** +;;; *************** +;;; +;;; Compiler macro for MAKE-INSTANCE, and load-time generation of +;;; optimized instance constructor functions. +;;; +;;; ******************** +;;; Entry Points ****** +;;; ******************** +;;; +;;; UPDATE-CTORS must be called when methods are added/removed, +;;; classes are changed, etc., which affect instance creation. +;;; +;;; PRECOMPILE-CTORS can be called to precompile constructor functions +;;; for classes whose definitions are known at the time the function +;;; is called. + +(ext:file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/ctor.lisp,v 1.2 2003/03/22 16:15:17 gerd Exp $") + +(in-package "PCL") + +;;; ****************** +;;; Utilities ******* +;;; ****************** + +(defun plist-keys (plist &key test) + (loop for (key . more) on plist by #'cddr + if (null more) do + (error "~@<Not a property list: ~S.~@:>" plist) + else if (or (null test) (funcall test key)) + collect key)) + + +;;; ***************** +;;; CTORS ********* +;;; ***************** +;;; +;;; Ctors are funcallable instances whose initial function is a +;;; function computing an optimized constructor function when called. +;;; When the optimized function is computed, the function of the +;;; funcallable instance is set to it. +;;; +(defstruct (ctor (:include pcl-funcallable-instance) + (:type kernel:funcallable-structure) + (:constructor %make-ctor)) + ;; + ;; The function name whose function definition is this CTOR. + (function-name nil :type list) + ;; + ;; The name of the class for which this CTOR constructs instances. + ;; We have to know the name here because only when the constructor + ;; function is actually called, we can assume that the class is + ;; actually defined (and throw an error if not). + (class-name nil :type symbol) + ;; + ;; The actual class object iff the optimized constructor function + ;; has been built and set as the funcallable-instance function + ;; of this ctor. + (class nil :type (or null class)) + ;; + ;; Property list of keywords and either constant values, from the + ;; MAKE-INSTANCE form for which this CTOR was constructed, or + ;; constructor function parameter names for non-constant values. + (initargs () :type list) + ;; + ;; The state of the ctor object. NIL if the the constructor function + ;; hasn't been generated yet. OPTIMIZED if an optimized constructor + ;; function has been generated. FALLBACK if an unoptimized constructor + ;; function has been generated. + (state 'initial :type (member initial optimized fallback))) + +;;; List of all defined ctors. + +(defvar *all-ctors* ()) + +(defun make-ctor-parameter-list (ctor) + (loop for (key value) on (ctor-initargs ctor) by #'cddr + unless (constantp value) collect value)) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (ext:define-function-name-syntax ctor (name) + (symbolp (cadr name)))) + +(defun make-ctor-function-name (class-name initargs) + (list* 'ctor class-name initargs)) + +;;; +;;; Reset CTOR to use a default function that will compute an +;;; optimized constructor function when called. +;;; +(defun install-initial-constructor (ctor &key force-p) + (when (or force-p (ctor-class ctor)) + (setf (ctor-class ctor) nil) + (setf (ctor-state ctor) 'initial) + (setf (kernel:funcallable-instance-function ctor) + #'(kernel:instance-lambda (&rest args) + (install-optimized-constructor ctor) + (apply ctor args))) + (setf (kernel:%funcallable-instance-info ctor 1) + (ctor-function-name ctor)))) + +;;; +;;; Keep this a separate function for testing. +;;; +(defun ensure-ctor (function-name class-name initargs) + (unless (fboundp function-name) + (make-ctor function-name class-name initargs))) + +;;; +;;; Keep this a separate function for testing. +;;; +(defun make-ctor (function-name class-name initargs) + (let ((ctor (%make-ctor :function-name function-name + :class-name class-name + :initargs initargs))) + (push ctor *all-ctors*) + (setf (fdefinition function-name) ctor) + (install-initial-constructor ctor :force-p t) + ctor)) + + +;;; *********************************************** +;;; Compile-Time Expansion of MAKE-INSTANCE ******* +;;; *********************************************** + +(define-compiler-macro make-instance (&whole form &rest args) + (declare (ignore args)) + (or (make-instance->constructor-call form) + form)) + +(defun make-instance->constructor-call (form) + (destructuring-bind (fn class-name &rest args) form + (declare (ignore fn)) + (labels ((constant-symbol-p (form) + (and (constantp form) + (let ((constant (eval form))) + (and (symbolp constant) + (not (null (symbol-package constant))))))) + ;; + ;; Return the name of parameter number I of a constructor + ;; function. + (parameter-name (i) + (let ((ps #(.p0. .p1. .p2. .p3. .p4. .p5.))) + (if (array-in-bounds-p ps i) + (aref ps i) + (intern (format nil ".P~D." i) *the-pcl-package*)))) + ;; + ;; Check if CLASS-NAME is a constant symbol. Give up if + ;; not. + (check-class () + (unless (and class-name (constant-symbol-p class-name)) + (return-from make-instance->constructor-call nil))) + ;; + ;; Check if ARGS are suitable for an optimized constructor. + ;; Return NIL from the outer function if not. + (check-args () + (loop for (key . more) on args by #'cddr do + (when (or (null more) + (not (constant-symbol-p key)) + (eq :allow-other-keys (eval key))) + (return-from make-instance->constructor-call nil))))) + (check-class) + (check-args) + ;; + ;; Collect a plist of initargs and constant values/parameter names + ;; in INITARGS. Collect non-constant initialization forms in + ;; VALUE-FORMS. + (multiple-value-bind (initargs value-forms) + (loop for (key value) on args by #'cddr and i from 0 + collect (eval key) into initargs + if (constantp value) + collect value into initargs + else + collect (parameter-name i) into initargs + and collect value into value-forms + finally + (return (values initargs value-forms))) + (let* ((class-name (eval class-name)) + (function-name (make-ctor-function-name class-name initargs))) + ;; + ;; Prevent compiler warnings for calling the ctor. + (c::define-function-name function-name) + (when (eq (ext:info function where-from function-name) :assumed) + (setf (ext:info function where-from function-name) :defined) + (when (ext:info function assumed-type function-name) + (setf (ext:info function assumed-type function-name) nil))) + ;; + ;; Return code constructing a ctor at load time, which, when + ;; called, will set its funcallable instance function to an + ;; optimized constructor function. + `(let ((.x. (load-time-value + (ensure-ctor ',function-name ',class-name ',initargs)))) + (declare (ignore .x.)) + (funcall (function ,function-name) ,@value-forms))))))) + + +;;; ************************************************** +;;; Load-Time Constructor Function Generation ******* +;;; ************************************************** + +;;; +;;; The system-supplied primary INITIALIZE-INSTANCE and +;;; SHARED-INITIALIZE methods. One cannot initialized these variables +;;; to the right values here because said functions don't exist yet +;;; when this file is first loaded. +;;; +(defvar *the-system-ii-method* nil) +(defvar *the-system-si-method* nil) + +(defun install-optimized-constructor (ctor) + (let ((class (find-class (ctor-class-name ctor)))) + (unless (class-finalized-p class) + (finalize-inheritance class)) + (setf (ctor-class ctor) class) + (pushnew ctor (plist-value class 'ctors)) + (if (null *cold-boot-state*) + (multiple-value-bind (lambda fn) + (constructor-function-form ctor) + (%print "installing optimized constructor") + (setf (kernel:funcallable-instance-function ctor) + (or fn (compile-lambda lambda)))) + (multiple-value-bind (lambda fn) + (fallback-generator ctor nil nil) + (declare (ignore lambda)) + (setf (kernel:funcallable-instance-function ctor) fn))))) + +(defun constructor-function-form (ctor) + (let* ((class (ctor-class ctor)) + (proto (class-prototype class)) + (make-instance-methods + (compute-applicable-methods #'make-instance (list class))) + (allocate-instance-methods + (compute-applicable-methods #'allocate-instance (list class))) + (ii-methods + (compute-applicable-methods #'initialize-instance (list proto))) + (si-methods + (compute-applicable-methods #'shared-initialize (list proto t)))) + ;; + ;; Cannot initialize these variables earlier because the generic + ;; functions don't exist when PCL is built. + (when (null *the-system-si-method*) + (setq *the-system-si-method* + (find-method #'shared-initialize + () (list *the-class-slot-object* *the-class-t*))) + (setq *the-system-ii-method* + (find-method #'initialize-instance + () (list *the-class-slot-object*)))) + ;; + ;; Note that when there are user-defined applicable methods on + ;; MAKE-INSTANCE and/or ALLOCATE-INSTANCE, these will show up + ;; together with the system-defined ones in what + ;; COMPUTE-APPLICABLE-METHODS returns. + (or (and (null (cdr make-instance-methods)) + (null (cdr allocate-instance-methods)) + (null (check-initargs class (plist-keys (ctor-initargs ctor)) + (append ii-methods si-methods) nil nil)) + (not (around-or-nonstandard-primary-method-p + ii-methods *the-system-ii-method*)) + (not (around-or-nonstandard-primary-method-p + si-methods *the-system-si-method*)) + (optimizing-generator ctor ii-methods si-methods)) + (fallback-generator ctor nil nil)))) + +(defun around-or-nonstandard-primary-method-p + (methods &optional standard-method) + (loop with primary-checked-p = nil + for method in methods + as qualifiers = (method-qualifiers method) + when (or (eq :around (car qualifiers)) + (and (null qualifiers) + (not primary-checked-p) + (not (null standard-method)) + (not (eq standard-method method)))) + return t + when (null qualifiers) do + (setq primary-checked-p t))) + +(defun fallback-generator (ctor dummy1 dummy2) + (declare (ignore dummy1 dummy2)) + (setf (ctor-state ctor) 'fallback) + (if (null *cold-boot-state*) + `(kernel:instance-lambda ,(make-ctor-parameter-list ctor) + (make-instance ,(ctor-class ctor) ,@(ctor-initargs ctor))) + (let ((class (ctor-class-name ctor)) + (params (copy-list (ctor-initargs ctor))) + (value-cells ())) + (loop for cell on (cdr params) by #'cddr do + (if (constantp (car cell)) + (setf (car cell) (eval (car cell))) + (push cell value-cells))) + (setq value-cells (nreverse value-cells)) + (values nil + #'(kernel:instance-lambda (&rest args) + (dolist (cell value-cells) + (setf (car cell) (pop args))) + (apply #'make-instance class params)))))) + +(defun optimizing-generator (ctor ii-methods si-methods) + (multiple-value-bind (body before-method-p) + (fake-initialization-emf ctor ii-methods si-methods) + (setf (ctor-state ctor) 'optimized) + `(kernel:instance-lambda ,(make-ctor-parameter-list ctor) + (declare (optimize (speed 3))) + (declare (ext:optimize-interface (speed 3))) + ,(wrap-in-allocate-forms ctor body before-method-p)))) + +;;; +;;; Return a form wrapped around BODY that allocates an instance +;;; constructed by CTOR. BEFORE-METHOD-P set means we have to run +;;; before-methods, in which case we initialize instance slots to +;;; +SLOT-UNBOUND+. The resulting form binds the local variables +;;; .INSTANCE. to the instance. For non-structure instances, +;;; .SLOTS. is bound to the instance's slot vector around BODY. +;;; +(defun wrap-in-allocate-forms (ctor body before-method-p) + (let ((class (ctor-class ctor))) + (if (structure-class-p class) + (let ((allocation-function (class-defstruct-constructor class))) + `(let ((.instance. (,allocation-function))) + ,body + .instance.)) + (let ((wrapper (class-wrapper class)) + (allocation-function (raw-instance-allocator class)) + (slots-fetcher (slots-fetcher class))) + (if (eq allocation-function 'allocate-standard-instance) + `(let ((.instance. (%%allocate-instance--class)) + (.slots. (make-array ,(kernel:layout-length wrapper) + ,@(when before-method-p + '(:initial-element + +slot-unbound+))))) + (setf (std-instance-wrapper .instance.) ,wrapper) + (setf (std-instance-slots .instance.) .slots.) + ,body + .instance.) + `(let* ((.instance. (,allocation-function ,wrapper)) + (.slots. (,slots-fetcher .instance.))) + ,body + .instance.)))))) + +;;; +;;; Return a form for invoking METHOD with arguments from ARGS. As +;;; can be seen in METHOD-FUNCTION-FROM-FAST-FUNCTION, method +;;; functions look like (LAMBDA (ARGS NEXT-METHODS) ...). We could +;;; call fast method functions directly here, but benchmarks show that +;;; there's no speed to gain, so lets avoid the hair here. +;;; +#+nil +(defmacro invoke-method (method args) + (let ((fn (method-function method))) + `(funcall (ext:truly-the function ,fn) ,args ()))) + +;;; +;;; Return a form that is sort of an effective method comprising all +;;; calls to INITIALIZE-INSTANCE and SHARED-INITIALIZE that would +;;; normally have taken place when calling MAKE-INSTANCE. +;;; +(defun fake-initialization-emf (ctor ii-methods si-methods) + (multiple-value-bind (ii-around ii-before ii-primary ii-after) + (standard-sort-methods ii-methods) + (declare (ignore ii-primary)) + (multiple-value-bind (si-around si-before si-primary si-after) + (standard-sort-methods si-methods) + (declare (ignore si-primary)) + (assert (and (null ii-around) (null si-around))) + (let ((initargs (ctor-initargs ctor)) + (slot-inits (slot-init-forms ctor (or ii-before si-before)))) + (flet ((method-calls (methods args) + (loop for method in methods + as fn = (method-function method) + collect `(funcall (ext:truly-the function ,fn) + ,args ())))) + (values + `(let (,@(when (or ii-before ii-after) + `((.ii-args. (list .instance. ,@initargs)))) + ,@(when (or si-before si-after) + `((.si-args. (list .instance. t ,@initargs))))) + ,@(method-calls ii-before '.ii-args.) + ,@(method-calls si-before '.si-args.) + ,slot-inits + ,@(method-calls si-after '.si-args.) + ,@(method-calls ii-after '.ii-args.)) + (or ii-before si-before))))))) + +;;; +;;; Return four values from APPLICABLE-METHODS: around methods, before +;;; methods, the applicable primary method, and applicable after +;;; methods. Before and after methods are sorted in the order they +;;; must be called. +;;; +(defun standard-sort-methods (applicable-methods) + (loop for method in applicable-methods + as qualifiers = (method-qualifiers method) + if (null qualifiers) + collect method into primary + else if (eq :around (car qualifiers)) + collect method into around + else if (eq :after (car qualifiers)) + collect method into after + else if (eq :before (car qualifiers)) + collect method into before + finally + (return (values around before (first primary) (nreverse after))))) + + +;;; +;;; Return the declared type of slot TYPE, or T if we don't want +;;; to use slot types. +;;; +(declaim (inline slot-type-or-t)) +(defun slot-type-or-t (slot) + (declare (special *use-slot-types-p*)) + (if *use-slot-types-p* + (slot-definition-type slot) + t)) + +;;; +;;; Return a form initializing instance and class slots of an object +;;; costructed by CTOR. The variable .SLOTS. is assumed to bound to a +;;; non-structure instance's slot vector. The variable .INSTANCE. is +;;; assumed to be bound in case of a structure instance. +;;; +;;; BEFORE-METHOD-P T means before-methods will be called, which, for +;;; not-structures, means that 1) other code will initialize instance +;;; slots to +SLOT-UNBOUND+ before the before-methods are run, and 2) +;;; that we have to check if these before-methods have set slots. +;;; For structures the consequences are likewise. +;;; +(defun slot-init-forms (ctor before-method-p) + (let* ((class (ctor-class ctor)) + (structure-p (structure-class-p class)) + (initargs (ctor-initargs ctor)) + (initkeys (plist-keys initargs)) + (slot-vector + (unless structure-p + (make-array (kernel:layout-length (class-wrapper class)) + :initial-element nil))) + (class-inits ()) + (structure-inits ()) + (default-initargs (class-default-initargs class)) + ;; + ;; Note that the locations are actually defstruct slot + ;; accessors for structures. + (locations (compute-initarg-locations + class + (append initkeys (mapcar #'car default-initargs))))) + (labels ((locations (key) + (cdr (assoc key locations :test #'eq))) + + (class-init (location type val slot-type) + (assert (consp location)) + (assert (not structure-p)) + (unless (assoc location class-inits :test #'eq) + (push (list location type val slot-type) class-inits))) + + (instance-init (location type val slot-type) + (assert (not (instance-slot-initialized-p location))) + (cond (structure-p + (assert (symbolp location)) + (push (list location type val slot-type) + structure-inits)) + (t + (assert (integerp location)) + (setf (aref slot-vector location) + (list type val slot-type))))) + + (instance-slot-initialized-p (location) + (if structure-p + (assq location structure-inits) + (not (null (aref slot-vector location)))))) + ;; + ;; Loop over supplied initargs and values and record which + ;; instance and class slots they initialize. + (loop for (key value) on initargs by #'cddr + as type = (if (constantp value) 'constant 'param) do + (loop for (location . slot-type) in (locations key) do + (if (consp location) + (class-init location type value slot-type) + (instance-init location type value slot-type)))) + ;; + ;; Loop over default initargs of the class, recording + ;; initializations of slots that have not been initialized + ;; above. + (loop for (key initfn initform) in default-initargs + unless (memq key initkeys) do + (loop with type = (if (constantp initform) 'constant 'initfn) + with init = (if (eq type 'initfn) initfn initform) + for (location . slot-type) in (locations key) do + (if (consp location) + (class-init location type init slot-type) + (instance-init location type init slot-type)))) + ;; + ;; Loop over all slots of the class, filling in the rest from + ;; slot initforms. + (loop for slotd in (class-slots class) + as location + = (if structure-p + (slot-definition-defstruct-accessor-symbol slotd) + (slot-definition-location slotd)) + as allocation = (slot-definition-allocation slotd) + as initfn = (slot-definition-initfunction slotd) + as slot-type = (slot-type-or-t slotd) + as initform = (slot-definition-initform slotd) do + (unless (or (eq allocation :class) + (and (not structure-p) + (null initfn)) + (instance-slot-initialized-p location)) + (if (constantp initform) + (instance-init location 'initform initform slot-type) + (instance-init location 'initform/initfn initfn + slot-type)))) + ;; + ;; Generate the forms for initializing instance and class slots. + (let ((instance-init-forms + (delete nil + (if structure-p + (structure-init-forms structure-inits before-method-p) + (instance-init-forms slot-vector before-method-p)))) + (class-init-forms + (unless structure-p + (loop for (location type value slot-type) in class-inits + collect + `(setf (cdr ',location) + (the ,slot-type + ,(ecase type + (constant `',(eval value)) + (param `,value) + (initfn `(funcall ,value))))))))) + `(progn + ,@instance-init-forms + ,@class-init-forms))))) + +;;; +;;; Return an alist of lists (KEY LOCATION ...) telling, for each key +;;; in INITKEYS, which locations the initarg initializes. For +;;; structures, defstruct slot accessor symbols are used as location. +;;; CLASS is the class of the instance being initialized. +;;; +(defun compute-initarg-locations (class initkeys) + (let ((get-location-fn (if (structure-class-p class) + #'slot-definition-defstruct-accessor-symbol + #'slot-definition-location))) + (loop with slots = (class-slots class) + for key in initkeys + collect + (loop for slot in slots + if (memq key (slot-definition-initargs slot)) + collect (cons (funcall get-location-fn slot) + (slot-type-or-t slot)) + into locations + else + collect slot into remaining-slots + finally + (setq slots remaining-slots) + (return (cons key locations)))))) + +;;; +;;; Return a list of forms for initializing instance slots as +;;; described by SLOT-VECTOR. Each element of SLOT-VECTOR is a list +;;; (TYPE VALUE SLOT-TYPE). See function SLOT-INIT-FORMS. +;;; BEFORE-METHOD-P true means before-methods are run; we can assume +;;; in that case that all slots are initialized to +SLOT-UNBOUND+ when +;;; the instance is allocated. +;;; +(defun instance-init-forms (slot-vector before-method-p) + (loop for slot-entry across slot-vector and i from 0 + as (type value slot-type) = slot-entry + collect + (ecase type + ((nil) + (unless before-method-p + `(setf (%svref .slots. ,i) +slot-unbound+))) + (param + `(setf (%svref .slots. ,i) (the ,slot-type ,value))) + (initfn + `(setf (%svref .slots. ,i) + (the ,slot-type (funcall ,value)))) + (initform/initfn + (if before-method-p + `(when (eq (%svref .slots. ,i) +slot-unbound+) + (setf (%svref .slots. ,i) + (the ,slot-type (funcall ,value)))) + `(setf (%svref .slots. ,i) + (the ,slot-type (funcall ,value))))) + (initform + (if before-method-p + `(when (eq (%svref .slots. ,i) +slot-unbound+) + (setf (%svref .slots. ,i) + (the ,slot-type ',(eval value)))) + `(setf (%svref .slots. ,i) + (the ,slot-type ',(eval value))))) + (constant + `(setf (%svref .slots. ,i) + (the ,slot-type ',(eval value))))))) + +;;; +;;; Like INSTANCE-INIT-FORMS, but for a structure instance. +;;; INITS is a list describing the slots to initialize. +;;; +(defun structure-init-forms (inits before-method-p) + (loop for (accessor type value slot-type) in inits + collect + (ecase type + ((nil) + (if before-method-p + `(when (eq (,accessor .instance.) '.unbound.) + (setf (,accessor .instance.) nil)) + `(setf (,accessor .instance.) nil))) + (param + `(setf (,accessor .instance.) (the ,slot-type ,value))) + (initfn + `(setf (,accessor .instance.) + (the ,slot-type (funcall ,value)))) + (initform/initfn + (if before-method-p + `(when (eq (,accessor .instance.) '.unbound.) + (setf (,accessor .instance.) + (the ,slot-type (funcall ,value)))) + `(setf (,accessor .instance.) + (the ,slot-type (funcall ,value))))) + (initform + (if before-method-p + `(when (eq (,accessor .instance.) '.unbound.) + (setf (,accessor .instance.) + (the ,slot-type ',(eval value)))) + `(setf (,accessor .instance.) + (the ,slot-type ',(eval value))))) + (constant + `(setf (,accessor .instance.) + (the ,slot-type ',(eval value))))))) + + +;;; ******************************* +;;; External Entry Points ******** +;;; ******************************* + +(defun update-ctors (reason &key class name generic-function method) + (labels ((reset (class &optional ri-cache-p (ctors-p t)) + (when ctors-p + (dolist (ctor (plist-value class 'ctors)) + (install-initial-constructor ctor))) + (when ri-cache-p + (setf (plist-value class 'ri-initargs) ())) + (dolist (subclass (class-direct-subclasses class)) + (reset subclass ri-cache-p ctors-p)))) + (ecase reason + ;; + ;; CLASS must have been specified. + (finalize-inheritance + (reset class t)) + ;; + ;; NAME must have been specified. + (setf-find-class + (loop for ctor in *all-ctors* + when (eq (ctor-class-name ctor) name) do + (when (ctor-class ctor) + (reset (ctor-class ctor))) + (loop-finish))) + ;; + ;; GENERIC-FUNCTION and METHOD must have been specified. + ((add-method remove-method) + (flet ((class-of-1st-method-param (method) + (type-class (first (method-specializers method))))) + (case (generic-function-name generic-function) + ((make-instance allocate-instance initialize-instance + shared-initialize) + (reset (class-of-1st-method-param method) t t)) + ((reinitialize-instance) + (reset (class-of-1st-method-param method) t nil)))))))) + +(defun precompile-ctors () + (dolist (ctor *all-ctors*) + (when (null (ctor-class ctor)) + (let ((class (find-class (ctor-class-name ctor) nil))) + (when (and class (class-finalized-p class)) + (install-optimized-constructor ctor)))))) + +;;; +;;; Try to call a CTOR of class CLASS to construct an instance of CLASS +;;; with given initargs. Value is an instance of CLASS if a suitable +;;; ctor is found, NIL otherwise. +;;; +;;; This is called from MAKE-INSTANCE. +;;; +(defun call-ctor (class initargs) + (flet (;; + ;; Return two values ARGS, MATCH-P. ARGS is a list of values + ;; from INITARGS with which the ctor can be invoked. MATCH-P + ;; true means the ctor can be used. + (call-args (ctor) + (loop with match-p = t + for (key supplied-value) on initargs by #'cddr + as value = (getf (ctor-initargs ctor) key 'not-found) + while match-p + when (or (eq 'not-found value) + (and (constantp value) + (not (eql supplied-value value)))) do + (setq match-p nil) + unless (constantp value) + collect supplied-value into args + finally + (return (values args match-p))))) + ;; + ;; Loop over all ctors of CLASS looking for a ctor that can be + ;; used to construct an instance with the given initargs. If one + ;; is found, invoke it and return its value. + (dolist (ctor (plist-value class 'ctors)) + (when (eq (ctor-state ctor) 'optimized) + (multiple-value-bind (args match-p) + (call-args ctor) + (when match-p + (return (apply ctor args)))))))) + +;;; +;;; REINITIALIZE-INSTANCE initargs checking with memoization. +;;; INSTANCE is the instance being reinitialized, INITARGS are the +;;; initargs passed to REINITIALIZE-INSTANCE. +;;; +;;; The function UPDATE-CTORS clears the memoization cache. +;;; +(defun check-ri-initargs (instance initargs) + (let* ((class (class-of instance)) + (keys (plist-keys initargs)) + (cached (assoc keys (plist-value class 'ri-initargs) + :test #'equal)) + (invalid-keys + (if (consp cached) + (cdr cached) + (let ((invalid (check-initargs + class initargs + (list (list* 'reinitialize-instance + instance initargs) + (list* 'shared-initialize + instance nil initargs)) + t nil))) + (setf (plist-value class 'ri-initargs) + (acons keys invalid cached)) + invalid)))) + (when invalid-keys + (invalid-initargs-error class invalid-keys)))) + +;;; end of ctor.lisp diff --git a/pcl/ctypes.lisp b/pcl/ctypes.lisp index bd2c7a6d6..e0d216245 100644 --- a/pcl/ctypes.lisp +++ b/pcl/ctypes.lisp @@ -23,7 +23,6 @@ ;;; ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* -;;; (in-package :pcl) diff --git a/pcl/defclass.lisp b/pcl/defclass.lisp index 840601af8..e7d1426f7 100644 --- a/pcl/defclass.lisp +++ b/pcl/defclass.lisp @@ -23,10 +23,9 @@ ;;; ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* -;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/defclass.lisp,v 1.24 2002/10/19 14:56:02 pmai Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/defclass.lisp,v 1.25 2003/03/22 16:15:17 gerd Exp $") ;;; (in-package :pcl) @@ -49,9 +48,9 @@ (defun make-top-level-form (name times form) (flet ((definition-name () (if (and (listp name) - (memq (car name) '(defmethod defclass class method method-combination))) - (format nil "~A~{ ~S~}" - (capitalize-words (car name) ()) (cdr name)) + (memq (car name) '(defmethod defclass class method + method-combination))) + (format nil "~A~{ ~S~}" (car name) (cdr name)) (format nil "~S" name)))) (definition-name) (if (or (member 'compile times) @@ -72,9 +71,9 @@ ;;; has been defined, the real definition of LOAD-DEFCLASS is installed by the ;;; file defclass.lisp ;;; -(defmacro DEFCLASS (name direct-superclasses direct-slots &rest options) - (declare (indentation 2 4 3 1)) - (expand-defclass name direct-superclasses direct-slots options)) +(defmacro defclass (name direct-superclasses direct-slots + &rest options &environment env) + (expand-defclass name direct-superclasses direct-slots options env)) ;;; The following functions were moved here from slots-boot.lisp ;;; because expand-defclass now depends on them to generate ftype @@ -82,41 +81,28 @@ ;;; the relevant GFs at run-time, in order to squelch spurious ;;; warnings. -(defmacro slot-symbol (slot-name type) - `(if (and (symbolp ,slot-name) (symbol-package ,slot-name)) - (or (get ,slot-name ',(ecase type - (reader 'reader-symbol) - (writer 'writer-symbol) - (boundp 'boundp-symbol))) - (intern (format nil "~A ~A slot ~a" - (package-name (symbol-package ,slot-name)) - (symbol-name ,slot-name) - ,(symbol-name type)) - *slot-accessor-name-package*)) - (progn - (error "non-symbol and non-interned symbol slot name accessors~ - are not yet implemented") - ;;(make-symbol (format nil "~a ~a" ,slot-name ,type)) - ))) - -(defun slot-reader-symbol (slot-name) - (slot-symbol slot-name reader)) - -(defun slot-writer-symbol (slot-name) - (slot-symbol slot-name writer)) - -(defun slot-boundp-symbol (slot-name) - (slot-symbol slot-name boundp)) +(defun slot-reader-name (slot-name) + (list 'slot-accessor :global slot-name 'reader)) + +(defun slot-writer-name (slot-name) + (list 'slot-accessor :global slot-name 'writer)) + +(defun slot-boundp-name (slot-name) + (list 'slot-accessor :global slot-name 'boundp)) ;;; The defclass expander proper -(defun expand-defclass (name supers slots options) - (declare (special *defclass-times* *boot-state* *the-class-structure-class*)) - (setq supers (nsubstitute 'standard-class 'lisp:standard-class - (copy-tree supers)) - slots (copy-tree slots) +(defun expand-defclass (name supers slots options env) + (declare (special *boot-state* *the-class-structure-class*)) + (setq slots (copy-tree slots) options (copy-tree options)) - (let ((metaclass 'standard-class)) + ;; + (when (eq *boot-state* 'complete) + (dolist (super supers) + (check-seals super 'expand-defclass))) + ;; + (let ((metaclass 'standard-class) + (info-slots (copy-tree slots))) ;; TBD - ANSI compliant class and slot option checking. (dolist (option options) (if (not (listp option)) @@ -125,14 +111,10 @@ (when (eq (car option) :metaclass) (unless (legal-class-name-p (cadr option)) (simple-program-error - "The value of the :metaclass option (~S) is not a~%~ - legal class name." - (cadr option))) - (setq metaclass - (case (cadr option) - (lisp:standard-class 'standard-class) - (lisp:structure-class 'structure-class) - (t (cadr option)))) + "~@<The value of the ~s option (~s) is not a legal ~ + class name.~@:>" + :metaclass (cadr option))) + (setq metaclass (cadr option)) (setf options (remove option options)) (return t)))) @@ -149,37 +131,43 @@ (mapcar (lambda (option) (canonicalize-defclass-option name option)) options)) - (defstruct-p (and (eq *boot-state* 'complete) - (let ((mclass (find-class metaclass nil))) - (and mclass - (*subtypep mclass - *the-class-structure-class*)))))) + (defstruct-p + (and (eq *boot-state* 'complete) + (not (or (ext:featurep :loadable-pcl) + (ext:featurep :bootable-pcl))) + (let ((mclass (find-class metaclass nil))) + (and mclass + (*subtypep mclass + *the-class-structure-class*)))))) (let ((defclass-form - (make-top-level-form `(defclass ,name) - (if defstruct-p '(load eval) *defclass-times*) - `(progn - ,@(mapcar (lambda (x) - `(declaim (ftype (function (t) t) ,x))) - *readers*) - ,@(mapcar (lambda (x) - `(declaim (ftype (function (t t) t) ,x))) - *writers*) - ,@(mapcar (lambda (x) - `(declaim (ftype (function (t) t) - ,(slot-reader-symbol x) - ,(slot-boundp-symbol x)) - (ftype (function (t t) t) - ,(slot-writer-symbol x)))) - *slots*) - (let ,(mapcar #'cdr *initfunctions*) - (load-defclass ',name - ',metaclass - ',supers - (list ,@canonical-slots) - (list ,@(apply #'append - (when defstruct-p - '(:from-defclass-p t)) - other-initargs)))))))) + (make-top-level-form + `(defclass ,name) + (if (define-class-at-compile-time-p env name supers) + '(:compile-toplevel :load-toplevel :execute) + '(:load-toplevel :execute)) + `(progn + ,@(mapcar (lambda (x) + `(declaim (ftype (function (t) t) ,x))) + *readers*) + ,@(mapcar (lambda (x) + `(declaim (ftype (function (t t) t) ,x))) + *writers*) + ,@(mapcar (lambda (x) + `(declaim (ftype (function (t) t) + ,(slot-reader-name x) + ,(slot-boundp-name x)) + (ftype (function (t t) t) + ,(slot-writer-name x)))) + *slots*) + (let ,(mapcar #'cdr *initfunctions*) + (load-defclass ',name + ',metaclass + ',supers + (list ,@canonical-slots) + (list ,@(apply #'append + (when defstruct-p + '(:from-defclass-p t)) + other-initargs)))))))) (if defstruct-p (progn (eval defclass-form) ; define the class now, so that @@ -187,8 +175,8 @@ ,(class-defstruct-form (find-class name)) ,defclass-form)) (progn - (when (and (eq *boot-state* 'complete) - (not (member 'compile *defclass-times*))) + (set-class-info name metaclass info-slots) + (when (eq *boot-state* 'complete) (when (eq metaclass 'standard-class) ;; a funcallable-standard-class metaclass here causes ;; a compiler crash in construct.lisp @@ -223,14 +211,15 @@ (push spec *slots*) `'(:name ,spec)) ((not (consp spec)) - (error "~S is not a legal slot specification." spec)) + (error "~@<~S is not a legal slot specification.~@:>" spec)) ((null (cdr spec)) (push (car spec) *slots*) `'(:name ,(car spec))) ((null (cddr spec)) - (error "In DEFCLASS ~S, the slot specification ~S is obsolete.~%~ - Convert it to ~S" - class-name spec (list (car spec) :initform (cadr spec)))) + (error "~@<In the class definintion of ~s, the slot specification ~s ~ + is obsolete. Convert it to ~s.~@:>" + class-name spec + (list (car spec) :initform (cadr spec)))) (t (let* ((name (pop spec)) (readers ()) @@ -293,7 +282,8 @@ (defun early-class-definition (class-name) (or (find class-name *early-class-definitions* :key #'ecd-class-name) - (error "~S is not a class in *early-class-definitions*." class-name))) + (error "~@<~S is not a class in *early-class-definitions*.~@:>" + class-name))) (defun make-early-class-definition (name source metaclass @@ -326,7 +316,6 @@ (length (early-class-slots class-name))) (defun early-collect-inheritance (class-name) - ;;(declare (values slots cpl default-initargs direct-subclasses)) (let ((cpl (early-collect-cpl class-name))) (values (early-collect-slots cpl) cpl @@ -343,10 +332,10 @@ (let ((name1 (canonical-slot-name s1))) (dolist (s2 (cdr (memq s1 slots))) (when (eq name1 (canonical-slot-name s2)) - (error "More than one early class defines a slot with the~%~ - name ~S. This can't work because the bootstrap~%~ - object system doesn't know how to compute effective~%~ - slots." + (error "~@<More than one early class defines a slot with the ~ + name ~S. This can't work because the bootstrap ~ + object system doesn't know how to compute effective ~ + slots.~@:>" name1))))) slots)) @@ -366,8 +355,8 @@ (loop (when (null others) (return nil)) (let ((initarg (pop others))) (unless (eq initarg :direct-default-initargs) - (error "The defclass option ~S is not supported by the bootstrap~%~ - object system." + (error "~@<The defclass option ~S is not supported by ~ + the bootstrap object system.~@:>" initarg))) (setq default-initargs (nconc default-initargs (reverse (pop others))))))) @@ -375,7 +364,7 @@ (defun bootstrap-slot-index (class-name slot-name) (or (position slot-name (early-class-slots class-name)) - (error "~S not found" slot-name))) + (internal-error "Slot ~S not found in class ~S" slot-name class-name))) ;;; ;;; bootstrap-get-slot and bootstrap-set-slot are used to access and change @@ -394,7 +383,7 @@ ;;; object system later. ;;; (defmacro bootstrap-get-slot (type object slot-name) - `(instance-ref (get-slots ,object) (bootstrap-slot-index ,type ,slot-name))) + `(slot-ref (get-slots ,object) (bootstrap-slot-index ,type ,slot-name))) (defun bootstrap-set-slot (type object slot-name new-value) (setf (bootstrap-get-slot type object slot-name) new-value)) diff --git a/pcl/defcombin.lisp b/pcl/defcombin.lisp index 3987e3261..37de87e57 100644 --- a/pcl/defcombin.lisp +++ b/pcl/defcombin.lisp @@ -23,11 +23,9 @@ ;;; ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* -;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/defcombin.lisp,v 1.21 2003/02/06 15:20:13 gerd Exp $") -;;; + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/defcombin.lisp,v 1.22 2003/03/22 16:15:17 gerd Exp $") (in-package :pcl) @@ -66,14 +64,16 @@ -;;; -;;; STANDARD method combination -;;; -;;; The STANDARD method combination type is implemented directly by the class -;;; STANDARD-METHOD-COMBINATION. The method on COMPUTE-EFFECTIVE-METHOD does -;;; standard method combination directly and is defined by hand in the file -;;; combin.lisp. The method for FIND-METHOD-COMBINATION must appear in this -;;; file for bootstrapping reasons. +;;; *********************************** +;;; STANDARD method combination ******* +;;; *********************************** + +;;; The STANDARD method combination type is implemented directly by +;;; the class STANDARD-METHOD-COMBINATION. The method on +;;; COMPUTE-EFFECTIVE-METHOD does standard method combination directly +;;; and is defined by hand in the file combin.lisp. The method for +;;; FIND-METHOD-COMBINATION must appear in this file for bootstrapping +;;; reasons. ;;; ;;; A commented out copy of this definition appears in combin.lisp. ;;; If you change this definition here, be sure to change it there @@ -84,20 +84,19 @@ options) (when options (method-combination-error - "The method combination type STANDARD accepts no options.")) + "The standard method combination accepts no options.")) *standard-method-combination*) - -;;; -;;; short method combinations +;;; ******************************* +;;; Short Method Combinations ***** +;;; ******************************* ;;; ;;; Short method combinations all follow the same rule for computing the ;;; effective method. So, we just implement that rule once. Each short ;;; method combination object just reads the parameters out of the object ;;; and runs the same rule. -;;; -;;; + (defclass short-method-combination (standard-method-combination) ((operator :reader short-combination-operator @@ -116,7 +115,7 @@ (operator (getf (cddr whole) :operator type))) (make-top-level-form `(define-method-combination ,type) - '(load eval) + '(:load-toplevel :execute) `(load-short-defcombin ',type ',operator ',identity-with-one-arg ',documentation)))) @@ -163,10 +162,10 @@ ((equal options '(:most-specific-last))) (t (method-combination-error - "Illegal options to a short method combination type.~%~ - The method combination type ~S accepts one option which~%~ - must be either :MOST-SPECIFIC-FIRST or :MOST-SPECIFIC-LAST." - type))) + "~@<Invalid options to a short method combination type. ~ + The method combination type ~S accepts one option which ~ + must be either ~s or ~s.~@:>" + type :most-specific-first :most-specific-last))) (make-instance 'short-method-combination :type type :options options @@ -189,12 +188,13 @@ (flet ((lose (method why) (invalid-method-error method - "The method ~S ~A.~%~ - The method combination type ~S was defined with the~%~ - short form of DEFINE-METHOD-COMBINATION and so requires~%~ - all methods have either the single qualifier ~S or the~%~ - single qualifier :AROUND." - method why type type))) + "~@<The method ~S ~A. ~ + The method combination type ~S was defined with the ~ + short form of ~s and so requires all methods have ~ + either the single qualifier ~S or the single qualifier ~ + ~s.~@:>" + method why type 'define-method-combination type + :around))) (cond ((null qualifiers) (lose m "has no qualifiers")) ((cdr qualifiers) @@ -215,7 +215,7 @@ `(,operator ,@(mapcar (lambda (m) `(call-method ,m ())) primary))))) (cond ((null primary) - `(error "No ~S methods for the generic function ~S." + `(error "~@<No ~S methods for the generic function ~S.~@:>" ',type ',generic-function)) ((null around) main-method) (t @@ -223,10 +223,9 @@ (,@(cdr around) (make-method ,main-method)))))))) -;;; -;;; long method combinations -;;; -;;; +;;; ****************************** +;;; Long Method Combinations ***** +;;; ****************************** (defun expand-long-defcombin (form) (let ((type (cadr form)) @@ -246,11 +245,9 @@ (make-top-level-form `(define-method-combination ,type) '(:load-toplevel :execute) `(load-long-defcombin ',type ',documentation #',function - ',arguments-option))))) + ',arguments-option))))) -(defvar *long-method-combination-functions* (make-hash-table :test #'eq)) - -(defun load-long-defcombin (type doc function arguments-lambda-list) +(defun load-long-defcombin (type doc function args-lambda-list) (let* ((specializers (list (find-class 'generic-function) (intern-eql-specializer type) @@ -271,14 +268,13 @@ :type type :options options :function function - :arguments-lambda-list - arguments-lambda-list + :args-lambda-list args-lambda-list :documentation doc)) args)) :definition-source `((define-method-combination ,type) ,*load-pathname*)))) - (setf (gethash type *long-method-combination-functions*) function) - (when old-method (remove-method #'find-method-combination old-method)) + (when old-method + (remove-method #'find-method-combination old-method)) (add-method #'find-method-combination new-method) (set-random-documentation type 'method-combination doc) type)) @@ -286,47 +282,34 @@ (defmethod compute-effective-method ((generic-function generic-function) (combin long-method-combination) applicable-methods) - (funcall (gethash (method-combination-type combin) - *long-method-combination-functions*) - generic-function - combin - applicable-methods)) + (funcall (long-method-combination-function combin) + generic-function combin applicable-methods)) -;;; -;;; -;;; (defun make-long-method-combination-function - (type ll method-group-specifiers arguments-option gf-var body) + (type ll method-group-specifiers arguments-option gf-var body) (declare (ignore type)) (multiple-value-bind (real-body declarations documentation) ;; Note that PARSE-BODY ignores its second arg ENVIRONMENT. (system:parse-body body nil) - (let ((wrapped-body - (wrap-method-group-specifier-bindings method-group-specifiers - declarations - real-body))) + (wrap-method-group-specifier-bindings method-group-specifiers + declarations + real-body))) (when gf-var (push `(,gf-var .generic-function.) (cadr wrapped-body))) - (when arguments-option (setq wrapped-body (deal-with-arguments-option wrapped-body arguments-option))) - (when ll (setq wrapped-body `(apply (lambda ,ll ,wrapped-body) (method-combination-options .method-combination.)))) - (values - documentation - `(lambda (.generic-function. .method-combination. .applicable-methods.) + documentation + `(lambda (.generic-function. .method-combination. .applicable-methods.) (declare (ignorable .generic-function. .method-combination. - .applicable-methods.)) - (block .long-method-combination-function. ,wrapped-body)))))) -;; -;; parse-method-group-specifiers parse the method-group-specifiers -;; + .applicable-methods.)) + (block .long-method-combination-function. ,wrapped-body)))))) (defun wrap-method-group-specifier-bindings (method-group-specifiers declarations real-body) @@ -344,11 +327,11 @@ (push specializer-cache specializer-caches) (push `((or ,@tests) (if (and (equal ,specializer-cache .specializers.) - (not (null .specializers.))) - (return-from .long-method-combination-function. - '(error "More than one method of type ~S ~ - with the same specializers." - ',name)) + (not (null .specializers.))) + (return-from .long-method-combination-function. + '(error "~@<More than one method of type ~S ~ + with the same specializers.~@:>" + ',name)) (setq ,specializer-cache .specializers.)) (push .method. ,name)) cond-clauses) @@ -379,9 +362,8 @@ ,@(nreverse required-checks) ,@(nreverse order-cleanups) ,@real-body))) - + (defun parse-method-group-specifier (method-group-specifier) - ;;(declare (values name tests description order required)) (loop with name = (pop method-group-specifier) for rest on method-group-specifier for pattern = (car rest) @@ -402,8 +384,8 @@ ((eq pattern '*) t) ((symbolp pattern) `(,pattern .qualifiers.)) ((listp pattern) `(qualifier-check-runtime ',pattern .qualifiers.)) - (t (error "In the method group specifier ~S,~%~ - ~S isn't a valid qualifier pattern." + (t (error "~@<In the method group specifier ~S, ~ + ~S isn't a valid qualifier pattern.~@:>" name pattern)))) (defun qualifier-check-runtime (pattern qualifiers) @@ -427,66 +409,63 @@ "methods matching the pattern: ~S" (car patterns)))) - - ;;; ;;; Return a form that deals with the :ARGUMENTS lambda-list of a long ;;; method combination. WRAPPED-BODY is the body of the method -;;; combination so far, and ARGUMENTS-LAMBDA-LIST is the arguments -;;; lambda-list of the method combination. +;;; combination so far, and ARGS-LAMBDA-LIST is the args-lambda-list +;;; of the method combination. ;;; -(defun deal-with-arguments-option (wrapped-body arguments-lambda-list) +(defun deal-with-arguments-option (wrapped-body args-lambda-list) (let ((intercept-rebindings - (loop for arg in arguments-lambda-list + (loop for arg in args-lambda-list unless (memq arg lambda-list-keywords) collect `(,arg ',arg))) - (nreq 0) - (nopt 0) + (nreq 0) + (nopt 0) whole) ;; ;; Count the number of required and optional parameters in - ;; ARGUMENTS-LAMBDA-LIST into NREQ and NOPT, and set WHOLE to the + ;; ARGS-LAMBDA-LIST into NREQ and NOPT, and set WHOLE to the ;; name of a &WHOLE parameter, if any. (loop with state = 'required - for arg in arguments-lambda-list do - (if (memq arg lambda-list-keywords) - (setq state arg) - (case state - (required (incf nreq)) - (&optional (incf nopt)) - (&whole (setq whole arg - state 'required))))) + for arg in args-lambda-list do + (if (memq arg lambda-list-keywords) + (setq state arg) + (case state + (required (incf nreq)) + (&optional (incf nopt)) + (&whole (setq whole arg state 'required))))) ;; - ;; This assumes that the WRAPPED-BODY is a let/let* form, and it + ;; This assumes that the cadr of the WRAPPED-BODY is a let, and it ;; injects let-bindings of the form (ARG 'SYM) for all variables ;; of the argument-lambda-list; SYM is a gensym. (assert (memq (first wrapped-body) '(let let*))) (setf (second wrapped-body) - (append intercept-rebindings (second wrapped-body))) + (append intercept-rebindings (second wrapped-body))) ;; ;; Be sure to fill out the args lambda list so that it can be too ;; short if it wants to. - (unless (or (memq '&rest arguments-lambda-list) - (memq '&allow-other-keys arguments-lambda-list)) - (let ((aux (memq '&aux arguments-lambda-list))) - (setq arguments-lambda-list - (append (ldiff arguments-lambda-list aux) - (if (memq '&key arguments-lambda-list) - '(&allow-other-keys) - '(&rest .ignore.)) - aux)))) + (unless (or (memq '&rest args-lambda-list) + (memq '&allow-other-keys args-lambda-list)) + (let ((aux (memq '&aux args-lambda-list))) + (setq args-lambda-list + (append (ldiff args-lambda-list aux) + (if (memq '&key args-lambda-list) + '(&allow-other-keys) + '(&rest .ignore.)) + aux)))) ;; ;; .GENERIC-FUNCTION. is bound to the generic function in the - ;; method combination function, and .GF-ARGS* is bound to the + ;; method combination function, and .GF-ARGS. is bound to the ;; generic function arguments in effective method functions ;; created for generic functions having a method combination that ;; uses :ARGUMENTS. ;; ;; The DESTRUCTURING-BIND binds the parameters of the - ;; ARGUMENTS-LAMBDA-LIST to actual generic function arguments. - ;; Because ARGUMENTS-LAMBDA-LIST may be shorter or longer than the - ;; generic function's lambda list, which is only known at run time, - ;; this destructuring has to be done on a slighly modified list of + ;; ARGS-LAMBDA-LIST to actual generic function arguments. Because + ;; ARGS-LAMBDA-LIST may be shorter or longer than the generic + ;; function's lambda list, which is only known at run time, this + ;; destructuring has to be done on a slighly modified list of ;; actual arguments, from which values might be stripped or added. ;; ;; Using one of the variable names in the body inserts a symbol @@ -494,14 +473,14 @@ ;; produces the value of actual argument that is bound to the ;; symbol. `(let ((inner-result. ,wrapped-body) - (gf-lambda-list (generic-function-lambda-list .generic-function.))) - `(destructuring-bind ,',arguments-lambda-list + (gf-lambda-list (generic-function-lambda-list .generic-function.))) + `(destructuring-bind ,',args-lambda-list (frob-combined-method-args - .gf-args. ',gf-lambda-list - ,',nreq ,',nopt) - ,,(when (memq '.ignore. arguments-lambda-list) + .gf-args. ',gf-lambda-list + ,',nreq ,',nopt) + ,,(when (memq '.ignore. args-lambda-list) ''(declare (ignore .ignore.))) - ;; If there is a &WHOLE in the arguments-lambda-list, let + ;; If there is a &WHOLE in the args-lambda-list, let ;; it result in the actual arguments of the generic-function ;; not the frobbed list. ,,(when whole @@ -518,22 +497,23 @@ ;;; (defun frob-combined-method-args (values lambda-list nreq nopt) (loop with section = 'required - for arg in lambda-list - if (memq arg lambda-list-keywords) do + for arg in lambda-list + if (memq arg lambda-list-keywords) do (setq section arg) - (unless (eq section '&optional) - (loop-finish)) + (unless (eq section '&optional) + (loop-finish)) else if (eq section 'required) count t into nr - and collect (pop values) into required + and collect (pop values) into required else if (eq section '&optional) count t into no - and collect (pop values) into optional + and collect (pop values) into optional finally (flet ((frob (list n m) - (cond ((> n m) (butlast list (- n m))) - ((< n m) (nconc list (make-list (- m n)))) - (t list)))) - (return (nconc (frob required nr nreq) - (frob optional no nopt) - values))))) + (cond ((> n m) (butlast list (- n m))) + ((< n m) (nconc list (make-list (- m n)))) + (t list)))) + (return (nconc (frob required nr nreq) + (frob optional no nopt) + values))))) + diff --git a/pcl/defs.lisp b/pcl/defs.lisp index 028db2f44..6d4fa0c84 100644 --- a/pcl/defs.lisp +++ b/pcl/defs.lisp @@ -23,28 +23,29 @@ ;;; ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* -;;; (in-package :pcl) +#-(or loadable-pcl bootable-pcl) (eval-when (:compile-toplevel :load-toplevel :execute) - ;; Probably have to add 'compile' if you use defconstructor. - (defvar *defclass-times* '(load eval)) - - (defvar *defmethod-times* '(load eval)) - (defvar *defgeneric-times* '(load eval)) - (when (eq *boot-state* 'complete) - (error "Trying to load (or compile) PCL in an environment in which it~%~ - has already been loaded. This doesn't work, you will have to~%~ - get a fresh lisp (reboot) and then load PCL.")) + (error "~@<Trying to load (or compile) PCL in an environment in which it ~ + has already been loaded. This doesn't work, you will have to ~ + get a fresh lisp (reboot) and then load PCL.~@:>")) (when *boot-state* (cerror "Try loading (or compiling) PCL anyways." - "Trying to load (or compile) PCL in an environment in which it~%~ - has already been partially loaded. This may not work, you may~%~ - need to get a fresh lisp (reboot) and then load PCL."))) + "~@<Trying to load (or compile) PCL in an environment in which it ~ + has already been partially loaded. This may not work, you may ~ + need to get a fresh lisp (reboot) and then load PCL.~@:>"))) +;;; +;;; These are retained only for backward compatibility. They +;;; are no longer used, and may be deleted at some point. +;;; +(defvar *defclass-times* () "Obsolete, don't use.") +(defvar *defmethod-times* () "Obsolete, don't use.") +(defvar *defgeneric-times* () "Obsolete, don't use.") ;;; @@ -52,9 +53,18 @@ ;;; unadvised, traced etc. definition. This lets me get at the generic ;;; function object even when it is traced. ;;; +;;; Note that FDEFINITION takes care of encapsulations. PROFILE +;;; isn't using encapsulations, so it has to be treated specially. +;;; (declaim (inline gdefinition)) -(defun gdefinition (symbol) - (fdefinition symbol)) + +(defun gdefinition (name) + (let ((fdefn (fdefinition name)) + (info (gethash name profile::*profile-info*))) + (if (and info + (eq fdefn (profile::profile-info-new-definition info))) + (profile::profile-info-old-definition info) + fdefn))) ;;; ;;; If symbol names a function which is traced or advised, redefine @@ -64,6 +74,7 @@ (c::%%defun name new-definition nil) (c::note-name-defined name :function) new-definition) + (declaim (special *the-class-t* *the-class-vector* *the-class-symbol* @@ -126,13 +137,11 @@ (or (and (null args) (find-class type)) (ecase type (class (coerce-to-class (car args))) - (prototype (make-instance 'class-prototype-specializer - :object (coerce-to-class (car args)))) (class-eq (class-eq-specializer (coerce-to-class (car args)))) (eql (intern-eql-specializer (car args)))))) - ((and (null args) (typep type 'lisp:class)) - (or (kernel:class-pcl-class type) - (find-structure-class (lisp:class-name type)))) + ((and (null args) (typep type 'kernel::class)) + (or (kernel:%class-pcl-class type) + (ensure-non-standard-class (kernel:%class-name type)))) ((specializerp type) type))) ;;; interface @@ -140,8 +149,8 @@ (cond ((eq specl t) t) ((consp specl) - (unless (member (car specl) '(class prototype class-eq eql)) - (error "~S is not a legal specializer type" specl)) + (unless (member (car specl) '(class class-eq eql)) + (error "~@<~S is not a legal specializer type.~@:>" specl)) specl) ((progn (when (symbolp specl) @@ -151,7 +160,7 @@ (specializerp specl))) (specializer-type specl)) (t - (error "~s is neither a type nor a specializer" specl)))) + (error "~@<~s is neither a type nor a specializer.~@:>" specl)))) (defun type-class (type) (declare (special *the-class-t*)) @@ -159,10 +168,9 @@ (if (atom type) (if (eq type t) *the-class-t* - (error "bad argument to type-class")) + (internal-error "Bad argument to type-class.")) (case (car type) (eql (class-of (cadr type))) - (prototype (class-of (cadr type))) ;? (class-eq (cadr type)) (class (cadr type))))) @@ -182,9 +190,9 @@ ;; Earlier revisions (<= 1.17) of this function were essentially NOOPs. (declare (ignorable name)) (when (and (eq *boot-state* 'complete) - (null (lisp:find-class name nil))) - (setf (lisp:find-class name) - (lisp::make-standard-class :name name)))) + (null (kernel::find-class name nil))) + (setf (kernel::find-class name) + (kernel::make-standard-class :name name)))) ;;; Internal to this file. ;;; @@ -208,7 +216,7 @@ (specializerp type)) (specializer-type type)) (t - (error "~s is not a type" type)))) + (error "~s is not a type." type)))) ;;; internal to this file... (defun convert-to-system-type (type) @@ -259,19 +267,15 @@ (defun get-built-in-class-symbol (class-name) (or (cadr (assq class-name *built-in-class-symbols*)) - (let ((symbol (intern (format nil - "*THE-CLASS-~A*" - (symbol-name class-name)) - *the-pcl-package*))) + (let ((symbol (symbolicate *the-pcl-package* + '*the-class- class-name '*))) (push (list class-name symbol) *built-in-class-symbols*) symbol))) (defun get-built-in-wrapper-symbol (class-name) (or (cadr (assq class-name *built-in-wrapper-symbols*)) - (let ((symbol (intern (format nil - "*THE-WRAPPER-OF-~A*" - (symbol-name class-name)) - *the-pcl-package*))) + (let ((symbol (symbolicate *the-pcl-package* + '*the-wrapper-of- class-name '*))) (push (list class-name symbol) *built-in-wrapper-symbols*) symbol))) @@ -288,11 +292,7 @@ (defun make-class-predicate-name (name) - (intern (format nil "~A::~A class predicate" - (let ((pkg (symbol-package name))) - (if pkg (package-name pkg) "")) - name) - *the-pcl-package*)) + `(class-predicate ,name)) (defun plist-value (object name) (getf (object-plist object) name)) @@ -347,14 +347,14 @@ nil))) (labels ((direct-supers (class) - (if (typep class 'lisp:built-in-class) + (if (typep class 'kernel::built-in-class) (kernel:built-in-class-direct-superclasses class) (let ((inherits (kernel:layout-inherits - (kernel:class-layout class)))) + (kernel:%class-layout class)))) (list (svref inherits (1- (length inherits))))))) (direct-subs (class) (ext:collect ((res)) - (let ((subs (kernel:class-subclasses class))) + (let ((subs (kernel:%class-subclasses class))) (when subs (ext:do-hash (sub v subs) (declare (ignore v)) @@ -364,17 +364,17 @@ (ext:collect ((res)) (dolist (bic kernel::built-in-classes) (let* ((name (car bic)) - (class (lisp:find-class name))) + (class (kernel::find-class name))) (unless (member name '(t kernel:instance kernel:funcallable-instance function stream)) (res `(,name - ,(mapcar #'lisp:class-name (direct-supers class)) - ,(mapcar #'lisp:class-name (direct-subs class)) + ,(mapcar #'kernel:%class-name (direct-supers class)) + ,(mapcar #'kernel:%class-name (direct-subs class)) ,(map 'list (lambda (x) - (lisp:class-name (kernel:layout-class x))) + (kernel:%class-name (kernel:layout-class x))) (reverse (kernel:layout-inherits - (kernel:class-layout class)))) + (kernel:%class-layout class)))) ,(let ((found (assoc name *built-in-classes*))) (if found (fifth found) 42))))))) (setq *built-in-classes* (res)))) @@ -401,6 +401,20 @@ (defclass slot-object (t) () (:metaclass slot-class)) +;;; +;;; In a host Lisp with intact PCL, the DEFCLASS below would normally +;;; generate a DEFSTRUCT with :INCLUDE SLOT-OBJECT. SLOT-OBJECT is +;;; not a structure, so this would give an error. Likewise, +;;; KERNEL:INSTANCE is a BUILT-IN-CLASS, not a structure class, so +;;; this would give an error, too. +;;; +;;; When PCL is bootstrapped normally, *BOOT-STATE* is not COMPLETE at +;;; this point, which means that a DEFSTRUCT is not done, because +;;; EXPAND-DEFCLASS looks at the boot state. +;;; +;;; I've modified EXPAND-DEFCLASS accordingly to not do a DEFSTRUCT +;;; when a loadable or bootable PCL is built. +;;; (defclass structure-object (slot-object kernel:instance) () (:metaclass structure-class)) @@ -413,34 +427,35 @@ (defclass standard-object (std-object kernel:instance) ()) -(defclass funcallable-standard-object (std-object kernel:funcallable-instance) - () +(defclass funcallable-standard-object (std-object + kernel:funcallable-instance) + () (:metaclass funcallable-standard-class)) (defclass specializer (standard-object) - ((type - :initform nil - :reader specializer-type))) + ((type + :initform nil + :reader specializer-type))) (defclass definition-source-mixin (std-object) - ((source - :initform *load-pathname* - :reader definition-source - :initarg :definition-source)) + ((source + :initform *load-pathname* + :reader definition-source + :initarg :definition-source)) (:metaclass std-class)) (defclass plist-mixin (std-object) - ((plist - :initform () - :accessor object-plist)) + ((plist + :initform () + :accessor object-plist)) (:metaclass std-class)) (defclass documentation-mixin (plist-mixin) - () + () (:metaclass std-class)) (defclass dependent-update-mixin (plist-mixin) - () + () (:metaclass std-class)) ;;; @@ -448,103 +463,126 @@ ;;; of any kind of class. That is any class that can be a metaclass must ;;; have the class CLASS in its class precedence list. ;;; -(defclass class (documentation-mixin dependent-update-mixin definition-source-mixin - specializer) - ((name - :initform nil - :initarg :name - :accessor class-name) - (class-eq-specializer - :initform nil - :reader class-eq-specializer) - (direct-superclasses - :initform () - :reader class-direct-superclasses) - (direct-subclasses - :initform () - :reader class-direct-subclasses) - (direct-methods - :initform (cons nil nil)) - (predicate-name - :initform nil - :reader class-predicate-name))) +(defclass class (documentation-mixin dependent-update-mixin + definition-source-mixin + specializer) + ((name + :initform nil + :initarg :name + :accessor class-name) + (class-eq-specializer + :initform nil + :reader class-eq-specializer) + (direct-superclasses + :initform () + :reader class-direct-superclasses) + (direct-subclasses + :initform () + :reader class-direct-subclasses) + (direct-methods + :initform (cons nil nil)) + (predicate-name + :initform nil + :reader class-predicate-name))) ;;; ;;; The class PCL-CLASS is an implementation-specific common superclass of ;;; all specified subclasses of the class CLASS. ;;; (defclass pcl-class (class) - ((class-precedence-list - :reader class-precedence-list) - (can-precede-list - :initform () - :reader class-can-precede-list) - (incompatible-superclass-list - :initform () - :accessor class-incompatible-superclass-list) - (wrapper - :initform nil - :reader class-wrapper) - (prototype - :initform nil - :reader class-prototype))) + ((class-precedence-list + :reader class-precedence-list) + (can-precede-list + :initform () + :reader class-can-precede-list) + (incompatible-superclass-list + :initform () + :accessor class-incompatible-superclass-list) + (wrapper + :initform nil + :reader class-wrapper) + (prototype + :initform nil + :reader class-prototype))) (defclass slot-class (pcl-class) - ((direct-slots - :initform () - :accessor class-direct-slots) - (slots - :initform () - :accessor class-slots) - (initialize-info - :initform nil - :accessor class-initialize-info))) + ((direct-slots + :initform () + :accessor class-direct-slots) + (slots + :initform () + :accessor class-slots) + (initialize-info + :initform nil + :accessor class-initialize-info))) ;;; ;;; The class STD-CLASS is an implementation-specific common superclass of ;;; the classes STANDARD-CLASS and FUNCALLABLE-STANDARD-CLASS. ;;; -(defclass std-class (slot-class) - ()) +(defclass std-class (slot-class) ()) -(defclass standard-class (std-class) - ()) +(defclass standard-class (std-class) ()) -(defclass funcallable-standard-class (std-class) - ()) +(defclass funcallable-standard-class (std-class) ()) (defclass forward-referenced-class (pcl-class) ()) (defclass built-in-class (pcl-class) ()) (defclass structure-class (slot-class) - ((defstruct-form - :initform () - :accessor class-defstruct-form) - (defstruct-constructor - :initform nil - :accessor class-defstruct-constructor) - (from-defclass-p - :initform nil - :initarg :from-defclass-p))) + ((defstruct-form + :initform () + :accessor class-defstruct-form) + (defstruct-constructor + :initform nil + :accessor class-defstruct-constructor) + (from-defclass-p + :initform nil + :initarg :from-defclass-p))) +(defclass condition-class (pcl-class) ()) (defclass specializer-with-object (specializer) ()) (defclass exact-class-specializer (specializer) ()) -(defclass class-eq-specializer (exact-class-specializer specializer-with-object) - ((object :initarg :class :reader specializer-class :reader specializer-object))) +;;; +;;; Extension specializing on the exact specified class. You must set +;;; pcl::*allow-experimental-specializers-p* to use this extension. +;;; +;;; (defclass foo () ()) +;;; (defclass bar (foo) ()) +;;; +;;; (setq pcl::*allow-experimental-specializers-p* t) +;;; (defmethod m (x) nil) +;;; (defmethod m ((x (pcl::class-eq 'foo))) t) +;;; +;;; (m (make-instance 'foo)) => t +;;; (m (make-instance 'bar)) => nil +;;; -(defclass class-prototype-specializer (specializer-with-object) - ((object :initarg :class :reader specializer-class :reader specializer-object))) +(defclass class-eq-specializer (exact-class-specializer + specializer-with-object) + ((object + :initarg :class + :reader specializer-class + :reader specializer-object))) (defclass eql-specializer (exact-class-specializer specializer-with-object) - ((object :initarg :object :reader specializer-object - :reader eql-specializer-object))) + ((object + :initarg :object + :reader specializer-object + :reader eql-specializer-object))) (defvar *eql-specializer-table* (make-hash-table :test 'eql)) +;;; +;;; When compiled with an intact PCL, the MAKE-INSTANCE in the function +;;; below will generate an optimized constructor, and a LOAD-TIME-VALUE +;;; creating it. That means CTOR must be initialized before this file +;;; is. +;;; (defun intern-eql-specializer (object) (or (gethash object *eql-specializer-table*) (setf (gethash object *eql-specializer-table*) @@ -555,41 +593,41 @@ ;;; Slot definitions. ;;; (defclass slot-definition (standard-object) - ((name - :initform nil - :initarg :name - :accessor slot-definition-name) - (initform - :initform nil - :initarg :initform - :accessor slot-definition-initform) - (initfunction - :initform nil - :initarg :initfunction - :accessor slot-definition-initfunction) - (readers - :initform nil - :initarg :readers - :accessor slot-definition-readers) - (writers - :initform nil - :initarg :writers - :accessor slot-definition-writers) - (initargs - :initform nil - :initarg :initargs - :accessor slot-definition-initargs) - (type - :initform t - :initarg :type - :accessor slot-definition-type) - (documentation - :initform "" - :initarg :documentation) - (class - :initform nil - :initarg :class - :accessor slot-definition-class))) + ((name + :initform nil + :initarg :name + :accessor slot-definition-name) + (initform + :initform nil + :initarg :initform + :accessor slot-definition-initform) + (initfunction + :initform nil + :initarg :initfunction + :accessor slot-definition-initfunction) + (readers + :initform nil + :initarg :readers + :accessor slot-definition-readers) + (writers + :initform nil + :initarg :writers + :accessor slot-definition-writers) + (initargs + :initform nil + :initarg :initargs + :accessor slot-definition-initargs) + (type + :initform t + :initarg :type + :accessor slot-definition-type) + (documentation + :initform "" + :initarg :documentation) + (class + :initform nil + :initarg :class + :accessor slot-definition-class))) (defclass standard-slot-definition (slot-definition) ((allocation @@ -597,6 +635,9 @@ :initarg :allocation :accessor slot-definition-allocation) (allocation-class + :documentation "For class slots, the class defininig the slot. +For inherited class slots, this is the superclass from which the slot +was inherited." :initform nil :initarg :allocation-class :accessor slot-definition-allocation-class))) @@ -648,42 +689,36 @@ (defclass method (standard-object) ()) -(defclass standard-method (definition-source-mixin documentation-mixin method) - ((generic-function - :initform nil - :accessor method-generic-function) -; (qualifiers -; :initform () -; :initarg :qualifiers -; :reader method-qualifiers) - (specializers - :initform () - :initarg :specializers - :reader method-specializers) - (lambda-list - :initform () - :initarg :lambda-list - :reader method-lambda-list) - (function - :initform nil - :initarg :function) ;no writer - (fast-function - :initform nil - :initarg :fast-function ;no writer - :reader method-fast-function) -; (documentation -; :initform nil -; :initarg :documentation -; :reader method-documentation) - )) +(defclass standard-method (definition-source-mixin documentation-mixin + method) + ((generic-function + :initform nil + :accessor method-generic-function) + (specializers + :initform () + :initarg :specializers + :reader method-specializers) + (lambda-list + :initform () + :initarg :lambda-list + :reader method-lambda-list) + (function + :initform nil + :initarg :function) + (fast-function + :initform nil + :initarg :fast-function + :reader method-fast-function))) (defclass standard-accessor-method (standard-method) - ((slot-name :initform nil - :initarg :slot-name - :reader accessor-method-slot-name) - (slot-definition :initform nil - :initarg :slot-definition - :reader accessor-method-slot-definition))) + ((slot-name + :initform nil + :initarg :slot-name + :reader accessor-method-slot-name) + (slot-definition + :initform nil + :initarg :slot-definition + :reader accessor-method-slot-definition))) (defclass standard-reader-method (standard-accessor-method) ()) @@ -695,59 +730,66 @@ definition-source-mixin documentation-mixin funcallable-standard-object) - () + () (:metaclass funcallable-standard-class)) (defclass standard-generic-function (generic-function) - ((name - :initform nil - :initarg :name - :accessor generic-function-name) - (methods - :initform () - :accessor generic-function-methods) - (method-class - :initarg :method-class - :accessor generic-function-method-class) - (method-combination - :initarg :method-combination - :accessor generic-function-method-combination) - (declarations - :initarg :declarations - :initform () - :accessor generic-function-declarations) - (arg-info - :initform (make-arg-info) - :reader gf-arg-info) - (dfun-state - :initform () - :accessor gf-dfun-state) - (pretty-arglist - :initform () - :accessor gf-pretty-arglist) - ) + ((name + :initform nil + :initarg :name + :accessor generic-function-name) + (methods + :initform () + :accessor generic-function-methods) + (method-class + :initarg :method-class + :accessor generic-function-method-class) + (method-combination + :initarg :method-combination + :accessor generic-function-method-combination) + (arg-info + :initform (make-arg-info) + :reader gf-arg-info) + (dfun-state + :initform () + :accessor gf-dfun-state) + (pretty-arglist + :initform () + :accessor gf-pretty-arglist) + (declarations + :initform () + :initarg :declarations + :reader generic-function-declarations)) (:metaclass funcallable-standard-class) (:default-initargs :method-class *the-class-standard-method* - :method-combination *standard-method-combination*)) + :method-combination *standard-method-combination*)) (defclass method-combination (standard-object) ()) (defclass standard-method-combination - (definition-source-mixin method-combination) - ((type :reader method-combination-type - :initarg :type) - (documentation :reader method-combination-documentation - :initarg :documentation) - (options :reader method-combination-options - :initarg :options))) + (definition-source-mixin method-combination) + ((type + :reader method-combination-type + :initarg :type) + (documentation + :reader method-combination-documentation + :initarg :documentation) + (options + :reader method-combination-options + :initarg :options))) (defclass long-method-combination (standard-method-combination) ((function :initarg :function :reader long-method-combination-function) - (arguments-lambda-list - :initarg :arguments-lambda-list - :reader long-method-combination-arguments-lambda-list))) + (args-lambda-list + :initarg :args-lambda-list + :reader long-method-combination-args-lambda-list))) + +(defclass seal (standard-object) + ((quality + :initarg :quality + :reader seal-quality))) (defparameter *early-class-predicates* '((specializer specializerp) @@ -772,3 +814,4 @@ (method-combination method-combination-p) (long-method-combination long-method-combination-p))) + diff --git a/pcl/defsys.lisp b/pcl/defsys.lisp index bc2133d4a..0e79c07ad 100644 --- a/pcl/defsys.lisp +++ b/pcl/defsys.lisp @@ -23,10 +23,9 @@ ;;; ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* -;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/defsys.lisp,v 1.29 2003/03/04 00:46:46 pmai Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/defsys.lisp,v 1.30 2003/03/22 16:15:17 gerd Exp $") ;;; ;;; Some support stuff for compiling and loading PCL. It would be nice if ;;; there was some portable make-system we could all agree to share for a @@ -67,10 +66,10 @@ ;;; (defvar *the-pcl-package* (find-package :pcl)) -(defvar *pcl-system-date* "September 16 92 PCL (f)") +(defvar *pcl-system-date* "$Date: 2003/03/22 16:15:17 $") (setf (getf ext:*herald-items* :pcl) - `(" CLOS 18e (based on PCL " ,*pcl-system-date* ")")) + `(" CLOS based on Gerd's PCL " ,(subseq *pcl-system-date* 7 26))) ;;; Yet Another Sort Of General System Facility and friends. @@ -374,11 +373,7 @@ and load your system with: (make-pathname :defaults (make-binary-pathname name) :version :newest) - :byte-compile - (if (and (member name *byte-files*) - (member :small *features*)) - t - :maybe)))))) + :byte-compile nil))))) (with-compilation-unit () (loop (when (null transformations) (return t)) (let ((transform (pop transformations))) @@ -462,37 +457,39 @@ and load your system with: (walk (pkg) (pkg) ()) (macros t t ()) (low (pkg macros) t (macros)) + (info (pkg walk) t (macros)) (fin t t (low)) - (defclass t t (low)) + (defclass t t (low info)) (defs t t (defclass macros)) (fngen t t (low)) (cache t t (low defs)) (dlisp t t (defs low fin cache)) (dlisp2 t t (low fin cache dlisp)) (boot t t (defs fin)) - (vector t t (boot defs cache fin)) + (vector t t (boot defs cache fin)) + (method-slot-access-optimization t t (vector)) + (gf-call-optimization t t (vector)) (slots-boot t t (vector boot defs cache fin)) (combin t t (boot defs)) (dfun t t (boot low cache)) - (fast-init t t (boot low)) - (braid (+ precom1 precom2) t (boot defs low fin cache)) + (ctor t t (boot low)) + (braid (+ precom2) t (boot defs low fin cache)) (dlisp3 t t (dlisp2 boot braid)) (generic-functions t t (boot)) (slots t t (vector boot defs low cache fin)) - (init t t (vector boot defs low fast-init)) - (std-class t t (vector boot defs low cache fin slots)) + (init t t (vector boot defs low ctor)) + (seal t t (info generic-functions slots)) + (std-class t t (vector boot defs low cache fin slots seal)) (cpl t t (vector boot defs low cache fin slots)) (fsc t t (defclass boot defs low fin cache)) (methods t t (defclass boot defs low fin cache)) (fixup t t (boot defs low fin)) (defcombin t t (defclass boot defs low fin)) (ctypes t t (defclass defcombin)) - (construct t t (defclass boot defs low)) (env t t (defclass boot defs low fin)) - (cmucl-documentation t t () CMU) - (precom1 (dlisp) t (defs low cache fin dfun)) - (precom2 (dlisp) t (defs low cache fin dfun)) + (cmucl-documentation t t ()) + (precom2 (dlisp) t (defs low cache fin dfun cmucl-documentation)) )) (defsystem gray-streams @@ -541,60 +538,3 @@ and load your system with: (lisp-implementation-type) (lisp-implementation-version) *features*)) - -;;;; -;;; -;;; This stuff is not intended for external use. -;;; -(defun rename-pcl () - (dolist (f (cadr (get-system 'pcl))) - (let ((old nil) - (new nil)) - (let ((*system-directory* *default-pathname-defaults*)) - (setq old (make-source-pathname (car f)))) - (setq new (make-source-pathname (car f))) - (rename-file old new)))) - -(defun reset-pcl-package () ; Try to do this safely - (let* ((vars '(*pcl-directory* - *default-pathname-extensions* - *pathname-extensions* - *redefined-functions*)) - (names (mapcar #'symbol-name vars)) - (values (mapcar #'symbol-value vars))) - (declare (special *redefined-functions*)) - (reset-package "PCL") - (let ((pkg (find-package "SLOT-ACCESSOR-NAME"))) - (when pkg - (do-symbols (sym pkg) - (makunbound sym) - (fmakunbound sym) - (setf (symbol-plist sym) nil)))) - (let ((pcl (find-package "PCL"))) - (mapcar (lambda (name value) - (let ((var (intern name pcl))) - (proclaim `(special ,var)) - (set var value))) - names values)) - (dolist (sym *redefined-functions*) - (setf (symbol-function sym) (get sym :definition-before-pcl))) - nil)) - -(defun reset-package (&optional (package-name "PCL")) - (let ((pkg (find-package package-name))) - (do-symbols (sym pkg) - (when (eq pkg (symbol-package sym)) - (if (or (constantp sym) - (or (c::info setf inverse sym) - (c::info setf expander sym) - (c::info type kind sym) - (c::info function macro-function sym) - (c::info function compiler-macro-function sym))) - (unintern sym pkg) - (progn - (makunbound sym) - (unless (or (eq sym 'reset-pcl-package) - (eq sym 'reset-package)) - (fmakunbound sym) - (fmakunbound `(setf ,sym))) - (setf (symbol-plist sym) nil))))))) diff --git a/pcl/dfun.lisp b/pcl/dfun.lisp index f076ee89e..923fb4533 100644 --- a/pcl/dfun.lisp +++ b/pcl/dfun.lisp @@ -23,11 +23,9 @@ ;;; ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* -;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/dfun.lisp,v 1.17 2002/12/18 00:57:04 pmai Exp $") -;;; + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/dfun.lisp,v 1.18 2003/03/22 16:15:17 gerd Exp $") (in-package :pcl) @@ -87,54 +85,48 @@ And so, we are saved. |# -;An alist in which each entry is of the form : -; (<generator> . (<subentry> ...)) -;Each subentry is of the form: -; (<args> <constructor> <system>) +;;; +;;; An alist in which each entry is of the form (<generator> +;;; . (<subentry> ...)) Each subentry is of the form: (<args> +;;; <constructor> <system>) +;;; (defvar *dfun-constructors* ()) -;If this is NIL, then the whole mechanism -;for caching dfun constructors is turned -;off. The only time that makes sense is -;when debugging LAP code. -(defvar *enable-dfun-constructor-caching* t) - -(defun show-dfun-constructors () - (format t "~&DFUN constructor caching is ~A." - (if *enable-dfun-constructor-caching* - "enabled" "disabled")) - (dolist (generator-entry *dfun-constructors*) - (dolist (args-entry (cdr generator-entry)) - (format t "~&~S ~S" - (cons (car generator-entry) (caar args-entry)) - (caddr args-entry))))) - -(defvar *raise-metatypes-to-class-p* t) +;;; +;;; If this is NIL, then the whole mechanism for caching dfun +;;; constructors is turned off. The only time that makes sense is +;;; when debugging LAP code. +;;; +(defvar *enable-dfun-constructor-caching* t) (defun get-dfun-constructor (generator &rest args) - (when (and *raise-metatypes-to-class-p* - (member generator '(emit-checking emit-caching - emit-in-checking-cache-p emit-constant-value))) - (setq args (cons (mapcar (lambda (mt) - (if (eq mt t) - mt - 'class)) - (car args)) - (cdr args)))) + (when (member generator '(emit-checking emit-caching + emit-in-checking-cache-p + emit-constant-value)) + (loop for type in (car args) + if (eq type t) + collect type into types + else + collect 'class into types + finally + (setf (car args) types))) (let* ((generator-entry (assq generator *dfun-constructors*)) (args-entry (assoc args (cdr generator-entry) :test #'equal))) - (if (null *enable-dfun-constructor-caching*) - (apply (symbol-function generator) args) - (or (cadr args-entry) - (multiple-value-bind (new not-best-p) - (apply (symbol-function generator) args) - (let ((entry (list (copy-list args) new (unless not-best-p 'pcl) + (cond ((null *enable-dfun-constructor-caching*) + (apply (symbol-function generator) args)) + ((cadr args-entry) + (cadr args-entry)) + (t + (multiple-value-bind (new not-best-p) + (apply (symbol-function generator) args) + (let ((entry (list (copy-list args) + new + (unless not-best-p 'pcl) not-best-p))) - (if generator-entry - (push entry (cdr generator-entry)) - (push (list generator entry) - *dfun-constructors*))) - (values new not-best-p)))))) + (if generator-entry + (push entry (cdr generator-entry)) + (push (list generator entry) *dfun-constructors*))) + (values new not-best-p)))))) (defun load-precompiled-dfun-constructor (generator args system constructor) (let* ((generator-entry (assq generator *dfun-constructors*)) @@ -142,21 +134,23 @@ And so, we are saved. (if args-entry (when (fourth args-entry) (let* ((dfun-type (case generator - (emit-checking 'checking) - (emit-caching 'caching) + (emit-checking 'checking) + (emit-caching 'caching) (emit-constant-value 'constant-value) - (emit-default-only 'default-method-only))) + (emit-default-only 'default-method-only))) (metatypes (car args)) (gfs (when dfun-type (gfs-of-type dfun-type)))) (dolist (gf gfs) - (when (and (equal metatypes (arg-info-metatypes (gf-arg-info gf))) + (when (and (equal metatypes + (arg-info-metatypes (gf-arg-info gf))) (let ((gf-name (generic-function-name gf))) (and (not (eq gf-name 'slot-value-using-class)) - (not (equal gf-name '(setf slot-value-using-class))) + (not (equal gf-name + '(setf slot-value-using-class))) (not (eq gf-name 'slot-boundp-using-class))))) (update-dfun gf))) (setf (second args-entry) constructor) - (setf (third args-entry) system) + (setf (third args-entry) system) (setf (fourth args-entry) nil))) (let ((entry (list args constructor system nil))) (if generator-entry @@ -177,7 +171,7 @@ And so, we are saved. (push (make-top-level-form `(precompile-dfun-constructor ,(car generator-entry)) - '(load) + '(:load-toplevel) `(load-precompiled-dfun-constructor ',(car generator-entry) ',(car args-entry) @@ -233,23 +227,23 @@ And so, we are saved. (format stream "~A" (type-of dfun-info)))) (defstruct (no-methods - (:constructor no-methods-dfun-info ()) + (:constructor make-no-methods-dfun-info ()) (:include dfun-info))) (defstruct (initial - (:constructor initial-dfun-info ()) + (:constructor make-initial-dfun-info ()) (:include dfun-info))) (defstruct (initial-dispatch - (:constructor initial-dispatch-dfun-info ()) + (:constructor make-initial-dispatch-dfun-info ()) (:include dfun-info))) (defstruct (dispatch - (:constructor dispatch-dfun-info ()) + (:constructor make-dispatch-dfun-info ()) (:include dfun-info))) (defstruct (default-method-only - (:constructor default-method-only-dfun-info ()) + (:constructor make-default-method-only-dfun-info ()) (:include dfun-info))) ;without caching: @@ -260,61 +254,54 @@ And so, we are saved. ;accessor: ; one-class two-class one-index n-n + (defstruct (accessor-dfun-info (:constructor nil) + (:conc-name dfun-info-) (:include dfun-info)) accessor-type) ; (member reader writer) -(defmacro dfun-info-accessor-type (di) - `(accessor-dfun-info-accessor-type ,di)) - (defstruct (one-index-dfun-info (:constructor nil) + (:conc-name dfun-info-) (:include accessor-dfun-info)) index) -(defmacro dfun-info-index (di) - `(one-index-dfun-info-index ,di)) - (defstruct (n-n - (:constructor n-n-dfun-info (accessor-type cache)) + (:constructor make-n-n-dfun-info (accessor-type cache)) (:include accessor-dfun-info))) (defstruct (one-class - (:constructor one-class-dfun-info (accessor-type index wrapper0)) + (:constructor make-one-class-dfun-info + (accessor-type index wrapper0)) + (:conc-name dfun-info-) (:include one-index-dfun-info)) wrapper0) -(defmacro dfun-info-wrapper0 (di) - `(one-class-wrapper0 ,di)) - (defstruct (two-class - (:constructor two-class-dfun-info (accessor-type index wrapper0 wrapper1)) + (:constructor make-two-class-dfun-info + (accessor-type index wrapper0 wrapper1)) + (:conc-name dfun-info-) (:include one-class)) wrapper1) -(defmacro dfun-info-wrapper1 (di) - `(two-class-wrapper1 ,di)) - (defstruct (one-index - (:constructor one-index-dfun-info + (:constructor make-one-index-dfun-info (accessor-type index cache)) (:include one-index-dfun-info))) (defstruct (checking - (:constructor checking-dfun-info (function cache)) + (:constructor make-checking-dfun-info (function cache)) + (:conc-name dfun-info-) (:include dfun-info)) function) -(defmacro dfun-info-function (di) - `(checking-function ,di)) - (defstruct (caching - (:constructor caching-dfun-info (cache)) + (:constructor make-caching-dfun-info (cache)) (:include dfun-info))) (defstruct (constant-value - (:constructor constant-value-dfun-info (cache)) + (:constructor make-constant-value-dfun-info (cache)) (:include dfun-info))) (defmacro dfun-update (generic-function function &rest args) @@ -324,13 +311,11 @@ And so, we are saved. (defun accessor-miss-function (gf dfun-info) (ecase (dfun-info-accessor-type dfun-info) - (reader + ((reader boundp) (lambda (arg) - (declare (pcl-fast-call)) (accessor-miss gf nil arg dfun-info))) (writer (lambda (new arg) - (declare (pcl-fast-call)) (accessor-miss gf new arg dfun-info))))) (declaim (ext:freeze-type dfun-info)) @@ -340,8 +325,11 @@ And so, we are saved. ;;; ONE-CLASS-ACCESSOR ;;; (defun make-one-class-accessor-dfun (gf type wrapper index) - (let ((emit (if (eq type 'reader) 'emit-one-class-reader 'emit-one-class-writer)) - (dfun-info (one-class-dfun-info type index wrapper))) + (let ((emit (ecase type + (reader 'emit-one-class-reader) + (boundp 'emit-one-class-boundp) + (writer 'emit-one-class-writer))) + (dfun-info (make-one-class-dfun-info type index wrapper))) (values (funcall (get-dfun-constructor emit (consp index)) wrapper index @@ -353,8 +341,11 @@ And so, we are saved. ;;; TWO-CLASS-ACCESSOR ;;; (defun make-two-class-accessor-dfun (gf type w0 w1 index) - (let ((emit (if (eq type 'reader) 'emit-two-class-reader 'emit-two-class-writer)) - (dfun-info (two-class-dfun-info type index w0 w1))) + (let ((emit (ecase type + (reader 'emit-two-class-reader) + (boundp 'emit-two-class-boundp) + (writer 'emit-two-class-writer))) + (dfun-info (make-two-class-dfun-info type index w0 w1))) (values (funcall (get-dfun-constructor emit (consp index)) w0 w1 index @@ -366,9 +357,12 @@ And so, we are saved. ;;; std accessors same index dfun ;;; (defun make-one-index-accessor-dfun (gf type index &optional cache) - (let* ((emit (if (eq type 'reader) 'emit-one-index-readers 'emit-one-index-writers)) - (cache (or cache (get-cache 1 nil #'one-index-limit-fn 4))) - (dfun-info (one-index-dfun-info type index cache))) + (let* ((emit (ecase type + (reader 'emit-one-index-readers) + (boundp 'emit-one-index-boundps) + (writer 'emit-one-index-writers))) + (cache (or cache (get-cache 1 nil 4))) + (dfun-info (make-one-index-dfun-info type index cache))) (declare (type cache cache)) (values (funcall (get-dfun-constructor emit (consp index)) @@ -379,17 +373,16 @@ And so, we are saved. dfun-info))) (defun make-final-one-index-accessor-dfun (gf type index table) - (let ((cache (fill-dfun-cache table nil 1 #'one-index-limit-fn))) + (let ((cache (fill-dfun-cache table nil 1))) (make-one-index-accessor-dfun gf type index cache))) -(defun one-index-limit-fn (nlines) - (default-limit-fn nlines)) - - (defun make-n-n-accessor-dfun (gf type &optional cache) - (let* ((emit (if (eq type 'reader) 'emit-n-n-readers 'emit-n-n-writers)) - (cache (or cache (get-cache 1 t #'n-n-accessors-limit-fn 2))) - (dfun-info (n-n-dfun-info type cache))) + (let* ((emit (ecase type + (reader 'emit-n-n-readers) + (boundp 'emit-n-n-boundps) + (writer 'emit-n-n-writers))) + (cache (or cache (get-cache 1 t 2))) + (dfun-info (make-n-n-dfun-info type cache))) (declare (type cache cache)) (values (funcall (get-dfun-constructor emit) @@ -399,12 +392,9 @@ And so, we are saved. dfun-info))) (defun make-final-n-n-accessor-dfun (gf type table) - (let ((cache (fill-dfun-cache table t 1 #'n-n-accessors-limit-fn))) + (let ((cache (fill-dfun-cache table t 1))) (make-n-n-accessor-dfun gf type cache))) -(defun n-n-accessors-limit-fn (nlines) - (default-limit-fn nlines)) - (defun make-checking-dfun (generic-function function &optional cache) (unless cache (when (use-caching-dfun-p generic-function) @@ -415,20 +405,19 @@ And so, we are saved. (get-generic-function-info generic-function) (declare (ignore nreq)) (if (every (lambda (mt) (eq mt t)) metatypes) - (let ((dfun-info (default-method-only-dfun-info))) + (let ((dfun-info (make-default-method-only-dfun-info))) (values (funcall (get-dfun-constructor 'emit-default-only metatypes applyp) function) nil dfun-info)) - (let* ((cache (or cache (get-cache nkeys nil #'checking-limit-fn 2))) - (dfun-info (checking-dfun-info function cache))) + (let* ((cache (or cache (get-cache nkeys nil 2))) + (dfun-info (make-checking-dfun-info function cache))) (values (funcall (get-dfun-constructor 'emit-checking metatypes applyp) cache function (lambda (&rest args) - (declare (pcl-fast-call)) (checking-miss generic-function args dfun-info))) cache dfun-info))))) @@ -439,18 +428,13 @@ And so, we are saved. (if (every (lambda (mt) (eq mt t)) metatypes) (values (lambda (&rest args) (invoke-emf function args)) - nil (default-method-only-dfun-info)) + nil + (make-default-method-only-dfun-info)) (let ((cache (make-final-ordinary-dfun-internal - generic-function nil #'checking-limit-fn + generic-function nil classes-list new-class))) (make-checking-dfun generic-function function cache))))) -(defun use-default-method-only-dfun-p (generic-function) - (multiple-value-bind (nreq applyp metatypes nkeys) - (get-generic-function-info generic-function) - (declare (ignore nreq applyp nkeys)) - (every (lambda (mt) (eq mt t)) metatypes))) - (defun use-caching-dfun-p (generic-function) (some (lambda (method) (let ((fmf (if (listp method) @@ -461,9 +445,6 @@ And so, we are saved. (early-gf-methods generic-function) (generic-function-methods generic-function)))) -(defun checking-limit-fn (nlines) - (default-limit-fn nlines)) - ;;; ;;; @@ -477,26 +458,21 @@ And so, we are saved. (multiple-value-bind (nreq applyp metatypes nkeys) (get-generic-function-info generic-function) (declare (ignore nreq)) - (let* ((cache (or cache (get-cache nkeys t #'caching-limit-fn 2))) - (dfun-info (caching-dfun-info cache))) + (let* ((cache (or cache (get-cache nkeys t 2))) + (dfun-info (make-caching-dfun-info cache))) (values (funcall (get-dfun-constructor 'emit-caching metatypes applyp) cache (lambda (&rest args) - (declare (pcl-fast-call)) (caching-miss generic-function args dfun-info))) cache dfun-info)))) (defun make-final-caching-dfun (generic-function classes-list new-class) (let ((cache (make-final-ordinary-dfun-internal - generic-function t #'caching-limit-fn - classes-list new-class))) + generic-function t classes-list new-class))) (make-caching-dfun generic-function cache))) -(defun caching-limit-fn (nlines) - (default-limit-fn nlines)) - (defun insure-caching-dfun (gf) (multiple-value-bind (nreq applyp metatypes nkeys) (get-generic-function-info gf) @@ -538,20 +514,19 @@ And so, we are saved. (multiple-value-bind (nreq applyp metatypes nkeys) (get-generic-function-info generic-function) (declare (ignore nreq applyp)) - (let* ((cache (or cache (get-cache nkeys t #'caching-limit-fn 2))) - (dfun-info (constant-value-dfun-info cache))) + (let* ((cache (or cache (get-cache nkeys t 2))) + (dfun-info (make-constant-value-dfun-info cache))) (values (funcall (get-dfun-constructor 'emit-constant-value metatypes) cache (lambda (&rest args) - (declare (pcl-fast-call)) (constant-value-miss generic-function args dfun-info))) cache dfun-info)))) (defun make-final-constant-value-dfun (generic-function classes-list new-class) (let ((cache (make-final-ordinary-dfun-internal - generic-function :constant-value #'caching-limit-fn + generic-function :constant-value classes-list new-class))) (make-constant-value-dfun generic-function cache))) @@ -576,7 +551,7 @@ And so, we are saved. ;; Look at pcl/generic-functions.lisp for other potential test cases. (defun show-dfun-costs (gf) (when (or (symbolp gf) (consp gf)) - (setq gf (fdefinition gf))) + (setq gf (gdefinition gf))) (format t "~&Name ~S caching cost ~D dispatch cost ~D~%" (generic-function-name gf) (caching-dfun-cost gf) @@ -586,31 +561,6 @@ And so, we are saved. (defparameter *structure-typep-cost* 1) (defparameter *built-in-typep-cost* 0) -;; The execution time of this is exponential to some function -;; of number of gf methods and argument lists. It was taking -;; literally hours to load the presentation methods from the -;; cl-http w3p kit. -#+nil -(defun dispatch-dfun-cost (gf) - (generate-discrimination-net-internal - gf (generic-function-methods gf) nil - (lambda (methods known-types) - (declare (ignore methods known-types)) - 0) - (lambda (position type true-value false-value) - (declare (ignore position)) - (+ (max true-value false-value) - (if (eq 'class (car type)) - (let ((cpl (class-precedence-list (class-of (cadr type))))) - (cond((memq *the-class-built-in-class* cpl) - *built-in-typep-cost*) - ((memq *the-class-structure-class* cpl) - *structure-typep-cost*) - (t - *non-built-in-typep-cost*))) - 0))) - #'identity)) - ;; This version is from the pcl found in the gcl-2.1 distribution. ;; Someone added a cost limit so as to keep the execution time controlled (defun dispatch-dfun-cost (gf &optional limit) @@ -664,13 +614,13 @@ And so, we are saved. (defun make-dispatch-dfun (gf) - (values (get-dispatch-function gf) nil (dispatch-dfun-info))) + (values (get-dispatch-function gf) nil (make-dispatch-dfun-info))) (defun get-dispatch-function (gf) - (let ((methods (generic-function-methods gf))) - (function-funcall (get-secondary-dispatch-function1 gf methods nil nil nil - nil nil t) - nil nil))) + (let* ((methods (generic-function-methods gf)) + (generator (get-secondary-dispatch-function1 + gf methods nil nil nil nil nil t))) + (make-callable gf methods generator nil nil))) (defun make-final-dispatch-dfun (gf) (make-dispatch-dfun gf)) @@ -679,8 +629,8 @@ And so, we are saved. (dolist (gf (gfs-of-type '(dispatch initial-dispatch))) (dfun-update gf #'make-dispatch-dfun))) -(defun fill-dfun-cache (table valuep nkeys limit-fn &optional cache) - (let ((cache (or cache (get-cache nkeys valuep limit-fn +(defun fill-dfun-cache (table valuep nkeys &optional cache) + (let ((cache (or cache (get-cache nkeys valuep (+ (hash-table-count table) 3))))) (maphash (lambda (classes value) (setq cache (fill-cache cache @@ -689,19 +639,22 @@ And so, we are saved. table) cache)) -(defun make-final-ordinary-dfun-internal (generic-function valuep limit-fn - classes-list new-class) +(defun make-final-ordinary-dfun-internal (generic-function valuep + classes-list new-class) (let* ((arg-info (gf-arg-info generic-function)) (nkeys (arg-info-nkeys arg-info)) (new-class (and new-class (equal (type-of (gf-dfun-info generic-function)) - (cond ((eq valuep t) 'caching) - ((eq valuep :constant-value) 'constant-value) - ((null valuep) 'checking))) + (cond ((eq valuep t) + 'caching) + ((eq valuep :constant-value) + 'constant-value) + ((null valuep) + 'checking))) new-class)) (cache (if new-class (copy-cache (gf-dfun-cache generic-function)) - (get-cache nkeys (not (null valuep)) limit-fn 4)))) + (get-cache nkeys (not (null valuep)) 4)))) (make-emf-cache generic-function valuep cache classes-list new-class))) (defvar *dfun-miss-gfs-on-stack* ()) @@ -709,7 +662,8 @@ And so, we are saved. (defmacro dfun-miss ((gf args wrappers invalidp nemf &optional type index caching-p applicable) &body body) - (unless applicable (setq applicable (gensym))) + (unless applicable + (setq applicable (gensym))) `(multiple-value-bind (,nemf ,applicable ,wrappers ,invalidp ,@(when type `(,type ,index))) (cache-miss-values ,gf ,args ',(cond (caching-p 'caching) @@ -718,7 +672,15 @@ And so, we are saved. (when (and ,applicable (not (memq ,gf *dfun-miss-gfs-on-stack*))) (let ((*dfun-miss-gfs-on-stack* (cons ,gf *dfun-miss-gfs-on-stack*))) ,@body)) - (invoke-emf ,nemf ,args))) + ;; + ;; Create a FAST-INSTANCE-BOUNDP structure instance for a cached + ;; SLOT-BOUNDP so that INVOKE-EMF does the right thing, that is, + ;; does not signal a SLOT-UNBOUND error for a boundp test. + ,@(if type + `((if (and (eq ,type 'boundp) (integerp ,nemf)) + (invoke-emf (make-fast-instance-boundp :index ,nemf) ,args) + (invoke-emf ,nemf ,args))) + `((invoke-emf ,nemf ,args))))) ;;; ;;; The dynamically adaptive method lookup algorithm is implemented is @@ -733,39 +695,74 @@ And so, we are saved. ;;; simply select a new cache or cache field. Those are not considered ;;; as state transitions. ;;; -(defvar *lazy-dfun-compute-p* t) (defvar *early-p* nil) +;;; +;;; Try to finalize all unfinalized class specializers of all methods +;;; of generic function GF. Value is true if successful. +;;; +(defun finalize-specializers (gf) + (let ((all-finalized t)) + (dolist (method (generic-function-methods gf)) + (dolist (specializer (method-specializers method)) + (when (and (classp specializer) + (not (class-finalized-p specializer))) + (if (class-has-a-forward-referenced-superclass-p specializer) + (setq all-finalized nil) + (finalize-inheritance specializer))))) + all-finalized)) + (defun make-initial-dfun (gf) (let ((initial-dfun #'(kernel:instance-lambda (&rest args) (initial-dfun gf args)))) (multiple-value-bind (dfun cache info) - (if (and (eq *boot-state* 'complete) - (compute-applicable-methods-emf-std-p gf)) - (let* ((caching-p (use-caching-dfun-p gf)) - (classes-list (precompute-effective-methods - gf caching-p - (not *lazy-dfun-compute-p*)))) - (if *lazy-dfun-compute-p* - (cond ((use-dispatch-dfun-p gf caching-p) - (values initial-dfun nil (initial-dispatch-dfun-info))) - (caching-p - (insure-caching-dfun gf) - (values initial-dfun nil (initial-dfun-info))) - (t - (values initial-dfun nil (initial-dfun-info)))) - (make-final-dfun-internal gf classes-list))) - (let ((arg-info (if (early-gf-p gf) - (early-gf-arg-info gf) - (gf-arg-info gf))) - (type nil)) - (if (and (gf-precompute-dfun-and-emf-p arg-info) - (setq type (final-accessor-dfun-type gf))) - (if *early-p* - (values (make-early-accessor gf type) nil nil) - (make-final-accessor-dfun gf type)) - (values initial-dfun nil (initial-dfun-info))))) + (cond ((and (eq *boot-state* 'complete) + (not (finalize-specializers gf))) + (values initial-dfun nil (make-initial-dfun-info))) + + ((and (eq *boot-state* 'complete) + (compute-applicable-methods-emf-std-p gf)) + (let* ((caching-p (use-caching-dfun-p gf)) + ;; + ;; FIXME: I believe the call to P-E-M below is a + ;; relict of the unused, and meanwhile removed, + ;; *LAZY-DFUN-COMPUTE-P* code in the original PCL. + ;; The call also caused problems before the + ;; introduction of FINALIZE-SPECIALIZERS. Example: + ;; + ;; (defclass foo () ()) + ;; (defclass bar (forward) ()) + ;; (defmethod baz ((x bar)) x) + ;; (defmethod baz ((x foo)) x) + ;; + ;; This signaled an error because of the unfinalized + ;; class BAR, which P-E-M trampled on. + ;; + ;; When removing the call doesn't cause unforeseen + ;; problems, remove the P-E-M function. + ;; + ;; Gerd, 2003-03-18 + #+nil + (classes-list (precompute-effective-methods gf caching-p))) + (cond ((use-dispatch-dfun-p gf caching-p) + (values initial-dfun nil (make-initial-dispatch-dfun-info))) + (caching-p + (insure-caching-dfun gf) + (values initial-dfun nil (make-initial-dfun-info))) + (t + (values initial-dfun nil (make-initial-dfun-info)))))) + (t + (let ((arg-info (if (early-gf-p gf) + (early-gf-arg-info gf) + (gf-arg-info gf))) + (type nil)) + (if (and (gf-precompute-dfun-and-emf-p arg-info) + (setq type (final-accessor-dfun-type gf))) + (if *early-p* + (values (make-early-accessor gf type) nil nil) + (make-final-accessor-dfun gf type)) + (values initial-dfun nil (make-initial-dfun-info)))))) (set-dfun gf dfun cache info)))) (defun make-early-accessor (gf type) @@ -776,6 +773,12 @@ And so, we are saved. (let* ((class (class-of instance)) (class-name (bootstrap-get-slot 'class class 'name))) (bootstrap-get-slot class-name instance slot-name)))) + (boundp #'(kernel:instance-lambda (instance) + (let* ((class (class-of instance)) + (class-name (bootstrap-get-slot 'class class 'name))) + (not (eq +slot-unbound+ + (bootstrap-get-slot class-name instance + slot-name)))))) (writer #'(kernel:instance-lambda (new-value instance) (let* ((class (class-of instance)) (class-name (bootstrap-get-slot 'class class 'name))) @@ -785,21 +788,41 @@ And so, we are saved. (dfun-miss (gf args wrappers invalidp nemf ntype nindex) (cond (invalidp) ((and ntype nindex) - (dfun-update - gf #'make-one-class-accessor-dfun ntype wrappers nindex)) + (dfun-update gf #'make-one-class-accessor-dfun + ntype wrappers nindex)) ((use-caching-dfun-p gf) (dfun-update gf #'make-caching-dfun)) (t - (dfun-update - gf #'make-checking-dfun - ;; nemf is suitable only for caching, have to do this: - (cache-miss-values gf args 'checking)))))) + (dfun-update gf #'make-checking-dfun + (cache-miss-values gf args 'checking)))))) (defun make-final-dfun (gf &optional classes-list) (multiple-value-bind (dfun cache info) (make-final-dfun-internal gf classes-list) (set-dfun gf dfun cache info))) +(defun update-dfun (generic-function &optional dfun cache info) + (let* ((early-p (early-gf-p generic-function)) + (gf-name (if early-p + (early-gf-name generic-function) + (generic-function-name generic-function)))) + (set-dfun generic-function dfun cache info) + (let ((dfun (if early-p + (or dfun (make-initial-dfun generic-function)) + (compute-discriminating-function generic-function)))) + (set-funcallable-instance-function generic-function dfun) + (set-function-name generic-function gf-name) + (update-pv-calls-for-gf generic-function) + dfun))) + +(defun gfs-of-type (type) + (unless (consp type) (setq type (list type))) + (let ((gf-list nil)) + (map-all-generic-functions (lambda (gf) + (when (memq (type-of (gf-dfun-info gf)) type) + (push gf gf-list)))) + gf-list)) + (defvar *new-class* nil) (defvar *free-hash-tables* (mapcar #'list '(eq equal eql))) @@ -828,6 +851,13 @@ And so, we are saved. (standard-reader-method-p method))) methods) 'reader) + ((every (lambda (method) + (if (consp method) + (eq *the-class-standard-boundp-method* + (early-method-class method)) + (standard-boundp-method-p method))) + methods) + 'boundp) ((every (lambda (method) (if (consp method) (eq *the-class-standard-writer-method* @@ -866,7 +896,7 @@ And so, we are saved. #'(kernel:instance-lambda (&rest args) (apply #'no-applicable-method gf args)) nil - (no-methods-dfun-info))) + (make-no-methods-dfun-info))) ((setq type (final-accessor-dfun-type gf)) (make-final-accessor-dfun gf type classes-list new-class)) ((and (not (and (every (lambda (specl) (eq specl *the-class-t*)) @@ -890,9 +920,9 @@ And so, we are saved. (let* ((ostate (type-of dfun-info)) (otype (dfun-info-accessor-type dfun-info)) oindex ow0 ow1 cache - (args (ecase otype ;The congruence rules assure - (reader (list object)) ;us that this is safe despite - (writer (list new object))))) ;not knowing the new type yet. + (args (ecase otype + ((reader boundp) (list object)) + (writer (list new object))))) (dfun-miss (gf args wrappers invalidp nemf ntype nindex) ;; ;; The following lexical functions change the state of the @@ -902,9 +932,11 @@ And so, we are saved. ;; (flet ((two-class (index w0 w1) (when (zerop (random 2)) (psetf w0 w1 w1 w0)) - (dfun-update gf #'make-two-class-accessor-dfun ntype w0 w1 index)) + (dfun-update gf #'make-two-class-accessor-dfun + ntype w0 w1 index)) (one-index (index &optional cache) - (dfun-update gf #'make-one-index-accessor-dfun ntype index cache)) + (dfun-update gf #'make-one-index-accessor-dfun + ntype index cache)) (n-n (&optional cache) (if (consp nindex) (dfun-update gf #'make-checking-dfun nemf) @@ -1022,13 +1054,15 @@ And so, we are saved. ;;; an :instance slot, this is the index number of that slot ;;; in the object argument. ;;; +;;; Only used in this file. +;;; (defun cache-miss-values (gf args state) (multiple-value-bind (nreq applyp metatypes nkeys arg-info) (get-generic-function-info gf) (declare (ignore nreq applyp nkeys)) (with-dfun-wrappers (args metatypes) (dfun-wrappers invalid-wrapper-p wrappers classes types) - (error "The function ~S requires at least ~D arguments" + (error "~@<The function ~S requires at least ~D arguments.~@:>" gf (length metatypes)) (multiple-value-bind (emf methods accessor-type index) (cache-miss-values-internal gf arg-info wrappers classes types state) @@ -1037,6 +1071,9 @@ And so, we are saved. invalid-wrapper-p accessor-type index))))) +;;; +;;; Called from vector.lisp +;;; (defun cache-miss-values-internal (gf arg-info wrappers classes types state) (let* ((for-accessor-p (eq state 'accessor)) (for-cache-p (or (eq state 'caching) (eq state 'accessor))) @@ -1047,38 +1084,77 @@ And so, we are saved. (compute-applicable-methods-using-types gf types) (compute-applicable-methods-using-classes gf classes)) (let ((emf (if (or cam-std-p all-applicable-and-sorted-p) - (function-funcall (get-secondary-dispatch-function1 - gf methods types nil (and for-cache-p wrappers) - all-applicable-and-sorted-p) - nil (and for-cache-p wrappers)) - (default-secondary-dispatch-function gf)))) + (let ((generator (get-secondary-dispatch-function1 + gf methods types nil + (and for-cache-p wrappers) + all-applicable-and-sorted-p))) + (make-callable gf methods generator nil + (and for-cache-p wrappers))) + (let ((fn (default-secondary-dispatch-function gf))) + (set-emf-name gf methods fn))))) (multiple-value-bind (index accessor-type) (and for-accessor-p all-applicable-and-sorted-p methods (accessor-values gf arg-info classes methods)) (values (if (integerp index) index emf) methods accessor-type index)))))) +;;; +;;; Only used in this file. +;;; (defun accessor-values (gf arg-info classes methods) (declare (ignore gf)) (let* ((accessor-type (gf-info-simple-accessor-type arg-info)) (accessor-class (case accessor-type - (reader (car classes)) - (writer (cadr classes)) - (boundp (car classes))))) + ((reader boundp) (car classes)) + (writer (cadr classes))))) (accessor-values-internal accessor-type accessor-class methods))) +;;; +;;; Called from vector.lisp +;;; (defun accessor-values1 (gf accessor-type accessor-class) (let* ((type `(class-eq ,accessor-class)) - (types (if (eq accessor-type 'writer) `(t ,type) `(,type))) + (types (ecase accessor-type + (writer `(t ,type)) + ((reader boundp) `(,type)))) (methods (compute-applicable-methods-using-types gf types))) (accessor-values-internal accessor-type accessor-class methods))) +;;; +;;; Only used in this file. +;;; +(declaim (inline cpl-maybe-early slot-location-maybe-early)) + +(defun cpl-maybe-early (class) + (if (eq *boot-state* 'complete) + (class-precedence-list class) + (early-class-precedence-list class))) + +;;; +;;; Return the class precedence list of CLASS or null if we can't +;;; tell, which is the case when the class isn't finalized yet. +;;; +(defun cpl-or-nil (class) + (if (eq *boot-state* 'complete) + (when (class-finalized-p class) + (class-precedence-list class)) + (early-class-precedence-list class))) + +(defun slot-location-maybe-early (slotd) + (if (eq *boot-state* 'complete) + (slot-definition-location slotd) + (early-slot-definition-location slotd))) + +;;; +;;; Only used in this file. +;;; (defun accessor-values-internal (accessor-type accessor-class methods) - (dolist (meth methods) - (when (if (consp meth) - (early-method-qualifiers meth) - (method-qualifiers meth)) - (return-from accessor-values-internal (values nil nil)))) + (when (some (lambda (method) + (if (consp method) + (early-method-qualifiers method) + (method-qualifiers method))) + methods) + (return-from accessor-values-internal (values nil nil))) (let* ((meth (car methods)) (early-p (not (eq *boot-state* 'complete))) (slot-name (when accessor-class @@ -1086,9 +1162,7 @@ And so, we are saved. (and (early-method-standard-accessor-p meth) (early-method-standard-accessor-slot-name meth)) (and (member *the-class-std-object* - (if early-p - (early-class-precedence-list accessor-class) - (class-precedence-list accessor-class))) + (cpl-maybe-early accessor-class)) (if early-p (not (eq *the-class-standard-method* (early-method-class meth))) @@ -1105,14 +1179,15 @@ And so, we are saved. (when (and slotd (or early-p (slot-accessor-std-p slotd accessor-type))) - (values (if early-p - (early-slot-definition-location slotd) - (slot-definition-location slotd)) + (values (slot-location-maybe-early slotd) accessor-type)))) -(defun make-accessor-table (gf type &optional table) - (unless table (setq table (make-hash-table :test 'eq))) - (let ((methods (if (early-gf-p gf) +;;; +;;; Only used in this file. +;;; +(defun make-accessor-table (gf type table) + (let ((table (or table (make-hash-table :test 'eq))) + (methods (if (early-gf-p gf) (early-gf-methods gf) (generic-function-methods gf))) (all-index nil) @@ -1120,72 +1195,83 @@ And so, we are saved. (early-p (not (eq *boot-state* 'complete))) first second (size 0)) (declare (fixnum size)) - ;; class -> {(specl slotd)} - (dolist (method methods) - (let* ((specializers (if (consp method) - (early-method-specializers method t) - (method-specializers method))) - (specl (if (eq type 'reader) - (car specializers) - (cadr specializers))) - (specl-cpl (if early-p - (early-class-precedence-list specl) - (and (class-finalized-p specl) - (class-precedence-list specl)))) - (so-p (member *the-class-std-object* specl-cpl)) - (slot-name (if (consp method) - (and (early-method-standard-accessor-p method) - (early-method-standard-accessor-slot-name method)) - (accessor-method-slot-name method)))) - (when (or (null specl-cpl) - (member *the-class-structure-object* specl-cpl)) - (return-from make-accessor-table nil)) - (maphash (lambda (class slotd) - (let ((cpl (if early-p - (early-class-precedence-list class) - (class-precedence-list class)))) - (when (memq specl cpl) - (unless (and (or so-p - (member *the-class-std-object* cpl)) - (or early-p - (slot-accessor-std-p slotd type))) - (return-from make-accessor-table nil)) - (push (cons specl slotd) (gethash class table))))) - (gethash slot-name *name->class->slotd-table*)))) - (maphash (lambda (class specl+slotd-list) - (dolist (sclass (if early-p - (early-class-precedence-list class) - (class-precedence-list class)) - (error "This can't happen")) - (let ((a (assq sclass specl+slotd-list))) - (when a - (let* ((slotd (cdr a)) - (index (if early-p - (early-slot-definition-location slotd) - (slot-definition-location slotd)))) - (unless index (return-from make-accessor-table nil)) - (setf (gethash class table) index) - (when (consp index) (setq no-class-slots-p nil)) - (setq all-index (if (or (null all-index) - (eql all-index index)) - index t)) - (incf size) - (cond ((= size 1) (setq first class)) - ((= size 2) (setq second class))) - (return nil)))))) - table) - (values table all-index first second size no-class-slots-p))) + (flet ((precedence (class) + (cpl-maybe-early class)) + (slot-name (method) + (if (consp method) + (and (early-method-standard-accessor-p method) + (early-method-standard-accessor-slot-name method)) + (accessor-method-slot-name method))) + (slot-location (slotd) + (slot-location-maybe-early slotd))) + ;; class -> {(specl slotd)} + (dolist (method methods) + (let* ((specializers (if (consp method) + (early-method-specializers method t) + (method-specializers method))) + (specl (ecase type + ((reader boundp) (car specializers)) + (writer (cadr specializers)))) + (specl-cpl (precedence specl)) + (so-p (member *the-class-std-object* specl-cpl)) + (slot-name (slot-name method))) + (when (or (null specl-cpl) + (member *the-class-structure-object* specl-cpl)) + (return-from make-accessor-table nil)) + (maphash (lambda (class slotd) + (let ((cpl (precedence class))) + (when (memq specl cpl) + (unless (and (or so-p + (member *the-class-std-object* cpl)) + (or early-p + (slot-accessor-std-p slotd type))) + (return-from make-accessor-table nil)) + (push (cons specl slotd) (gethash class table))))) + (gethash slot-name *name->class->slotd-table*)))) + (maphash (lambda (class specl+slotd-list) + (dolist (sclass (precedence class) + (internal-error "This can't happen.")) + (let ((a (assq sclass specl+slotd-list))) + (when a + (let* ((slotd (cdr a)) + (index (slot-location slotd))) + (unless index + (return-from make-accessor-table nil)) + (setf (gethash class table) index) + (when (consp index) + (setq no-class-slots-p nil)) + (setq all-index (if (or (null all-index) + (eql all-index index)) + index t)) + (incf size) + (cond ((= size 1) (setq first class)) + ((= size 2) (setq second class))) + (return nil)))))) + table) + (values table all-index first second size no-class-slots-p)))) -(defun compute-applicable-methods-using-types (generic-function types) - (let ((definite-p t) (possibly-applicable-methods nil)) - (dolist (method (if (early-gf-p generic-function) - (early-gf-methods generic-function) - (generic-function-methods generic-function))) + +;;;; *********************************************** +;;;; The guts of COMPUTE-APPLICABLE-METHODS ******* +;;;; *********************************************** + +;;; +;;; First value is a sorted list of possibly applicable methods of +;;; generic function GF when applied to arguments of types TYPES. +;;; Second value is true if all methods are known to be applicable. +;;; +(defun compute-applicable-methods-using-types (gf types) + (let ((definite-p t) + (possibly-applicable-methods ())) + (dolist (method (if (early-gf-p gf) + (early-gf-methods gf) + (generic-function-methods gf))) (let ((specls (if (consp method) (early-method-specializers method t) (method-specializers method))) (types types) - (possibly-applicable-p t) (applicable-p t)) + (possibly-applicable-p t) + (applicable-p t)) (dolist (specl specls) (multiple-value-bind (specl-applicable-p specl-possibly-applicable-p) (specializer-applicable-using-type-p specl (pop types)) @@ -1193,72 +1279,102 @@ And so, we are saved. (setq applicable-p nil)) (unless specl-possibly-applicable-p (setq possibly-applicable-p nil) - (return nil)))) + (return)))) (when possibly-applicable-p - (unless applicable-p (setq definite-p nil)) + (unless applicable-p + (setq definite-p nil)) (push method possibly-applicable-methods)))) - (let ((precedence (arg-info-precedence (if (early-gf-p generic-function) - (early-gf-arg-info generic-function) - (gf-arg-info generic-function))))) - (values (sort-applicable-methods precedence - (nreverse possibly-applicable-methods) - types) + (let ((precedence (arg-info-precedence (if (early-gf-p gf) + (early-gf-arg-info gf) + (gf-arg-info gf))))) + (values (sort-applicable-methods (nreverse possibly-applicable-methods) + types precedence) definite-p)))) -(defun sort-applicable-methods (precedence methods types) +;;; +;;; Sort the list of methods METHODS which are applicable to TYPES +;;; destructively according to PRECEDENCE. PRECEDENCE is a list of +;;; indices for the argument precedence order. +;;; +;;; Only used in this file. +;;; +(defun sort-applicable-methods (methods types precedence) (sort-methods methods precedence (lambda (class1 class2 index) (let* ((class (type-class (nth index types))) - (cpl (if (eq *boot-state* 'complete) - (class-precedence-list class) - (early-class-precedence-list class)))) + (cpl (cpl-maybe-early class))) (if (memq class2 (memq class1 cpl)) - class1 class2))))) + class1 + class2))))) -(defun sort-methods (methods precedence compare-classes-function) +;;; +;;; Sort the list of methods METHODS using argument precedence order +;;; PRECEDENCE. COMPARE-CLASSES is a function used to compare method +;;; specializers. +;;; +;;; Only used in this file. +;;; +(defun sort-methods (methods precedence compare-classes) (flet ((sorter (method1 method2) (dolist (index precedence) - (let* ((specl1 (nth index (if (listp method1) - (early-method-specializers method1 t) - (method-specializers method1)))) - (specl2 (nth index (if (listp method2) - (early-method-specializers method2 t) - (method-specializers method2)))) - (order (order-specializers - specl1 specl2 index compare-classes-function))) - (when order - (return-from sorter (eq order specl1))))))) + (flet ((specializers (method) + (if (listp method) + (early-method-specializers method t) + (method-specializers method)))) + (let* ((specl1 (nth index (specializers method1))) + (specl2 (nth index (specializers method2))) + (more-specific (more-specific-specializer + specl1 specl2 index compare-classes))) + (when more-specific + (return-from sorter (eq more-specific specl1)))))))) (stable-sort methods #'sorter))) -(defun order-specializers (specl1 specl2 index compare-classes-function) - (let ((type1 (if (eq *boot-state* 'complete) - (specializer-type specl1) - (bootstrap-get-slot 'specializer specl1 'type))) - (type2 (if (eq *boot-state* 'complete) - (specializer-type specl2) - (bootstrap-get-slot 'specializer specl2 'type)))) - (cond ((eq specl1 specl2) - nil) - ((atom type1) - specl2) - ((atom type2) - specl1) - (t - (case (car type1) - (class (case (car type2) - (class (funcall compare-classes-function specl1 specl2 index)) - (t specl2))) - (prototype (case (car type2) - (class (funcall compare-classes-function specl1 specl2 index)) - (t specl2))) - (class-eq (case (car type2) - (eql specl2) - (class-eq nil) - (class type1))) - (eql (case (car type2) - (eql nil) - (t specl1)))))))) +;;; +;;; Return the more specific specializer of SPEC1 and SPEC2, or null +;;; if equally specific. INDEX is the index of SPEC1 and SPEC2 in the +;;; method specializers. COMPARE-CLASSES is a function to call for +;;; comparing class specializers. +;;; +;;; Only used in this file. +;;; +(defun more-specific-specializer (specl1 specl2 index compare-classes) + (flet ((spec-type (spec) + (if (eq *boot-state* 'complete) + (specializer-type spec) + (bootstrap-get-slot 'specializer spec 'type)))) + (let ((type1 (spec-type specl1)) + (type2 (spec-type specl2))) + (cond ((eq specl1 specl2) + nil) + ((atom type1) + specl2) + ((atom type2) + specl1) + (t + (case (car type1) + (class + (case (car type2) + (class (funcall compare-classes specl1 specl2 index)) + (t specl2))) + (prototype + (case (car type2) + (class (funcall compare-classes specl1 specl2 index)) + (t specl2))) + (class-eq + (case (car type2) ; FIXME: ECASE? + (eql specl2) + (class-eq nil) + (class type1))) + (eql + (case (car type2) + (eql nil) + (t specl1))))))))) + + +;;;; *********************** +;;;; MAP-ALL-ORDERS ******* +;;;; *********************** (defun map-all-orders (methods precedence function) (let ((choices nil)) @@ -1304,14 +1420,34 @@ And so, we are saved. (not (member class1 (cdr (class-precedence-list class2)))) (class-can-precede-p class1 class2))) -(defun compute-precedence (lambda-list nreq argument-precedence-order) - (if (null argument-precedence-order) - (let ((list nil)) - (dotimes (i nreq list) - (declare (fixnum i)) - (push (- (1- nreq) i) list))) - (mapcar (lambda (x) (position x lambda-list)) - argument-precedence-order))) + +;;;; ******************************************** +;;;; SPECIALIZER-APPLICABLE-USING-TYPE-P ******* +;;;; ******************************************** + +;;; +;;; First value is true if specializer SPECL is applicable to TYPE. +;;; Second value is true if its possibly applicable to TYPE. This is +;;; used by c-a-m-u-t and generate-discrimination-net-internal, and +;;; has only what they need. +;;; +(defun specializer-applicable-using-type-p (specl type) + (let ((specl (type-from-specializer specl))) + (cond ((eq specl t) + (values t t)) + ((or (atom type) (eq (car type) t)) + (values nil t)) + (t + (case (car type) + (class (saut-class specl type)) + (and (saut-and specl type)) + (not (saut-not specl type)) + (prototype (saut-prototype specl type)) + (class-eq (saut-class-eq specl type)) + (eql (saut-eql specl type)) + (t (internal-error + "~@<~s cannot handle the second argument ~s.~@:>" + 'specializer-applicable-using-type-p type))))))) (defun saut-and (specl type) (let ((applicable nil) @@ -1319,57 +1455,59 @@ And so, we are saved. (dolist (type (cdr type)) (multiple-value-bind (appl poss-appl) (specializer-applicable-using-type-p specl type) - (when appl (return (setq applicable t))) - (unless poss-appl (return (setq possibly-applicable nil))))) + (when appl + (return (setq applicable t))) + (unless poss-appl + (return (setq possibly-applicable nil))))) (values applicable possibly-applicable))) (defun saut-not (specl type) (let ((ntype (cadr type))) - (values nil - (case (car ntype) - (class (saut-not-class specl ntype)) - (class-eq (saut-not-class-eq specl ntype)) - (prototype (saut-not-prototype specl ntype)) - (eql (saut-not-eql specl ntype)) - (t (error "~s cannot handle the second argument ~s" + (values + nil + (case (car ntype) + (class + (let* ((class (type-class specl)) + (cpl (cpl-or-nil class))) + (not (memq (cadr ntype) cpl)))) + (class-eq + (let ((class (case (car specl) + (eql (class-of (cadr specl))) + (class-eq (cadr specl))))) + (not (eq class (cadr ntype))))) + (prototype + (let* ((class (case (car specl) + (eql (class-of (cadr specl))) + (class-eq (cadr specl)) + (prototype (cadr specl)) + (class (cadr specl)))) + (cpl (cpl-or-nil class))) + (not (memq (cadr ntype) cpl)))) + (eql + (case (car specl) + (eql (not (eql (cadr specl) (cadr ntype)))) + (t t))) + (t + (internal-error "~@<~s cannot handle the second argument ~s.~@:>" 'specializer-applicable-using-type-p type)))))) -(defun saut-not-class (specl ntype) - (let* ((class (type-class specl)) - (cpl (class-precedence-list class))) - (not (memq (cadr ntype) cpl)))) - -(defun saut-not-prototype (specl ntype) - (let* ((class (case (car specl) - (eql (class-of (cadr specl))) - (class-eq (cadr specl)) - (prototype (cadr specl)) - (class (cadr specl)))) - (cpl (class-precedence-list class))) - (not (memq (cadr ntype) cpl)))) - -(defun saut-not-class-eq (specl ntype) - (let ((class (case (car specl) - (eql (class-of (cadr specl))) - (class-eq (cadr specl))))) - (not (eq class (cadr ntype))))) - -(defun saut-not-eql (specl ntype) - (case (car specl) - (eql (not (eql (cadr specl) (cadr ntype)))) - (t t))) - -(defun class-applicable-using-class-p (specl type) - (let ((pred (memq specl (if (eq *boot-state* 'complete) - (class-precedence-list type) - (early-class-precedence-list type))))) - (values pred - (or pred - (if (not *in-precompute-effective-methods-p*) - ;; classes might get common subclass - (superclasses-compatible-p specl type) - ;; worry only about existing classes - (classes-have-common-subclass-p specl type)))))) +(defun saut-class (specl type) + (if (eq 'class (car specl)) + (let* ((specl (cadr specl)) + (type (cadr type)) + (cpl (cpl-or-nil type)) + (pred (memq specl cpl))) + (values pred + (or pred + (if (not *in-precompute-effective-methods-p*) + ;; classes might get common subclass + (superclasses-compatible-p specl type) + ;; worry only about existing classes + (classes-have-common-subclass-p specl type))))) + (values nil + (let ((class (type-class specl)) + (cpl (cpl-or-nil class))) + (memq (cadr type) cpl))))) (defun classes-have-common-subclass-p (class1 class2) (or (eq class1 class2) @@ -1379,13 +1517,6 @@ And so, we are saved. (when (classes-have-common-subclass-p class1-sub class2) (return t))))))) -(defun saut-class (specl type) - (case (car specl) - (class (class-applicable-using-class-p (cadr specl) (cadr type))) - (t (values nil (let ((class (type-class specl))) - (memq (cadr type) - (class-precedence-list class))))))) - (defun saut-class-eq (specl type) (if (eq (car specl) 'eql) (values nil (eq (class-of (cadr specl)) (cadr type))) @@ -1395,9 +1526,7 @@ And so, we are saved. (class (or (eq (cadr specl) (cadr type)) (memq (cadr specl) - (if (eq *boot-state* 'complete) - (class-precedence-list (cadr type)) - (early-class-precedence-list (cadr type))))))))) + (cpl-maybe-early (cadr type)))))))) (values pred pred)))) (defun saut-prototype (specl type) @@ -1406,45 +1535,15 @@ And so, we are saved. (defun saut-eql (specl type) (let ((pred (case (car specl) - (eql (eql (cadr specl) (cadr type))) - (class-eq (eq (cadr specl) (class-of (cadr type)))) - (class (memq (cadr specl) - (let ((class (class-of (cadr type)))) - (if (eq *boot-state* 'complete) - (class-precedence-list class) - (early-class-precedence-list class)))))))) + (eql + (eql (cadr specl) (cadr type))) + (class-eq + (eq (cadr specl) (class-of (cadr type)))) + (class + (memq (cadr specl) + (cpl-maybe-early (class-of (cadr type)))))))) (values pred pred))) -(defun specializer-applicable-using-type-p (specl type) - (setq specl (type-from-specializer specl)) - (when (eq specl t) - (return-from specializer-applicable-using-type-p (values t t))) - ;; This is used by c-a-m-u-t and generate-discrimination-net-internal, - ;; and has only what they need. - (if (or (atom type) (eq (car type) t)) - (values nil t) - (case (car type) - (and (saut-and specl type)) - (not (saut-not specl type)) - (class (saut-class specl type)) - (prototype (saut-prototype specl type)) - (class-eq (saut-class-eq specl type)) - (eql (saut-eql specl type)) - (t (error "~s cannot handle the second argument ~s" - 'specializer-applicable-using-type-p type))))) - -(defun map-all-classes (function &optional (root t)) - (let ((braid-p (or (eq *boot-state* 'braid) - (eq *boot-state* 'complete)))) - (labels ((do-class (class) - (mapc #'do-class - (if braid-p - (class-direct-subclasses class) - (early-class-direct-subclasses class))) - (funcall function class))) - (do-class (if (symbolp root) - (find-class root) - root))))) ;;; ;;; NOTE: We are assuming a restriction on user code that the method @@ -1456,21 +1555,22 @@ And so, we are saved. ;;; cache, is just a backing cache for the fast cache. If that ;;; cache is legal, this one must be too. ;;; -;;; Don't clear this table! +;;; Don't clear this table! +;;; (defvar *effective-method-table* (make-hash-table :test 'eq)) (defun get-secondary-dispatch-function (gf methods types &optional - method-alist wrappers) - (function-funcall (get-secondary-dispatch-function1 - gf methods types - (not (null method-alist)) - (not (null wrappers)) - (not (methods-contain-eql-specializer-p methods))) - method-alist wrappers)) + method-alist wrappers) + (let ((generator (get-secondary-dispatch-function1 + gf methods types + (not (null method-alist)) + (not (null wrappers)) + (not (methods-contain-eql-specializer-p methods))))) + (make-callable gf methods generator method-alist wrappers))) (defun get-secondary-dispatch-function1 (gf methods types method-alist-p wrappers-p - &optional all-applicable-p - (all-sorted-p t) function-p) + &optional all-applicable-p + (all-sorted-p t) function-p) (if (null methods) (if function-p (lambda (method-alist wrappers) @@ -1502,50 +1602,49 @@ And so, we are saved. (push (cons akey value) (cdr ht-value)) value))))))) -(defun get-secondary-dispatch-function2 (gf methods types method-alist-p wrappers-p - all-applicable-p all-sorted-p function-p) +(defvar *computing-standard-effective-method-p* nil) + +(defun get-secondary-dispatch-function2 (gf methods types method-alist-p + wrappers-p all-applicable-p + all-sorted-p function-p) (if (and all-applicable-p all-sorted-p (not function-p)) - (if (eq *boot-state* 'complete) + (if (and (eq *boot-state* 'complete) + ;; Because of loadable-pcl. See combin.lisp. + (not (eq #'compute-effective-method gf)) + (not *computing-standard-effective-method-p*)) (let* ((combin (generic-function-method-combination gf)) (effective (compute-effective-method gf combin methods))) - (make-effective-method-function1 gf effective method-alist-p wrappers-p)) - (let ((effective (standard-compute-effective-method gf nil methods))) - (make-effective-method-function1 gf effective method-alist-p wrappers-p))) - (let ((net (generate-discrimination-net - gf methods types all-sorted-p))) + (callable-generator gf effective method-alist-p wrappers-p)) + (let ((*computing-standard-effective-method-p* t) + (effective (standard-compute-effective-method gf nil methods))) + (callable-generator gf effective method-alist-p wrappers-p))) + (let ((net (generate-discrimination-net gf methods types all-sorted-p))) (compute-secondary-dispatch-function1 gf net function-p)))) -(defun get-effective-method-function (gf methods &optional method-alist wrappers) - (function-funcall (get-secondary-dispatch-function1 gf methods nil - (not (null method-alist)) - (not (null wrappers)) - t) - method-alist wrappers)) +(defun get-effective-method-function (gf methods + &optional method-alist wrappers) + (let ((generator (get-secondary-dispatch-function1 + gf methods nil (not (null method-alist)) + (not (null wrappers))))) + (make-callable gf methods generator method-alist wrappers))) (defun get-effective-method-function1 (gf methods &optional (sorted-p t)) (get-secondary-dispatch-function1 gf methods nil nil nil t sorted-p)) (defun methods-contain-eql-specializer-p (methods) (and (eq *boot-state* 'complete) - (dolist (method methods nil) - (when (dolist (spec (method-specializers method) nil) - (when (eql-specializer-p spec) (return t))) - (return t))))) - -(defun update-dfun (generic-function &optional dfun cache info) - (let* ((early-p (early-gf-p generic-function)) - (gf-name (if early-p - (early-gf-name generic-function) - (generic-function-name generic-function)))) - (set-dfun generic-function dfun cache info) - (let ((dfun (if early-p - (or dfun (make-initial-dfun generic-function)) - (compute-discriminating-function generic-function)))) - (set-funcallable-instance-function generic-function dfun) - (set-function-name generic-function gf-name) - dfun))) + (some (lambda (method) + (some #'eql-specializer-p (method-specializers method))) + methods))) +;;;; ************************ +;;;; Debugging Stuff ******* +;;;; ************************ + +#+pcl-debug +(progn + (defvar dfun-count nil) (defvar dfun-list nil) (defvar *minimum-cache-size-to-list*) @@ -1582,7 +1681,6 @@ And so, we are saved. (mapc #'print dfun-list) (values)) - (defun count-dfun (gf) (let* ((sym (type-of (gf-dfun-info gf))) (cache (gf-dfun-cache gf)) @@ -1614,10 +1712,15 @@ And so, we are saved. dfun-count) (values)) -(defun gfs-of-type (type) - (unless (consp type) (setq type (list type))) - (let ((gf-list nil)) - (map-all-generic-functions (lambda (gf) - (when (memq (type-of (gf-dfun-info gf)) type) - (push gf gf-list)))) - gf-list)) + +(defun show-dfun-constructors () + (format t "~&DFUN constructor caching is ~A." + (if *enable-dfun-constructor-caching* + "enabled" "disabled")) + (dolist (generator-entry *dfun-constructors*) + (dolist (args-entry (cdr generator-entry)) + (format t "~&~S ~S" + (cons (car generator-entry) (caar args-entry)) + (caddr args-entry))))) + +) ; #+pcl-debug diff --git a/pcl/dlisp.lisp b/pcl/dlisp.lisp index ee2edbcd0..ab8e7a5a1 100644 --- a/pcl/dlisp.lisp +++ b/pcl/dlisp.lisp @@ -23,10 +23,9 @@ ;;; ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* -;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/dlisp.lisp,v 1.10 2002/11/28 16:23:33 pmai Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/dlisp.lisp,v 1.11 2003/03/22 16:15:17 gerd Exp $") ;;; (in-package :pcl) @@ -40,12 +39,18 @@ (defun emit-one-class-reader (class-slot-p) (emit-reader/writer :reader 1 class-slot-p)) +(defun emit-one-class-boundp (class-slot-p) + (emit-reader/writer :boundp 1 class-slot-p)) + (defun emit-one-class-writer (class-slot-p) (emit-reader/writer :writer 1 class-slot-p)) (defun emit-two-class-reader (class-slot-p) (emit-reader/writer :reader 2 class-slot-p)) +(defun emit-two-class-boundp (class-slot-p) + (emit-reader/writer :boundp 2 class-slot-p)) + (defun emit-two-class-writer (class-slot-p) (emit-reader/writer :writer 2 class-slot-p)) @@ -54,12 +59,18 @@ (defun emit-one-index-readers (class-slot-p) (emit-one-or-n-index-reader/writer :reader nil class-slot-p)) +(defun emit-one-index-boundps (class-slot-p) + (emit-one-or-n-index-reader/writer :boundp nil class-slot-p)) + (defun emit-one-index-writers (class-slot-p) (emit-one-or-n-index-reader/writer :writer nil class-slot-p)) (defun emit-n-n-readers () (emit-one-or-n-index-reader/writer :reader t nil)) +(defun emit-n-n-boundps () + (emit-one-or-n-index-reader/writer :boundp t nil)) + (defun emit-n-n-writers () (emit-one-or-n-index-reader/writer :writer t nil)) @@ -82,10 +93,13 @@ (defvar *precompiling-lap* nil) (defvar *emit-function-p* t) +(defvar *optimize-cache-functions-p* t) + (defun emit-default-only (metatypes applyp) - (when (and (null *precompiling-lap*) *emit-function-p*) - (return-from emit-default-only - (emit-default-only-function metatypes applyp))) + (unless *optimize-cache-functions-p* + (when (and (null *precompiling-lap*) *emit-function-p*) + (return-from emit-default-only + (emit-default-only-function metatypes applyp)))) (let* ((dlap-lambda-list (make-dlap-lambda-list metatypes applyp)) (args (remove '&rest dlap-lambda-list)) (restl (when applyp '(.lap-rest-arg.)))) @@ -93,12 +107,6 @@ dlap-lambda-list `(invoke-effective-method-function emf ,applyp ,@args ,@restl)))) -(defmacro emit-default-only-macro (metatypes applyp) - (let ((*emit-function-p* nil) - (*precompiling-lap* t)) - (values - (emit-default-only metatypes applyp)))) - ;;; -------------------------------- (defun generating-lisp (closure-variables args form) @@ -109,41 +117,45 @@ ,@(when (member 'miss-fn closure-variables) `((declare (type function miss-fn)))) #'(kernel:instance-lambda ,args - (let () - (declare #.*optimize-speed*) + ;; + ;; Don't ask me why LOCALLY is necessary here. + ;; Fact is that without it the resulting code is + ;; up ta 25% slower. --gerd 2002-10-26. + (locally (declare #.*optimize-speed*) ,form))))) (values (if *precompiling-lap* `#',lambda (compile-lambda lambda)) nil))) +;;; ;;; cmu17 note: since std-instance-p is weakened, that branch may run -;;; on non-pcl instances (structures). The result will be the -;;; non-wrapper layout for the structure, which will cause a miss. The "slots" -;;; will be whatever the first slot is, but will be ignored. Similarly, -;;; fsc-instance-p returns true on funcallable structures as well as PCL fins. +;;; on non-pcl instances (structures). The result will be the +;;; non-wrapper layout for the structure, which will cause a miss. +;;; The "slots" will be whatever the first slot is, but will be +;;; ignored. Similarly, fsc-instance-p returns true on funcallable +;;; structures as well as PCL fins. ;;; (defun emit-reader/writer (reader/writer 1-or-2-class class-slot-p) - (when (and (null *precompiling-lap*) *emit-function-p*) - (return-from emit-reader/writer - (emit-reader/writer-function reader/writer 1-or-2-class class-slot-p))) - (let ((instance nil) - (arglist ()) - (closure-variables ()) - (field (first-wrapper-cache-number-index)) - (readp (eq reader/writer :reader)) - (read-form (emit-slot-read-form class-slot-p 'index 'slots))) - ;;we need some field to do the fast obsolete check - (ecase reader/writer - (:reader (setq instance (dfun-arg-symbol 0) - arglist (list instance))) - (:writer (setq instance (dfun-arg-symbol 1) - arglist (list (dfun-arg-symbol 0) instance)))) - (ecase 1-or-2-class - (1 (setq closure-variables '(wrapper-0 index miss-fn))) - (2 (setq closure-variables '(wrapper-0 wrapper-1 index miss-fn)))) - (generating-lisp closure-variables - arglist + (unless *optimize-cache-functions-p* + (when (and (null *precompiling-lap*) *emit-function-p*) + (return-from emit-reader/writer + (emit-reader/writer-function reader/writer 1-or-2-class class-slot-p)))) + (let* ((instance + (ecase reader/writer + ((:reader :boundp) (dfun-arg-symbol 0)) + (:writer (dfun-arg-symbol 1)))) + (arglist + (ecase reader/writer + ((:reader :boundp) (list instance)) + (:writer (list (dfun-arg-symbol 0) instance)))) + (closure-variables + (ecase 1-or-2-class + (1 '(wrapper-0 index miss-fn)) + (2 '(wrapper-0 wrapper-1 index miss-fn)))) + (read-form + (emit-slot-read-form class-slot-p 'index 'slots))) + (generating-lisp closure-variables arglist `(let* (,@(unless class-slot-p `((slots nil))) (wrapper (cond ((std-instance-p ,instance) ,@(unless class-slot-p @@ -155,22 +167,27 @@ (fsc-instance-wrapper ,instance))))) (block access (when (and wrapper - (/= (wrapper-cache-number-vector-ref wrapper ,field) 0) + (not (zerop (kernel:layout-hash wrapper 0))) ,@(if (eql 1 1-or-2-class) `((eq wrapper wrapper-0)) `((or (eq wrapper wrapper-0) (eq wrapper wrapper-1))))) - ,@(if readp - `((let ((value ,read-form)) - (unless (eq value +slot-unbound+) - (return-from access value)))) - `((return-from access (setf ,read-form ,(car arglist)))))) + ,@(ecase reader/writer + (:reader + `((let ((value ,read-form)) + (unless (eq value +slot-unbound+) + (return-from access value))))) + (:boundp + `((let ((value ,read-form)) + (return-from access (not (eq value +slot-unbound+)))))) + (:writer + `((return-from access (setf ,read-form ,(car arglist))))))) (funcall miss-fn ,@arglist)))))) (defun emit-slot-read-form (class-slot-p index slots) (if class-slot-p `(cdr ,index) - `(%instance-ref ,slots ,index))) + `(%slot-ref ,slots ,index))) (defun emit-boundp-check (value-form miss-fn arglist) `(let ((value ,value-form)) @@ -182,6 +199,7 @@ (let ((read-form (emit-slot-read-form class-slot-p index slots))) (ecase reader/writer (:reader (emit-boundp-check read-form miss-fn arglist)) + (:boundp `(not (eq +slot-unbound+ ,read-form))) (:writer `(setf ,read-form ,(car arglist)))))) (defmacro emit-reader/writer-macro (reader/writer 1-or-2-class class-slot-p) @@ -191,16 +209,19 @@ (emit-reader/writer reader/writer 1-or-2-class class-slot-p)))) (defun emit-one-or-n-index-reader/writer (reader/writer cached-index-p class-slot-p) - (when (and (null *precompiling-lap*) *emit-function-p*) - (return-from emit-one-or-n-index-reader/writer - (emit-one-or-n-index-reader/writer-function - reader/writer cached-index-p class-slot-p))) + (unless *optimize-cache-functions-p* + (when (and (null *precompiling-lap*) *emit-function-p*) + (return-from emit-one-or-n-index-reader/writer + (emit-one-or-n-index-reader/writer-function + reader/writer cached-index-p class-slot-p)))) (multiple-value-bind (arglist metatypes) (ecase reader/writer - (:reader (values (list (dfun-arg-symbol 0)) - '(standard-instance))) - (:writer (values (list (dfun-arg-symbol 0) (dfun-arg-symbol 1)) - '(t standard-instance)))) + ((:reader :boundp) + (values (list (dfun-arg-symbol 0)) + '(standard-instance))) + (:writer + (values (list (dfun-arg-symbol 0) (dfun-arg-symbol 1)) + '(t standard-instance)))) (generating-lisp `(cache ,@(unless cached-index-p '(index)) miss-fn) arglist `(let (,@(unless class-slot-p '(slots)) @@ -217,7 +238,8 @@ (let ((*emit-function-p* nil) (*precompiling-lap* t)) (values - (emit-one-or-n-index-reader/writer reader/writer cached-index-p class-slot-p)))) + (emit-one-or-n-index-reader/writer reader/writer cached-index-p + class-slot-p)))) (defun emit-miss (miss-fn args &optional applyp) (let ((restl (when applyp '(.lap-rest-arg.)))) @@ -226,10 +248,11 @@ `(funcall ,miss-fn ,@args ,@restl)))) (defun emit-checking-or-caching (cached-emf-p return-value-p metatypes applyp) - (when (and (null *precompiling-lap*) *emit-function-p*) - (return-from emit-checking-or-caching - (emit-checking-or-caching-function - cached-emf-p return-value-p metatypes applyp))) + (unless *optimize-cache-functions-p* + (when (and (null *precompiling-lap*) *emit-function-p*) + (return-from emit-checking-or-caching + (emit-checking-or-caching-function + cached-emf-p return-value-p metatypes applyp)))) (let* ((dlap-lambda-list (make-dlap-lambda-list metatypes applyp)) (args (remove '&rest dlap-lambda-list)) (restl (when applyp '(.lap-rest-arg.)))) @@ -245,12 +268,6 @@ (emit-miss 'miss-fn args applyp) (when cached-emf-p 'emf)))))) -(defmacro emit-checking-or-caching-macro (cached-emf-p return-value-p metatypes applyp) - (let ((*emit-function-p* nil) - (*precompiling-lap* t)) - (values - (emit-checking-or-caching cached-emf-p return-value-p metatypes applyp)))) - (defun emit-dlap (args metatypes hit miss value-reg &optional slot-regs) (let* ((index -1) (wrapper-bindings (mapcan (lambda (arg mt) @@ -263,7 +280,7 @@ args metatypes)) (wrappers (mapcar #'car wrapper-bindings))) (declare (fixnum index)) - (unless wrappers (error "Every metatype is T.")) + (assert (not (null wrappers)) () "Every metatype is T.") `(block dfun (tagbody (let ((field (cache-field cache)) @@ -301,8 +318,6 @@ (defmacro get-cache-vector-lock-count (cache-vector) `(let ((lock-count (cache-vector-lock-count ,cache-vector))) - (unless (typep lock-count 'fixnum) - (error "my cache got freed somehow")) (the fixnum lock-count))) (defun emit-1-t-dlap (wrapper miss-label value) @@ -336,46 +351,48 @@ ,(emit-n-wrapper-compute-primary-cache-location wrappers miss-label) (let ((initial-lock-count (get-cache-vector-lock-count cache-vector))) (declare (fixnum initial-lock-count)) - (let ((location primary) (next-location 0)) - (declare (fixnum location next-location)) + (let ((location primary)) + (declare (fixnum location)) (block search - (loop (setq next-location (the fixnum (+ location ,cache-line-size))) - (when (and ,@(mapcar - (lambda (wrapper) - `(eq ,wrapper - (cache-vector-ref cache-vector - (setq location - (the fixnum (+ location 1)))))) - wrappers)) + (loop + (let ((next-location (the fixnum (+ location ,cache-line-size)))) + (declare #.*optimize-speed*) + (declare (fixnum next-location)) + (when (and ,@(mapcar + (lambda (wrapper) + `(eq ,wrapper + (%svref cache-vector + (setq location + (the fixnum (1+ location)))))) + wrappers)) ,@(when value - `((setq location (the fixnum (+ location 1))) - (setq ,value (cache-vector-ref cache-vector location)))) + `((setq location (the fixnum (1+ location))) + (setq ,value (%svref cache-vector location)))) (return-from search nil)) - (setq location next-location) - (when (= location size-1) - (setq location 0)) - (when (= location primary) - (dolist (entry overflow) - (let ((entry-wrappers (car entry))) - (when (and ,@(mapcar (lambda (wrapper) - `(eq ,wrapper (pop entry-wrappers))) - wrappers)) - ,@(when value - `((setq ,value (cdr entry)))) - (return-from search nil)))) - (go ,miss-label)))) + (setq location next-location) + (when (= location size-1) + (setq location 0)) + (when (= location primary) + (loop for (ws . v) in overflow + when (and ,@(mapcar (lambda (w) + `(eq ,w (pop ws))) + wrappers)) do + ,@(when value `((setq ,value v))) + (return-from search nil)) + (go ,miss-label))))) (unless (= initial-lock-count (get-cache-vector-lock-count cache-vector)) (go ,miss-label))))))) (defun emit-1-wrapper-compute-primary-cache-location (wrapper miss-label) - `(let ((wrapper-cache-no (wrapper-cache-number-vector-ref ,wrapper field))) + `(let ((wrapper-cache-no (kernel:layout-hash ,wrapper field))) (declare (fixnum wrapper-cache-no)) - (when (zerop wrapper-cache-no) (go ,miss-label)) - ,(let ((form `(logand - mask wrapper-cache-no))) + (when (zerop wrapper-cache-no) + (go ,miss-label)) + ,(let ((form `(logand mask wrapper-cache-no))) `(the fixnum ,form)))) +#-pcl-xorhash (defun emit-n-wrapper-compute-primary-cache-location (wrappers miss-label) (declare (type list wrappers)) ;; this returns 1 less that the actual location @@ -383,20 +400,40 @@ ,@(let ((adds 0) (len (length wrappers))) (declare (fixnum adds len)) (mapcar (lambda (wrapper) - `(let ((wrapper-cache-no (wrapper-cache-number-vector-ref - ,wrapper field))) + `(let ((wrapper-cache-no (kernel:layout-hash ,wrapper field))) (declare (fixnum wrapper-cache-no)) (when (zerop wrapper-cache-no) (go ,miss-label)) (setq primary (the fixnum (+ primary wrapper-cache-no))) ,@(progn (incf adds) - (when (or (zerop (mod adds wrapper-cache-number-adds-ok)) + (when (or (zerop (mod adds +max-hash-code-additions+)) (eql adds len)) `((setq primary ,(let ((form `(logand primary mask))) `(the fixnum ,form)))))))) wrappers)))) - + +#+pcl-xorhash +(defun emit-n-wrapper-compute-primary-cache-location (wrappers miss-label) + (declare (type list wrappers)) + ;; this returns 1 less that the actual location + `(progn + ,@(let ((adds 0) (len (length wrappers))) + (declare (fixnum adds len)) + (mapcar (lambda (wrapper) + `(let ((hash (kernel:layout-hash ,wrapper field))) + (declare (fixnum hash)) + (when (zerop hash) (go ,miss-label)) + (setq primary (logxor primary hash)) + ,@(progn + (incf adds) + (when (eql adds len) + `((setq primary + ,(let ((form `(logand primary mask))) + `(the fixnum ,form)))))))) + wrappers)))) + +;;; ;;; cmu17 note: since std-instance-p is weakened, that branch may run ;;; on non-pcl instances (structures). The result will be the ;;; non-wrapper layout for the structure, which will cause a miss. The "slots" @@ -415,10 +452,9 @@ (t (go ,miss-label)))) (class - (when slot (error "Can't do a slot reg for this metatype.")) + (assert (null slot) () "Can't do a slot reg for this metatype.") `(wrapper-of-macro ,argument)) ((built-in-instance structure-instance) - (when slot (error "Can't do a slot reg for this metatype.")) - `(built-in-or-structure-wrapper - ,argument)))) + (assert (null slot) () "Can't do a slot reg for this metatype.") + `(built-in-or-structure-wrapper ,argument)))) diff --git a/pcl/dlisp2.lisp b/pcl/dlisp2.lisp index 646192191..bf0a89f76 100644 --- a/pcl/dlisp2.lisp +++ b/pcl/dlisp2.lisp @@ -23,10 +23,9 @@ ;;; ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* -;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/dlisp2.lisp,v 1.10 2002/11/28 16:23:33 pmai Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/dlisp2.lisp,v 1.11 2003/03/22 16:15:17 gerd Exp $") ;;; (in-package :pcl) @@ -47,27 +46,44 @@ (emit-reader/writer-macro :writer 1 nil))) (2 (if class-slot-p (emit-reader/writer-macro :writer 2 t) - (emit-reader/writer-macro :writer 2 nil)))))) + (emit-reader/writer-macro :writer 2 nil))))) + (:boundp (ecase 1-or-2-class + (1 (if class-slot-p + (emit-reader/writer-macro :boundp 1 t) + (emit-reader/writer-macro :boundp 1 nil))) + (2 (if class-slot-p + (emit-reader/writer-macro :boundp 2 t) + (emit-reader/writer-macro :boundp 2 nil)))))) nil)) (defun emit-one-or-n-index-reader/writer-function (reader/writer cached-index-p class-slot-p) (values (ecase reader/writer - (:reader (if cached-index-p - (if class-slot-p - (emit-one-or-n-index-reader/writer-macro :reader t t) - (emit-one-or-n-index-reader/writer-macro :reader t nil)) - (if class-slot-p - (emit-one-or-n-index-reader/writer-macro :reader nil t) - (emit-one-or-n-index-reader/writer-macro :reader nil nil)))) - (:writer (if cached-index-p - (if class-slot-p - (emit-one-or-n-index-reader/writer-macro :writer t t) - (emit-one-or-n-index-reader/writer-macro :writer t nil)) - (if class-slot-p - (emit-one-or-n-index-reader/writer-macro :writer nil t) - (emit-one-or-n-index-reader/writer-macro :writer nil nil))))) + (:reader + (if cached-index-p + (if class-slot-p + (emit-one-or-n-index-reader/writer-macro :reader t t) + (emit-one-or-n-index-reader/writer-macro :reader t nil)) + (if class-slot-p + (emit-one-or-n-index-reader/writer-macro :reader nil t) + (emit-one-or-n-index-reader/writer-macro :reader nil nil)))) + (:writer + (if cached-index-p + (if class-slot-p + (emit-one-or-n-index-reader/writer-macro :writer t t) + (emit-one-or-n-index-reader/writer-macro :writer t nil)) + (if class-slot-p + (emit-one-or-n-index-reader/writer-macro :writer nil t) + (emit-one-or-n-index-reader/writer-macro :writer nil nil)))) + (:boundp + (if cached-index-p + (if class-slot-p + (emit-one-or-n-index-reader/writer-macro :boundp t t) + (emit-one-or-n-index-reader/writer-macro :boundp t nil)) + (if class-slot-p + (emit-one-or-n-index-reader/writer-macro :boundp nil t) + (emit-one-or-n-index-reader/writer-macro :boundp nil nil))))) nil)) (defun emit-checking-or-caching-function (cached-emf-p return-value-p @@ -76,8 +92,6 @@ cached-emf-p return-value-p metatypes applyp) t)) -(defvar not-in-cache (make-symbol "not in cache")) - (defun emit-checking-or-caching-function-preliminary (cached-emf-p return-value-p metatypes applyp) (declare (ignore applyp)) @@ -91,8 +105,8 @@ (apply miss-fn args) (if invalid-wrapper-p (apply miss-fn args) - (let ((emf (probe-cache cache dfun-wrappers not-in-cache))) - (if (eq emf not-in-cache) + (let ((emf (probe-cache cache dfun-wrappers 'not-in-cache))) + (if (eq emf 'not-in-cache) (apply miss-fn args) (if return-value-p emf @@ -106,9 +120,9 @@ (apply miss-fn args) (if invalid-wrapper-p (apply miss-fn args) - (let ((found-p (not (eq not-in-cache + (let ((found-p (not (eq 'not-in-cache (probe-cache cache dfun-wrappers - not-in-cache))))) + 'not-in-cache))))) (if found-p (invoke-emf emf args) (if return-value-p diff --git a/pcl/dlisp3.lisp b/pcl/dlisp3.lisp index a539c1327..ea93f461a 100644 --- a/pcl/dlisp3.lisp +++ b/pcl/dlisp3.lisp @@ -23,10 +23,9 @@ ;;; ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* -;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/dlisp3.lisp,v 1.6 2002/10/09 15:32:28 pmai Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/dlisp3.lisp,v 1.7 2003/03/22 16:15:17 gerd Exp $") ;;; (in-package :pcl) diff --git a/pcl/env.lisp b/pcl/env.lisp index 3e25d23b0..ff721b124 100644 --- a/pcl/env.lisp +++ b/pcl/env.lisp @@ -26,7 +26,7 @@ ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/env.lisp,v 1.18 2003/02/15 23:41:31 pmai Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/env.lisp,v 1.19 2003/03/22 16:15:17 gerd Exp $") ;;; ;;; Basic environmental stuff. ;;; @@ -74,7 +74,7 @@ (adjust-slot-name-length (slot-definition-name slotd)) (case (slot-definition-allocation slotd) (:instance (push slotd instance-slotds)) - (:class (push slotd class-slotds)) + (:class (push slotd class-slotds)) (otherwise (push slotd other-slotds)))) (setq max-slot-name-length (min (+ max-slot-name-length 3) 30)) (format stream "~%~S is an instance of class ~S:" object class) @@ -144,12 +144,12 @@ (mapcar #'pretty-class (class-direct-subclasses class)) (mapcar #'pretty-class (class-precedence-list class)) (length (specializer-direct-methods class))) - (loop initially - (ft "~&Its direct slots are:~%") - for slotd in (class-direct-slots class) - as name = (slot-definition-name slotd) - as doc = (slot-value slotd 'documentation) do - (ft " ~a~@[, documentation ~s~]~%" name doc)))) + (unless (typep class 'condition-class) + (loop initially (ft "~&Its direct slots are:~%") + for slotd in (class-direct-slots class) + as name = (slot-definition-name slotd) + as doc = (slot-value slotd 'documentation) do + (ft " ~a, documentation ~s~%" name doc))))) (when *describe-metaobjects-as-objects-p* (call-next-method))) @@ -196,95 +196,53 @@ ;;; -;;; trace-method and untrace-method accept method specs as arguments. A -;;; method-spec should be a list like: -;;; (<generic-function-spec> qualifiers* (specializers*)) -;;; where <generic-function-spec> should be either a symbol or a list -;;; of (SETF <symbol>). +;;; Value is a list of all (possible) method function names of +;;; generic function GF. ;;; -;;; For example, to trace the method defined by: -;;; -;;; (defmethod foo ((x spaceship)) 'ss) -;;; -;;; You should say: -;;; -;;; (trace-method '(foo (spaceship))) -;;; -;;; You can also provide a method object in the place of the method -;;; spec, in which case that method object will be traced. +(defun debug::all-method-function-names (gf) + (loop with gf = (if (symbolp gf) (gdefinition gf) gf) + for method in (generic-function-methods gf) + as name = (nth-value 2 (parse-method-or-spec method)) + collect name + collect (list* 'fast-method (cdr name)))) + +(defun debug::all-method-functions-in-package (pkg) + (let ((gfs ())) + (map-all-generic-functions + (lambda (gf) + (multiple-value-bind (valid base) + (ext:valid-function-name-p (generic-function-name gf)) + (declare (ignore valid)) + (when (and (symbolp base) + (eq (symbol-package base) pkg)) + (push gf gfs))))) + (loop for gf in gfs nconc (debug::all-method-function-names gf)))) + ;;; -;;; For untrace-method, if an argument is given, that method is untraced. -;;; If no argument is given, all traced methods are untraced. +;;; Reinitialize method function NAME from its fdefinitions. ;;; -(defclass traced-method (method) - ((method :initarg :method) - (function :initarg :function - :reader method-function) - (generic-function :initform nil - :accessor method-generic-function))) - -(defmethod method-lambda-list ((m traced-method)) - (with-slots (method) m (method-lambda-list method))) - -(defmethod method-specializers ((m traced-method)) - (with-slots (method) m (method-specializers method))) - -(defmethod method-qualifiers ((m traced-method)) - (with-slots (method) m (method-qualifiers method))) - -(defmethod accessor-method-slot-name ((m traced-method)) - (with-slots (method) m (accessor-method-slot-name method))) - -(defvar *traced-methods* ()) - -(defun trace-method (spec &rest options) - (multiple-value-bind (gf omethod name) - (parse-method-or-spec spec) - (let* ((tfunction (trace-method-internal (method-function omethod) - name - options)) - (tmethod (make-instance 'traced-method - :method omethod - :function tfunction))) - (remove-method gf omethod) - (add-method gf tmethod) - (pushnew tmethod *traced-methods*) - tmethod))) - -(defun untrace-method (&optional spec) - (flet ((untrace-1 (m) - (let ((gf (method-generic-function m))) - (when gf - (remove-method gf m) - (add-method gf (slot-value m 'method)) - (setq *traced-methods* (remove m *traced-methods*)))))) - (if (not (null spec)) - (multiple-value-bind (gf method) - (parse-method-or-spec spec) - (declare (ignore gf)) - (if (memq method *traced-methods*) - (untrace-1 method) - (error "~S is not a traced method?" method))) - (dolist (m *traced-methods*) (untrace-1 m))))) - -(defun trace-method-internal (ofunction name options) - (eval `(untrace ,name)) - (setf (symbol-function name) ofunction) - (eval `(trace ,name ,@options)) - (symbol-function name)) - - +(defun profile::reinitialize-method-function (name) + (multiple-value-bind (gf method method-name) + (parse-method-or-spec (cdr name)) + (declare (ignore gf method-name)) + (with-slots (function fast-function) method + (ecase (car name) + (method + (when function + (setq function (fdefinition name)))) + (fast-method + (when fast-function + (let* ((new (fdefinition name)) + (plist (method-function-plist new))) + ;; + ;; This is necessary so that, for instance, the arg-info of + ;; the function can be determined. + (unless plist + (setf (method-function-plist new) + (method-function-plist fast-function))) + (setq fast-function new)))))))) - -;(defun compile-method (spec) -; (multiple-value-bind (gf method name) -; (parse-method-or-spec spec) -; (declare (ignore gf)) -; (compile name (method-function method)) -; (setf (method-function method) (symbol-function name)))) - (defmacro undefmethod (&rest args) - (declare (arglist name {method-qualifier}* specializers)) `(undefmethod-1 ',args)) (defun undefmethod-1 (args) @@ -298,6 +256,7 @@ (pushnew :pcl *features*) (pushnew :portable-commonloops *features*) (pushnew :pcl-structures *features*) +(pushnew :gerds-pcl *features*) (when (find-package "OLD-PCL") (setf (symbol-function (find-symbol "PRINT-OBJECT" :old-pcl)) @@ -318,47 +277,22 @@ (declare (ignore env)) (let ((pname (kernel:class-proper-name (kernel:layout-class object)))) (unless pname - (error "Can't dump wrapper for anonymous class:~% ~S" + (error "~@<Can't dump wrapper for anonymous class ~S.~@:>" (kernel:layout-class object))) - `(kernel:class-layout (lisp:find-class ',pname)))) + `(kernel:%class-layout (kernel::find-class ',pname)))) +(defmethod make-load-form ((class class) &optional env) + (declare (ignore env)) + (let ((name (class-name class))) + (unless (and name (eq (find-class name nil) class)) + (error "~@<Can't use anonymous or undefined class as constant: ~S~:@>" + class)) + `(find-class ',name))) + (defun make-load-form-saving-slots (object &key slot-names environment) (declare (ignore environment)) (when slot-names - (warn ":SLOT-NAMES MAKE-LOAD-FORM option not implemented, dumping all ~ - slots:~% ~S" - object)) + (warn "~@<~s ~s option not implemented, dumping all slots: ~S~@:>" + :slot-names 'make-load-form object)) :just-dump-it-normally) - -;;; The following are hacks to deal with CMU CL having two different CLASS -;;; classes. -;;; -(defun coerce-to-pcl-class (class) - (if (typep class 'lisp:class) - (or (kernel:class-pcl-class class) - (find-structure-class (lisp:class-name class))) - class)) - -(defmethod make-instance ((class lisp:class) &rest stuff) - (apply #'make-instance (coerce-to-pcl-class class) stuff)) -(defmethod change-class (instance (class lisp:class) &rest initargs) - (apply #'change-class instance (coerce-to-pcl-class class) initargs)) - -(macrolet ((frob (&rest names) - `(progn - ,@(mapcar (lambda (name) - `(defmethod ,name ((class lisp:class)) - (funcall #',name - (coerce-to-pcl-class class)))) - names)))) - (frob - class-direct-slots - class-prototype - class-precedence-list - class-direct-default-initargs - class-direct-superclasses - compute-class-precedence-list - class-default-initargs class-finalized-p - class-direct-subclasses class-slots - make-instances-obsolete)) diff --git a/pcl/extensions.lisp b/pcl/extensions.lisp deleted file mode 100644 index d63640491..000000000 --- a/pcl/extensions.lisp +++ /dev/null @@ -1,495 +0,0 @@ -;;;-*-Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp; -*- - -;;; -;;; ************************************************************************* -;;; -;;; File: extensions.lisp. -;;; -;;; by Trent E. Lange, Effective Date 04-23-92 -;;; -;;; -;;; This file contains a small set of useful extensions to PCL. -;;; -;;; Permission is granted to any individual or institution to use, copy, -;;; modify and distribute this document. -;;; -;;; Suggestions, bugs, criticism and questions to lange@cs.ucla.edu -;;; ************************************************************************* -;;; - -(ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/Attic/extensions.lisp,v 1.8 2002/12/18 00:16:32 pmai Exp $") -;;; - -(in-package 'pcl) - -(eval-when (:compile-toplevel :load-toplevel :execute) - -(defvar *extensions-exports* - '(set-standard-instance-access - set-funcallable-instance-access - - funcallable-instance-slot-value - set-funcallable-instance-slot-value - funcallable-instance-slot-boundp - standard-instance-slot-value - set-standard-instance-slot-value - standard-instance-slot-boundp - structure-instance-slot-value - set-structure-instance-slot-value - structure-instance-slot-boundp - - #+pcl-user-instances - user-instance-slot-value - #+pcl-user-instances - set-user-instance-slot-value - #+pcl-user-instances - user-instance-slot-boundp - - with-optimized-slots - with-standard-instance-slots - - map-all-classes - finalize-all-classes - - updater - record-updater)) -) - -(defclass updater () - ((dependent :initarg :dependent :reader dependent))) - -(defun record-updater (class dependee dependent &rest initargs) - (let ((updater - (apply #'make-instance class :dependent dependent initargs))) - (add-dependent dependee updater) - updater)) - - -(defun finalize-all-classes (&optional (root-name t)) - "Makes sure that all classes are finalized. If Root-Name is supplied, - then finalizes Root-Name and all of its subclasses and their subclasses." - (map-all-classes (lambda (class) - (unless (class-finalized-p class) - (finalize-inheritance class))) - root-name)) - - -;;; -;;; -;;; - - -(defmacro slot-value-from-index (instance wrapper slot-name slots index) - "Returns instance's slot-value given slot-name's index." - (ext:once-only ((index index)) - `(if ,index - (let ((val (%svref ,slots ,index))) - (if (eq val +slot-unbound+) - (slot-unbound (wrapper-class ,wrapper) ,instance ,slot-name) - val)) - (if *safe-to-use-slot-value-wrapper-optimizations-p* - (get-class-slot-value-1 ,instance ,wrapper ,slot-name) - (accessor-slot-value ,instance ,slot-name))))) - -(defmacro set-slot-value-from-index - (instance wrapper slot-name slots index new-value) - "Sets instance's slot-value to new-value given slot-name's index." - (ext:once-only ((index index)) - `(if ,index - (setf (%svref ,slots ,index) ,new-value) - (if *safe-to-use-set-slot-value-wrapper-optimizations-p* - (set-class-slot-value-1 ,instance ,wrapper ,slot-name ,new-value) - (setf (accessor-slot-value ,instance ,slot-name) ,new-value))))) - -(defsetf slot-value-from-index set-slot-value-from-index) - -(defmacro with-slots-slot-value-from-index - (instance wrapper slot-name slots index variable-instance) - "Returns instance's slot-value given slot-name's index." - (cond - ((consp wrapper) - `(let ((wrapper ,wrapper)) - (unless (eq (wrapper-state wrapper) t) - (setf wrapper (wrapper-state-trap wrapper ,instance))) - (with-slots-slot-value-from-index - ,instance wrapper ,slot-name ,slots ,index ,variable-instance))) - (variable-instance - `(let ((,instance ,variable-instance)) - (with-slots-slot-value-from-index - ,instance ,wrapper ,slot-name ,slots ,index NIL))) - (T `(slot-value-from-index ,instance ,wrapper ,slot-name ,slots ,index)))) - -(defmacro set-with-slots-slot-value-from-index - (instance wrapper slot-name slots index variable-instance new-value) - "Sets instance's slot-value to new-value given slot-name's index." - (cond - ((consp wrapper) - `(let ((wrapper ,wrapper)) - (unless (eq (wrapper-state wrapper) t) - (setf wrapper (wrapper-state-trap wrapper ,instance))) - (set-with-slots-slot-value-from-index - ,instance wrapper ,slot-name ,slots ,index ,variable-instance - ,new-value))) - (variable-instance - `(let ((,instance ,variable-instance)) - (set-with-slot-slots-value-from-index - ,instance ,wrapper ,slot-name ,slots ,index NIL ,new-value))) - (T - `(setf (slot-value-from-index ,instance ,wrapper ,slot-name ,slots ,index) - ,new-value)))) - -(defsetf with-slots-slot-value-from-index - set-with-slots-slot-value-from-index) - -(defmacro with-slots-slot-value-from-wrapper-and-slots - (instance slot-name wrapper slots-layout slots variable-instance) - (cond - (variable-instance - `(let ((,instance ,variable-instance)) - (with-slots-slot-value-from-wrapper-and-slots - ,instance ,slot-name ,wrapper ,slots-layout ,slots NIL))) - ((consp wrapper) - `(if *safe-to-use-slot-value-wrapper-optimizations-p* - (let ((wrapper ,wrapper)) - (unless (eq (wrapper-state wrapper) t) - (setf wrapper (wrapper-state-trap wrapper ,instance))) - (slot-value-from-wrapper-and-slots ,instance ,slot-name - wrapper ,slots-layout ,slots NIL)) - (accessor-slot-value ,instance ,slot-name))) - (T - `(if *safe-to-use-slot-value-wrapper-optimizations-p* - (slot-value-from-wrapper-and-slots - ,instance ,slot-name ,wrapper ,slots-layout ,slots NIL) - (accessor-slot-value ,instance ,slot-name))))) - -(defmacro set-with-slots-slot-value-from-wrapper-and-slots - (instance slot-name wrapper slots-layout slots variable-instance new-value) - (cond - (variable-instance - `(let ((,instance ,variable-instance)) - (set-with-slots-slot-value-from-wrapper-and-slots - ,instance ,slot-name ,wrapper ,slots-layout ,slots NIL ,new-value))) - ((consp wrapper) - `(if *safe-to-use-set-slot-value-wrapper-optimizations-p* - (let ((wrapper ,wrapper)) - (unless (eq (wrapper-state wrapper) t) - (setf wrapper (wrapper-state-trap wrapper ,instance))) - (setf (slot-value-from-wrapper-and-slots ,instance ,slot-name - wrapper ,slots-layout ,slots NIL) - ,new-value)) - (setf (accessor-slot-value ,instance ,slot-name) ,new-value))) - (T - `(if *safe-to-use-set-slot-value-wrapper-optimizations-p* - (setf (slot-value-from-wrapper-and-slots - ,instance ,slot-name ,wrapper ,slots-layout ,slots NIL) - ,new-value) - (setf (accessor-slot-value ,instance ,slot-name) ,new-value))))) - -(defsetf with-slots-slot-value-from-wrapper-and-slots - set-with-slots-slot-value-from-wrapper-and-slots) - -(defun tree-memq-p (item form) - (cond ((consp form) - (or (tree-memq-p item (car form)) - (tree-memq-p item (cdr form)))) - (T (eq item form)))) - -(defmacro with-optimized-slots (slot-entries instance-form &body body) - "Optimized version of With-Slots that is faster because it factors out - functions common to all slot accesses on the instance. It has two - extensions to With-Slots: (1) the second value of slot-entries are - evaluated as forms rather than considered to be hard slot-names, allowing - access of variable slot-names. (2) if a :variable-instance keyword is - the first part of the body, then the instance-form is treated as a variable - form, which is always expected to return an instance of the same class. - The value of the keyword must be an instance that is the same class as - instance-form will always return." - ;; E.g. (with-optimized-slots (foo-slot - ;; (foo-slot-accessor 'foo-slot) - ;; (variable-slot-accessor variable-slot)) - ;; instance - ;; :instance-form (car instances-of-same-class) - ;; (loop for instance in objects-of-same-class - ;; as variable-slot in variable-slots - ;; collect (list foo-slot - ;; foo-slot-accessor - ;; variable-slot-accessor))) - ;; ==> (loop for instance in objects-of-same-class - ;; as variable-slot in variable-slots - ;; collect (list (slot-value instance 'foo-slot) - ;; (slot-value instance 'foo-slot) - ;; (slot-value instance variable-slot))) - (build-with-optimized-slots-form slot-entries instance-form body)) - -(defmacro with-standard-instance-slots (slot-entries instance-form &body body) - "Optimized version of With-Slots that assumes that the instance-form - evaluates to a standard-instance. The result is undefined if it does not. - With-standard-instance-slots is faster than With-Slots because it factors - out functions common to all slot accesses on the instance. It has two - extensions to With-Slots: (1) the second value of slot-entries are - evaluated as forms rather than considered to be hard slot-names, allowing - access of variable slot-names. (2) if a :variable-instance keyword is - the first part of the body, then the instance-form is treated as a variable - form, which is always expected to return an instance of the same class. - The value of the keyword must be an instance that is the same class as - instance-form will always return." - (build-with-optimized-slots-form slot-entries instance-form body 'std-instance)) - -(defun build-with-optimized-slots-form (slot-entries instance-form body - &optional instance-type) - (let* ((variable-instance - (if (eq (car body) :variable-instance) - (prog1 - (cadr body) - (setf body (cddr body))))) - (hard-accessors - (let ((collect NIL)) - (dolist (slot-entry slot-entries (nreverse collect)) - (when (and (symbolp slot-entry) - (tree-memq-p slot-entry body)) - (push (cons slot-entry slot-entry) collect)) - (when (and (consp slot-entry) - (constantp (second slot-entry)) - (tree-memq-p (car slot-entry) body)) - (push (cons (car slot-entry) (second (second slot-entry))) - collect))))) - (variable-accessors - (let ((collect NIL)) - (dolist (slot-entry slot-entries (nreverse collect)) - (when (and (consp slot-entry) - (not (constantp (second slot-entry))) - (tree-memq-p (car slot-entry) body)) - (push slot-entry collect)))))) - (if *safe-to-use-slot-wrapper-optimizations-p* - (build-maybe-safe-w-o-s-v hard-accessors variable-accessors - instance-form body variable-instance - instance-type) - (build-with-accessor-s-v hard-accessors variable-accessors - instance-form body variable-instance)))) - -(defun build-maybe-safe-w-o-s-v (hard-accessors variable-accessors - instance-form body variable-instance - instance-type) - (let* ((instance-string - (if (symbolp instance-form) (symbol-name instance-form) "")) - (instance-form-var - (if (and variable-instance (simple-eval-access-p instance-form)) - instance-form - (gensym - (concatenate 'simple-string instance-string "-INSTANCE-FORM")))) - (prototype-form - (if variable-instance - (if (simple-eval-access-p variable-instance) - variable-instance - (gensym (concatenate 'simple-string "VARIABLE-INSTANCE" - instance-string))) - instance-form-var)) - (wrapper-var - (gensym (concatenate 'simple-string instance-string "-WRAPPER"))) - (slots-var - (unless variable-instance - (gensym (concatenate 'simple-string instance-string "-SLOTS")))) - (type-var - (when (and variable-instance (not instance-type)) - (gensym (concatenate 'simple-string instance-string "-TYPE")))) - (type-var-std 1) - (type-var-fsc 2) - #+pcl-user-instances - (type-var-user 3) - (slot-index-vars - (mapcar (lambda (slot-entry) - (list (car slot-entry) - (cdr slot-entry) - (gensym (concatenate - 'simple-string - (if (string= instance-string "") - "INSTANCE-FORM-" - instance-string) - (symbol-name (cdr slot-entry)) - "-INDEX")))) - (remove-duplicates hard-accessors :key #'cdr))) - (slots-layout-var - (gensym (concatenate 'simple-string "SLOTS-LAYOUT-" instance-string))) - (runtime-slots-form - (if variable-instance - (ecase instance-type - (std-instance `(std-instance-slots ,instance-form-var)) - (fsc-instance `(fsc-instance-slots ,instance-form-var)) - #+pcl-user-instances - (user-instance `(get-user-instance-slots ,instance-form-var)) - ((nil) - `(case ,type-var - (,type-var-std (std-instance-slots ,instance-form-var)) - (,type-var-fsc (fsc-instance-slots ,instance-form-var)) - #+pcl-user-instances - (,type-var-user (get-user-instance-slots ,instance-form-var))))) - slots-var)) - (runtime-wrapper-form - (if variable-instance - (ecase instance-type - (std-instance `(std-instance-wrapper ,instance-form-var)) - (fsc-instance `(fsc-instance-wrapper ,instance-form-var)) - #+pcl-user-instances - (user-instance `(get-user-instance-wrapper ,instance-form-var)) - ((nil) - `(case ,type-var - (,type-var-std (std-instance-wrapper ,instance-form-var)) - (,type-var-fsc (fsc-instance-wrapper ,instance-form-var)) - #+pcl-user-instances - (,type-var-user (get-user-instance-wrapper ,instance-form-var))))) - wrapper-var))) - (declare (type simple-string instance-string) - (type list slot-index-vars)) - `(let (,@(unless variable-instance - `((,instance-form-var ,instance-form))) - ,@(when (and variable-instance - (not (eq prototype-form variable-instance))) - `((,prototype-form ,variable-instance))) - ,wrapper-var ,slots-layout-var - ,@(if variable-instance - (if type-var `((type-var 0))) - (list slots-var)) - ,@(mapcar #'third slot-index-vars)) - ,@(when type-var `((declare (type index ,type-var)))) - (when *safe-to-use-slot-wrapper-optimizations-p* - ,@(ecase instance-type - (std-instance - `((setf ,wrapper-var (std-instance-wrapper ,prototype-form)) - ,@(unless variable-instance - `((setf ,slots-var (std-instance-slots ,prototype-form)))))) - (fsc-instance - `((setf ,wrapper-var (fsc-instance-wrapper ,prototype-form)) - ,@(unless variable-instance - `((setf ,slots-var (fsc-instance-slots ,prototype-form)))))) - #+pcl-user-instances - (user-instance - `((setf ,wrapper-var (get-user-instance-wrapper ,prototype-form)) - ,@(unless variable-instance - `((setf ,slots-var (get-user-instance-slots ,prototype-form)))))) - ((nil) - `((cond - ((std-instance-p ,prototype-form) - (setf ,wrapper-var (std-instance-wrapper ,prototype-form)) - ,(if variable-instance - `(setf ,type-var ,type-var-std) - `(setf ,slots-var (std-instance-slots ,prototype-form)))) - ((fsc-instance-p ,prototype-form) - (setf ,wrapper-var (fsc-instance-wrapper ,prototype-form)) - ,(if variable-instance - `(setf ,type-var ,type-var-fsc) - `(setf ,slots-var (fsc-instance-slots ,prototype-form)))) - #+pcl-user-instances - ((get-user-instance-p ,prototype-form) - (setf ,wrapper-var (get-user-instance-wrapper ,prototype-form)) - ,(if variable-instance - `(setf ,type-var ,type-var-user) - `(setf ,slots-var (get-user-instance-slots ,prototype-form)))))))) - ,@(if instance-type - (build-w-s-v-find-slot-indices wrapper-var slots-layout-var - prototype-form slot-index-vars) - `((when ,wrapper-var - ,@(build-w-s-v-find-slot-indices wrapper-var slots-layout-var - prototype-form slot-index-vars))))) - (symbol-macrolet - (,@(mapcar - (lambda (slot-cons) - `(,(car slot-cons) - (with-slots-slot-value-from-index - ,instance-form-var - ,runtime-wrapper-form - ',(cdr slot-cons) - ,runtime-slots-form - ,(third (assoc (car slot-cons) slot-index-vars - :test #'eq)) - ,(when (and variable-instance - (not (eq variable-instance - instance-form-var))) - variable-instance)))) - hard-accessors) - ,@(mapcar - (lambda (variable-cons) - `(,(car variable-cons) - (with-slots-slot-value-from-wrapper-and-slots - ,instance-form-var - ,(second variable-cons) - ,runtime-wrapper-form - ,slots-layout-var - ,runtime-slots-form - ,(when (and variable-instance - (not (eq variable-instance - instance-form-var))) - variable-instance)))) - variable-accessors)) - ,@body)))) - -(defun build-w-s-v-find-slot-indices (wrapper-var slots-layout-var - prototype-form - slot-index-vars) - (declare (type list slot-index-vars)) - `((unless (eq (wrapper-state ,wrapper-var) t) - (setf ,wrapper-var - (wrapper-state-trap ,wrapper-var ,prototype-form))) - (setf ,slots-layout-var (wrapper-instance-slots-layout ,wrapper-var)) - ,@(if (<= (length slot-index-vars) 2) - (mapcar - (lambda (slot-cons) - `(setf ,(third slot-cons) - (instance-slot-index-from-slots-layout - ,slots-layout-var ',(second slot-cons)))) - slot-index-vars) - ;; More than two slots, so more efficient to search slots-layout-var - ;; only once, rather than once for each with instance-slot-index. - (labels - ((build-comps (slot-vars index) - (if slot-vars - `(if (eq slot-name ',(second (car slot-vars))) - (progn - (setf ,(third (car slot-vars)) ,index) - (if (= matches ,(1- (length slot-index-vars))) - (go end-loop) - (setf matches (the fixnum (1+ matches))))) - ,(build-comps (cdr slot-vars) index))))) - `((block nil - (let ((slots-left ,slots-layout-var) - (slot-name NIL) - (index 0) - (matches 0)) - (declare (type fixnum index matches)) - (when slots-left - (tagbody - begin-instance-slots-loop - (setf slot-name (car slots-left)) - ,(build-comps slot-index-vars 'index) - (setf index (the fixnum (1+ index))) - (if (null (setf slots-left (cdr slots-left))) - (go end-loop)) - (go begin-instance-slots-loop) - end-loop))))))))) - -(defun build-with-accessor-s-v (hard-accessors variable-accessors - instance-form body variable-instance) - ;; Build the body for with-optimized-slot-value when it is unsafe - ;; and accessor-slot-value must be used. - (let ((instance-form-var - (if variable-instance instance-form (gensym "INSTANCE-FORM")))) - `(let (,@(unless variable-instance - `((,instance-form-var ,instance-form)))) - (symbol-macrolet - (,@(mapcar - (lambda (slot-cons) - `(,(car slot-cons) - (accessor-slot-value ,instance-form-var - ',(cdr slot-cons)))) - hard-accessors) - ,@(mapcar - (lambda (variable-cons) - `(,(car variable-cons) - (accessor-slot-value ,instance-form-var - ,(second variable-cons)))) - variable-accessors)) - ,@body)))) - -(export *extensions-exports* *the-pcl-package*) - - diff --git a/pcl/fast-init.lisp b/pcl/fast-init.lisp deleted file mode 100644 index bcd9554e2..000000000 --- a/pcl/fast-init.lisp +++ /dev/null @@ -1,947 +0,0 @@ -;;; -*- Mode: LISP; Package: PCL -*- -;;; -;;; ************************************************************************* -;;; 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. -;;; ************************************************************************* -;;; - -(ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/Attic/fast-init.lisp,v 1.13 2002/11/28 16:23:33 pmai Exp $") -;;; -;;; This file defines the optimized make-instance functions. -;;; - -(in-package :pcl) - -(defvar *compile-make-instance-functions-p* nil) - -(defun update-make-instance-function-table (&optional (class *the-class-t*)) - (when (symbolp class) (setq class (find-class class))) - (when (eq class *the-class-t*) (setq class *the-class-slot-object*)) - (when (memq *the-class-slot-object* (class-precedence-list class)) - (map-all-classes #'reset-class-initialize-info class))) - -(defun constant-symbol-p (form) - (and (constantp form) - (let ((object (eval form))) - (and (symbolp object) - (symbol-package object))))) - -(defvar *make-instance-function-keys* nil) - -(defun expand-make-instance-form (form) - (let ((class (cadr form)) (initargs (cddr form)) - (keys nil)(allow-other-keys-p nil) key value) - (when (and (constant-symbol-p class) - (let ((initargs-tail initargs)) - (loop (when (null initargs-tail) (return t)) - (unless (constant-symbol-p (car initargs-tail)) - (return nil)) - (setq key (eval (pop initargs-tail))) - (setq value (pop initargs-tail)) - (when (eq :allow-other-keys key) - (setq allow-other-keys-p value)) - (push key keys)))) - (let* ((class (eval class)) - (keys (nreverse keys)) - (key (list class keys allow-other-keys-p)) - (sym (make-instance-function-symbol key))) - (push key *make-instance-function-keys*) - (when sym - (progn ;; Lifted from c::%%defun. - (c::define-function-name sym) - (when (eq (ext:info function where-from sym) :assumed) - (setf (ext:info function where-from sym) :defined) - (when (ext:info function assumed-type sym) - (setf (ext:info function assumed-type sym) nil)))) - `(,sym ',class (list ,@initargs))))))) - - - -(defmacro expanding-make-instance-top-level (&rest forms &environment env) - (let* ((*make-instance-function-keys* nil) - (form (macroexpand `(expanding-make-instance ,@forms) env))) - `(progn - ,@(when *make-instance-function-keys* - `((get-make-instance-functions ',*make-instance-function-keys*))) - ,form))) - -(defmacro expanding-make-instance (&rest forms &environment env) - `(progn - ,@(mapcar (lambda (form) - (walk-form form env - (lambda (subform context env) - (declare (ignore env)) - (or (and (eq context :eval) - (consp subform) - (eq (car subform) 'make-instance) - (expand-make-instance-form subform)) - subform)))) - forms))) - -(defmacro defconstructor - (name class lambda-list &rest initialization-arguments) - `(expanding-make-instance-top-level - (defun ,name ,lambda-list - (make-instance ',class ,@initialization-arguments)))) - -(defun get-make-instance-functions (key-list) - (dolist (key key-list) - (let* ((cell (find-class-cell (car key))) - (make-instance-function-keys - (find-class-cell-make-instance-function-keys cell)) - (mif-key (cons (cadr key) (caddr key)))) - (unless (find mif-key make-instance-function-keys - :test #'equal) - (push mif-key (find-class-cell-make-instance-function-keys cell)) - (let ((class (find-class-cell-class cell))) - (when (and class (not (forward-referenced-class-p class))) - (update-initialize-info-internal - (initialize-info class (car mif-key) nil (cdr mif-key)) - 'make-instance-function))))))) - -(defun make-instance-function-symbol (key) - (let* ((class (car key)) - (symbolp (symbolp class))) - (when (or symbolp (classp class)) - (let* ((class-name (if (symbolp class) class (class-name class))) - (keys (cadr key)) - (allow-other-keys-p (caddr key))) - (when (and (or symbolp - (and (symbolp class-name) - (eq class (find-class class-name nil)))) - (symbol-package class-name)) - (let ((*package* *the-pcl-package*) - (*print-length* nil) (*print-level* nil) - (*print-circle* nil) (*print-case* :upcase) - (*print-pretty* nil)) - (intern (format nil "MAKE-INSTANCE ~A::~A ~S ~S" - (package-name (symbol-package class-name)) - (symbol-name class-name) - keys - allow-other-keys-p)))))))) - -(defun make-instance-1 (class initargs) - (apply #'make-instance class initargs)) - -(defmacro define-cached-reader (type name trap) - (let ((reader-name (intern (format nil "~A-~A" type name))) - (cached-name (intern (format nil "~A-CACHED-~A" type name)))) - `(defmacro ,reader-name (info) - `(let ((value (,',cached-name ,info))) - (if (eq value :unknown) - (progn - (,',trap ,info ',',name) - (,',cached-name ,info)) - value))))) - -(eval-when (:compile-toplevel :load-toplevel :execute) -(defparameter initialize-info-cached-slots - '(valid-p ; t or (:invalid key) - ri-valid-p - initargs-form-list - new-keys - default-initargs-function - shared-initialize-t-function - shared-initialize-nil-function - constants - combined-initialize-function ; allocate-instance + shared-initialize - make-instance-function ; nil means use gf - make-instance-function-symbol))) - -(defmacro define-initialize-info () - (let ((cached-slot-names - (mapcar (lambda (name) - (intern (format nil "CACHED-~A" name))) - initialize-info-cached-slots)) - (cached-names - (mapcar (lambda (name) - (intern (format nil "~A-CACHED-~A" - 'initialize-info name))) - initialize-info-cached-slots))) - `(progn - (defstruct initialize-info - key wrapper - ,@(mapcar (lambda (name) - `(,name :unknown)) - cached-slot-names)) - (defmacro reset-initialize-info-internal (info) - `(progn - ,@(mapcar (lambda (cname) - `(setf (,cname ,info) :unknown)) - ',cached-names))) - (defun initialize-info-bound-slots (info) - (let ((slots nil)) - ,@(mapcar (lambda (name cached-name) - `(unless (eq :unknown (,cached-name info)) - (push ',name slots))) - initialize-info-cached-slots cached-names) - slots)) - ,@(mapcar (lambda (name) - `(define-cached-reader initialize-info ,name - update-initialize-info-internal)) - initialize-info-cached-slots)))) - -(define-initialize-info) - -(defvar *initialize-info-cache-class* nil) -(defvar *initialize-info-cache-initargs* nil) -(defvar *initialize-info-cache-info* nil) - -(defvar *revert-initialize-info-p* nil) - -(defun reset-initialize-info (info) - (setf (initialize-info-wrapper info) - (class-wrapper (car (initialize-info-key info)))) - (let ((slots-to-revert (if *revert-initialize-info-p* - (initialize-info-bound-slots info) - '(make-instance-function)))) - (reset-initialize-info-internal info) - (dolist (slot slots-to-revert) - (update-initialize-info-internal info slot)) - info)) - -(defun reset-class-initialize-info (class) - (reset-class-initialize-info-1 (class-initialize-info class))) - -(defun reset-class-initialize-info-1 (cell) - (when (consp cell) - (when (car cell) - (reset-initialize-info (car cell))) - (let ((alist (cdr cell))) - (dolist (a alist) - (reset-class-initialize-info-1 (cdr a)))))) - -(defun initialize-info (class initargs &optional (plist-p t) allow-other-keys-arg) - (let ((info nil)) - (if (and (eq *initialize-info-cache-class* class) - (eq *initialize-info-cache-initargs* initargs)) - (setq info *initialize-info-cache-info*) - (let ((initargs-tail initargs) - (cell (or (class-initialize-info class) - (setf (class-initialize-info class) (cons nil nil))))) - (loop (when (null initargs-tail) (return nil)) - (let ((keyword (pop initargs-tail)) - (alist-cell cell)) - (when plist-p - (if (eq keyword :allow-other-keys) - (setq allow-other-keys-arg (pop initargs-tail)) - (pop initargs-tail))) - (loop (let ((alist (cdr alist-cell))) - (when (null alist) - (setq cell (cons nil nil)) - (setf (cdr alist-cell) (list (cons keyword cell))) - (return nil)) - (when (eql keyword (caar alist)) - (setq cell (cdar alist)) - (return nil)) - (setq alist-cell alist))))) - (setq info (or (car cell) - (setf (car cell) (make-initialize-info)))))) - (let ((wrapper (initialize-info-wrapper info))) - (unless (eq wrapper (class-wrapper class)) - (unless wrapper - (let* ((initargs-tail initargs) - (klist-cell (list nil)) - (klist-tail klist-cell)) - (loop (when (null initargs-tail) (return nil)) - (let ((key (pop initargs-tail))) - (setf (cdr klist-tail) (list key))) - (setf klist-tail (cdr klist-tail)) - (when plist-p (pop initargs-tail))) - (setf (initialize-info-key info) - (list class (cdr klist-cell) allow-other-keys-arg)))) - (reset-initialize-info info))) - (setq *initialize-info-cache-class* class) - (setq *initialize-info-cache-initargs* initargs) - (setq *initialize-info-cache-info* info) - info)) - -(defun update-initialize-info-internal (info name) - (let* ((key (initialize-info-key info)) - (class (car key)) - (keys (cadr key)) - (allow-other-keys-arg (caddr key))) - (ecase name - ((initargs-form-list new-keys) - (multiple-value-bind (initargs-form-list new-keys) - (make-default-initargs-form-list class keys) - (setf (initialize-info-cached-initargs-form-list info) initargs-form-list) - (setf (initialize-info-cached-new-keys info) new-keys))) - ((default-initargs-function) - (let ((initargs-form-list (initialize-info-initargs-form-list info))) - (setf (initialize-info-cached-default-initargs-function info) - (initialize-instance-simple-function - 'default-initargs-function info - class initargs-form-list)))) - ((valid-p ri-valid-p) - (flet ((compute-valid-p (methods) - (or (not (null allow-other-keys-arg)) - (multiple-value-bind (legal allow-other-keys) - (check-initargs-values class methods) - (or (not (null allow-other-keys)) - (dolist (key keys t) - (unless (member key legal) - (return (cons :invalid key))))))))) - (let ((proto (class-prototype class))) - (setf (initialize-info-cached-valid-p info) - (compute-valid-p - (list (list* 'allocate-instance class nil) - (list* 'initialize-instance proto nil) - (list* 'shared-initialize proto t nil)))) - (setf (initialize-info-cached-ri-valid-p info) - (compute-valid-p - (list (list* 'reinitialize-instance proto nil) - (list* 'shared-initialize proto nil nil))))))) - ((shared-initialize-t-function) - (multiple-value-bind (initialize-form-list ignore) - (make-shared-initialize-form-list class keys t nil) - (declare (ignore ignore)) - (setf (initialize-info-cached-shared-initialize-t-function info) - (initialize-instance-simple-function - 'shared-initialize-t-function info - class initialize-form-list)))) - ((shared-initialize-nil-function) - (multiple-value-bind (initialize-form-list ignore) - (make-shared-initialize-form-list class keys nil nil) - (declare (ignore ignore)) - (setf (initialize-info-cached-shared-initialize-nil-function info) - (initialize-instance-simple-function - 'shared-initialize-nil-function info - class initialize-form-list)))) - ((constants combined-initialize-function) - (let ((initargs-form-list (initialize-info-initargs-form-list info)) - (new-keys (initialize-info-new-keys info))) - (multiple-value-bind (initialize-form-list constants) - (make-shared-initialize-form-list class new-keys t t) - (setf (initialize-info-cached-constants info) constants) - (setf (initialize-info-cached-combined-initialize-function info) - (initialize-instance-simple-function - 'combined-initialize-function info - class (append initargs-form-list initialize-form-list)))))) - ((make-instance-function-symbol) - (setf (initialize-info-cached-make-instance-function-symbol info) - (make-instance-function-symbol key))) - ((make-instance-function) - (let* ((function (get-make-instance-function key)) - (symbol (initialize-info-make-instance-function-symbol info))) - (setf (initialize-info-cached-make-instance-function info) function) - (when symbol (setf (gdefinition symbol) - (or function #'make-instance-1))))))) - info) - -(defun get-make-instance-function (key) - (let* ((class (car key)) - (keys (cadr key))) - (unless (eq *boot-state* 'complete) - (return-from get-make-instance-function nil)) - (when (symbolp class) - (setq class (find-class class))) - (when (classp class) - (unless (class-finalized-p class) (finalize-inheritance class))) - (let* ((initargs (mapcan (lambda (key) (list key nil)) keys)) - (class-and-initargs (list* class initargs)) - (make-instance (gdefinition 'make-instance)) - (make-instance-methods - (compute-applicable-methods make-instance class-and-initargs)) - (std-mi-meth (find-standard-ii-method make-instance-methods 'class)) - (class+initargs (list class initargs)) - (default-initargs (gdefinition 'default-initargs)) - (default-initargs-methods - (compute-applicable-methods default-initargs class+initargs)) - (proto (and (classp class) (class-prototype class))) - (initialize-instance-methods - (when proto - (compute-applicable-methods (gdefinition 'initialize-instance) - (list* proto initargs)))) - (shared-initialize-methods - (when proto - (compute-applicable-methods (gdefinition 'shared-initialize) - (list* proto t initargs))))) - (when (null make-instance-methods) - (return-from get-make-instance-function - (lambda (class initargs) - (apply #'no-applicable-method make-instance class initargs)))) - (unless (and (null (cdr make-instance-methods)) - (eq (car make-instance-methods) std-mi-meth) - (null (cdr default-initargs-methods)) - (eq (car (method-specializers (car default-initargs-methods))) - *the-class-slot-class*) - (flet ((check-meth (meth) - (let ((quals (method-qualifiers meth))) - (if (null quals) - (eq (car (method-specializers meth)) - *the-class-slot-object*) - (and (null (cdr quals)) - (or (eq (car quals) :before) - (eq (car quals) :after))))))) - (and (every #'check-meth initialize-instance-methods) - (every #'check-meth shared-initialize-methods)))) - (return-from get-make-instance-function nil)) - (get-make-instance-function-internal - class key (default-initargs class initargs) - initialize-instance-methods shared-initialize-methods)))) - -(defun get-make-instance-function-internal (class key initargs - initialize-instance-methods - shared-initialize-methods) - (let* ((keys (cadr key)) - (allow-other-keys-p (caddr key)) - (allocate-instance-methods - (compute-applicable-methods (gdefinition 'allocate-instance) - (list* class initargs)))) - (unless allow-other-keys-p - (unless (check-initargs-1 - class initargs - (append allocate-instance-methods - initialize-instance-methods - shared-initialize-methods) - t nil) - (return-from get-make-instance-function-internal nil))) - (if (or (cdr allocate-instance-methods) - (some #'complicated-instance-creation-method - initialize-instance-methods) - (some #'complicated-instance-creation-method - shared-initialize-methods)) - (make-instance-function-complex - key class keys - initialize-instance-methods shared-initialize-methods) - (make-instance-function-simple - key class keys - initialize-instance-methods shared-initialize-methods)))) - -(defun complicated-instance-creation-method (m) - (let ((qual (method-qualifiers m))) - (if qual - (not (and (null (cdr qual)) (eq (car qual) :after))) - (let ((specl (car (method-specializers m)))) - (or (not (classp specl)) - (not (eq 'slot-object (class-name specl)))))))) - -(defun find-standard-ii-method (methods class-names) - (dolist (m methods) - (when (null (method-qualifiers m)) - (let ((specl (car (method-specializers m)))) - (when (and (classp specl) - (if (listp class-names) - (member (class-name specl) class-names) - (eq (class-name specl) class-names))) - (return m)))))) - -(defmacro call-initialize-function (initialize-function instance initargs) - `(let ((.function. ,initialize-function)) - (if (and (consp .function.) - (eq (car .function.) 'call-initialize-instance-simple)) - (initialize-instance-simple (cadr .function.) (caddr .function.) - ,instance ,initargs) - (funcall (the function .function.) ,instance ,initargs)))) - -(defun make-instance-function-simple (key class keys - initialize-instance-methods - shared-initialize-methods) - (multiple-value-bind (initialize-function constants) - (get-simple-initialization-function class keys (caddr key)) - (let* ((wrapper (class-wrapper class)) - (lwrapper (list wrapper)) - (allocate-function - (cond ((structure-class-p class) - #'allocate-structure-instance) - ((standard-class-p class) - #'allocate-standard-instance) - ((funcallable-standard-class-p class) - #'allocate-funcallable-instance) - (t - (error "error in make-instance-function-simple")))) - (std-si-meth (find-standard-ii-method shared-initialize-methods - 'slot-object)) - (shared-initfns - (nreverse (mapcar (lambda (method) - (make-effective-method-function - #'shared-initialize - `(call-method ,method nil) - nil lwrapper)) - (remove std-si-meth shared-initialize-methods)))) - (std-ii-meth (find-standard-ii-method initialize-instance-methods - 'slot-object)) - (initialize-initfns - (nreverse (mapcar (lambda (method) - (make-effective-method-function - #'initialize-instance - `(call-method ,method nil) - nil lwrapper)) - (remove std-ii-meth - initialize-instance-methods))))) - (lambda (class1 initargs) - (if (not (eq wrapper (class-wrapper class))) - (let* ((info (initialize-info (coerce-to-class class1) initargs)) - (fn (initialize-info-make-instance-function info))) - (declare (type function fn)) - (funcall fn class1 initargs)) - (let* ((instance (funcall allocate-function wrapper constants)) - (initargs (call-initialize-function initialize-function - instance initargs))) - (dolist (fn shared-initfns) - (invoke-effective-method-function fn t instance t initargs)) - (dolist (fn initialize-initfns) - (invoke-effective-method-function fn t instance initargs)) - instance)))))) - -(defun make-instance-function-complex (key class keys - initialize-instance-methods - shared-initialize-methods) - (multiple-value-bind (initargs-function initialize-function) - (get-complex-initialization-functions class keys (caddr key)) - (let* ((wrapper (class-wrapper class)) - (shared-initialize - (get-secondary-dispatch-function - #'shared-initialize shared-initialize-methods - `((class-eq ,class) t t) - `((,(find-standard-ii-method shared-initialize-methods 'slot-object) - ,(lambda (instance init-type &rest initargs) - (declare (ignore init-type)) - (call-initialize-function initialize-function - instance initargs) - instance))) - (list wrapper *the-wrapper-of-t* *the-wrapper-of-t*))) - (initialize-instance - (get-secondary-dispatch-function - #'initialize-instance initialize-instance-methods - `((class-eq ,class) t) - `((,(find-standard-ii-method initialize-instance-methods 'slot-object) - ,(lambda (instance &rest initargs) - (invoke-effective-method-function - shared-initialize t instance t initargs)))) - (list wrapper *the-wrapper-of-t*)))) - (lambda (class1 initargs) - (if (not (eq wrapper (class-wrapper class))) - (let* ((info (initialize-info (coerce-to-class class1) initargs)) - (fn (initialize-info-make-instance-function info))) - (declare (type function fn)) - (funcall fn class1 initargs)) - (let* ((initargs (call-initialize-function initargs-function - nil initargs)) - (instance (apply #'allocate-instance class initargs))) - (invoke-effective-method-function - initialize-instance t instance initargs) - instance)))))) - -(defun get-simple-initialization-function (class keys &optional allow-other-keys-arg) - (let ((info (initialize-info class keys nil allow-other-keys-arg))) - (values (initialize-info-combined-initialize-function info) - (initialize-info-constants info)))) - -(defun get-complex-initialization-functions (class keys &optional allow-other-keys-arg - separate-p) - (let* ((info (initialize-info class keys nil allow-other-keys-arg)) - (default-initargs-function (initialize-info-default-initargs-function info))) - (if separate-p - (values default-initargs-function - (initialize-info-shared-initialize-t-function info)) - (values default-initargs-function - (initialize-info-shared-initialize-t-function - (initialize-info class (initialize-info-new-keys info) - nil allow-other-keys-arg)))))) - -(defun add-forms (forms forms-list) - (when forms - (setq forms (copy-list forms)) - (if (null (car forms-list)) - (setf (car forms-list) forms) - (setf (cddr forms-list) forms)) - (setf (cdr forms-list) (last forms))) - (car forms-list)) - -(defun make-default-initargs-form-list (class keys &optional (separate-p t)) - (let ((initargs-form-list (cons nil nil)) - (default-initargs (class-default-initargs class)) - (nkeys keys) - (slots-alist - (mapcan (lambda (slot) - (mapcar (lambda (arg) - (cons arg slot)) - (slot-definition-initargs slot))) - (class-slots class))) - (nslots nil)) - (dolist (key nkeys) - (pushnew (cdr (assoc key slots-alist)) nslots)) - (dolist (default default-initargs) - (let* ((key (car default)) - (slot (cdr (assoc key slots-alist))) - (function (cadr default))) - (unless (member slot nslots) - (add-forms `((funcall ,function) (push-initarg ,key)) - initargs-form-list) - (push key nkeys) - (push slot nslots)))) - (when separate-p - (add-forms `((update-initialize-info-cache - ,class ,(initialize-info class nkeys nil))) - initargs-form-list)) - (add-forms `((finish-pushing-initargs)) - initargs-form-list) - (values (car initargs-form-list) nkeys))) - -(defun make-shared-initialize-form-list (class keys si-slot-names simple-p) - (let* ((initialize-form-list (cons nil nil)) - (type (cond ((structure-class-p class) - 'structure) - ((standard-class-p class) - 'standard) - ((funcallable-standard-class-p class) - 'funcallable) - (t (error "error in make-shared-initialize-form-list")))) - (wrapper (class-wrapper class)) - (constants (when simple-p - (make-list (wrapper-no-of-instance-slots wrapper) - :initial-element +slot-unbound+))) - (slots (class-slots class)) - (slot-names (mapcar #'slot-definition-name slots)) - (slots-key (mapcar (lambda (slot) - (let ((index most-positive-fixnum)) - (dolist (key (slot-definition-initargs slot)) - (let ((pos (position key keys))) - (when pos (setq index (min index pos))))) - (cons slot index))) - slots)) - (slots (stable-sort slots-key #'< :key #'cdr))) - (let ((n-popped 0)) - (dolist (slot+index slots) - (let* ((slot (car slot+index)) - (name (slot-definition-name slot)) - (npop (1+ (- (cdr slot+index) n-popped)))) - (unless (eql (cdr slot+index) most-positive-fixnum) - (let* ((pv-offset (1+ (position name slot-names)))) - (add-forms `(,@(when (plusp npop) - `((pop-initargs ,(* 2 npop)))) - (instance-set ,pv-offset ,slot)) - initialize-form-list)) - (incf n-popped npop))))) - (dolist (slot+index slots) - (let* ((slot (car slot+index)) - (name (slot-definition-name slot))) - (when (and (eql (cdr slot+index) most-positive-fixnum) - (or (eq si-slot-names t) - (member name si-slot-names))) - (let* ((initform (slot-definition-initform slot)) - (initfunction (slot-definition-initfunction slot)) - (location (unless (eq type 'structure) - (slot-definition-location slot))) - (pv-offset (1+ (position name slot-names))) - (forms (cond ((null initfunction) - nil) - ((constantp initform) - (let ((value (funcall initfunction))) - (if (and simple-p (integerp location)) - (progn (setf (nth location constants) value) - nil) - `((const ,value) - (instance-set ,pv-offset ,slot))))) - (t - `((funcall ,(slot-definition-initfunction slot)) - (instance-set ,pv-offset ,slot)))))) - (add-forms `(,@(unless (or simple-p (null forms)) - `((skip-when-instance-boundp ,pv-offset ,slot - ,(length forms)))) - ,@forms) - initialize-form-list))))) - (values (car initialize-form-list) constants))) - -(defvar *class-pv-table-table* (make-hash-table :test 'eq)) - -(defun get-pv-cell-for-class (class) - (let* ((slot-names (mapcar #'slot-definition-name (class-slots class))) - (slot-name-lists (list (cons nil slot-names))) - (pv-table (gethash class *class-pv-table-table*))) - (unless (and pv-table - (equal slot-name-lists (pv-table-slot-name-lists pv-table))) - (setq pv-table (intern-pv-table :slot-name-lists slot-name-lists)) - (setf (gethash class *class-pv-table-table*) pv-table)) - (pv-table-lookup pv-table (class-wrapper class)))) - -(defvar *initialize-instance-simple-alist* nil) -(defvar *note-iis-entry-p* nil) - -(defvar *compiled-initialize-instance-simple-functions* - (make-hash-table :test #'equal)) - -(defun initialize-instance-simple-function (use info class form-list) - (let* ((pv-cell (get-pv-cell-for-class class)) - (key (initialize-info-key info)) - (sf-key (list* use (class-name (car key)) (cdr key)))) - (if (or *compile-make-instance-functions-p* - (gethash sf-key *compiled-initialize-instance-simple-functions*)) - (multiple-value-bind (form args) - (form-list-to-lisp pv-cell form-list) - (let ((entry (assoc form *initialize-instance-simple-alist* - :test #'equal))) - (setf (gethash sf-key - *compiled-initialize-instance-simple-functions*) - t) - (if entry - (setf (cdddr entry) (union (list sf-key) (cdddr entry) - :test #'equal)) - (progn - (setq entry (list* form nil nil (list sf-key))) - (setq *initialize-instance-simple-alist* - (nconc *initialize-instance-simple-alist* - (list entry))))) - (unless (or *note-iis-entry-p* (cadr entry)) - (setf (cadr entry) (compile-lambda (car entry)))) - (if (cadr entry) - (apply (the function (cadr entry)) args) - `(call-initialize-instance-simple ,pv-cell ,form-list)))) - #|| - (lambda (instance initargs) - (initialize-instance-simple pv-cell form-list instance initargs)) - ||# - `(call-initialize-instance-simple ,pv-cell ,form-list)))) - -(defun load-precompiled-iis-entry (form function system uses) - (let ((entry (assoc form *initialize-instance-simple-alist* - :test #'equal))) - (unless entry - (setq entry (list* form nil nil nil)) - (setq *initialize-instance-simple-alist* - (nconc *initialize-instance-simple-alist* - (list entry)))) - (setf (cadr entry) function) - (setf (caddr entry) system) - (dolist (use uses) - (setf (gethash use *compiled-initialize-instance-simple-functions*) t)) - (setf (cdddr entry) (union uses (cdddr entry) - :test #'equal)))) - -(defmacro precompile-iis-functions (&optional system) - (let ((index -1)) - `(progn - ,@(let ((collected ())) - (dolist (iis-entry *initialize-instance-simple-alist* - (nreverse collected)) - (when (or (null (caddr iis-entry)) - (eq (caddr iis-entry) system)) - (when system - (setf (caddr iis-entry) system)) - (push - (make-top-level-form - `(precompile-initialize-instance-simple ,system ,(incf index)) - '(load) - `(load-precompiled-iis-entry - ',(car iis-entry) - #',(car iis-entry) - ',system - ',(cdddr iis-entry))) - collected))))))) - -(defun compile-iis-functions (after-p) - (let ((*compile-make-instance-functions-p* t) - (*revert-initialize-info-p* t) - (*note-iis-entry-p* (not after-p))) - (declare (special *compile-make-instance-functions-p*)) - (when (eq *boot-state* 'complete) - (update-make-instance-function-table)))) - - -;(const const) -;(funcall function) -;(push-initarg const) -;(pop-supplied count) ; a positive odd number -;(instance-set pv-offset slotd) -;(skip-when-instance-boundp pv-offset slotd n) - -(defun initialize-instance-simple (pv-cell form-list instance initargs) - (let ((pv (car pv-cell)) - (initargs-tail initargs) - (slots (get-slots-or-nil instance)) - (class (class-of instance)) - value) - (loop (when (null form-list) (return nil)) - (let ((form (pop form-list))) - (ecase (car form) - (push-initarg - (push value initargs) - (push (cadr form) initargs)) - (const - (setq value (cadr form))) - (funcall - (setq value (funcall (the function (cadr form))))) - (pop-initargs - (setq initargs-tail (nthcdr (1- (cadr form)) initargs-tail)) - (setq value (pop initargs-tail))) - (instance-set - (instance-write-internal - pv slots (cadr form) value - (setf (slot-value-using-class class instance (caddr form)) value))) - (skip-when-instance-boundp - (when (instance-boundp-internal - pv slots (cadr form) - (slot-boundp-using-class class instance (caddr form))) - (dotimes (i (cadddr form)) - (declare (fixnum i)) - (pop form-list)))) - (update-initialize-info-cache - (when (consp initargs) - (setq initargs (cons (car initargs) (cdr initargs)))) - (setq *initialize-info-cache-class* (cadr form)) - (setq *initialize-info-cache-initargs* initargs) - (setq *initialize-info-cache-info* (caddr form))) - (finish-pushing-initargs - (setq initargs-tail initargs))))) - initargs)) - -(defun add-to-cvector (cvector constant) - (or (position constant cvector) - (prog1 (fill-pointer cvector) - (vector-push-extend constant cvector)))) - -(defvar *inline-iis-instance-locations-p* t) - -(defun first-form-to-lisp (forms cvector pv) - (flet ((const (constant) - (cond ((or (numberp constant) (characterp constant)) - constant) - ((and (symbolp constant) (symbol-package constant)) - `',constant) - (t - `(svref cvector ,(add-to-cvector cvector constant)))))) - (let ((form (pop (car forms)))) - (ecase (car form) - (push-initarg - `((push value initargs) - (push ,(const (cadr form)) initargs))) - (const - `((setq value ,(const (cadr form))))) - (funcall - `((setq value (funcall (the function ,(const (cadr form))))))) - (pop-initargs - `((setq initargs-tail (,@(let ((pop (1- (cadr form)))) - (case pop - (1 `(cdr)) - (3 `(cdddr)) - (t `(nthcdr ,pop)))) - initargs-tail)) - (setq value (pop initargs-tail)))) - (instance-set - (let* ((pv-offset (cadr form)) - (location (pvref pv pv-offset)) - (default `(setf (slot-value-using-class class instance - ,(const (caddr form))) - value))) - (if *inline-iis-instance-locations-p* - (typecase location - (fixnum `((setf (%instance-ref slots ,(const location)) value))) - (cons `((setf (cdr ,(const location)) value))) - (t `(,default))) - `((instance-write-internal pv slots ,(const pv-offset) value - ,default - ,(typecase location - (fixnum :instance) - (cons :class) - (t :default))))))) - (skip-when-instance-boundp - (let* ((pv-offset (cadr form)) - (location (pvref pv pv-offset)) - (default `(slot-boundp-using-class class instance - ,(const (caddr form))))) - `((unless ,(if *inline-iis-instance-locations-p* - (typecase location - (fixnum `(not (eq (%instance-ref slots ,(const location)) - +slot-unbound+))) - (cons `(not (eq (cdr ,(const location)) +slot-unbound+))) - (t default)) - `(instance-boundp-internal pv slots ,(const pv-offset) - ,default - ,(typecase (pvref pv pv-offset) - (fixnum :instance) - (cons :class) - (t :default)))) - ,@(let ((sforms (cons nil nil))) - (dotimes (i (cadddr form) (car sforms)) - (add-forms (first-form-to-lisp forms cvector pv) - sforms))))))) - (update-initialize-info-cache - `((when (consp initargs) - (setq initargs (cons (car initargs) (cdr initargs)))) - (setq *initialize-info-cache-class* ,(const (cadr form))) - (setq *initialize-info-cache-initargs* initargs) - (setq *initialize-info-cache-info* ,(const (caddr form))))) - (finish-pushing-initargs - `((setq initargs-tail initargs))))))) - -(defmacro iis-body (&body forms) - `(let ((initargs-tail initargs) - (slots (get-slots-or-nil instance)) - (class (class-of instance)) - (pv (car pv-cell)) - value) - initargs instance initargs-tail pv cvector slots class value - ,@forms)) - -(defun form-list-to-lisp (pv-cell form-list) - (let* ((forms (list form-list)) - (cvector (make-array (floor (length form-list) 2) - :fill-pointer 0 :adjustable t)) - (pv (car pv-cell)) - (body (let ((rforms (cons nil nil))) - (loop (when (null (car forms)) (return (car rforms))) - (add-forms (first-form-to-lisp forms cvector pv) - rforms)))) - (cvector-type `(simple-vector ,(length cvector)))) - (values - `(lambda (pv-cell cvector) - (declare (type ,cvector-type cvector)) - (lambda (instance initargs) - (declare #.*optimize-speed*) - (iis-body ,@body) - initargs)) - (list pv-cell (coerce cvector cvector-type))))) - - -;The effect of this is to cause almost all of the overhead of make-instance -;to happen at load time (or maybe at precompile time, as explained in a -;previous message) rather than the first time make-instance is called with -;a given class-name and sequence of keywords. - -;This optimization applys only when the first argument and all the even -;numbered arguments are constants evaluating to interned symbols. - -(declaim (ftype (function (t) symbol) get-make-instance-function-symbol)) - -; Use this definition in any CL implementation supporting -; both define-compiler-macro and load-time-value. -(define-compiler-macro make-instance (&whole form &rest args) - (declare (ignore args)) - (let* ((*make-instance-function-keys* nil) - (expanded-form (expand-make-instance-form form))) - (if expanded-form - `(funcall (symbol-function - ;; The symbol is guaranteed to be fbound. - ;; Is there a way to declare this? - (load-time-value - (get-make-instance-function-symbol - ',(first *make-instance-function-keys*)))) - ,@(cdr expanded-form)) - form))) - -(defun get-make-instance-function-symbol (key) - (get-make-instance-functions (list key)) - (make-instance-function-symbol key)) diff --git a/pcl/fin.lisp b/pcl/fin.lisp index 257338f48..2693762c5 100644 --- a/pcl/fin.lisp +++ b/pcl/fin.lisp @@ -23,10 +23,9 @@ ;;; ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* -;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/fin.lisp,v 1.19 2002/11/28 00:51:35 pmai Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/fin.lisp,v 1.20 2003/03/22 16:15:16 gerd Exp $") ;;; ;; @@ -113,8 +112,8 @@ explicitly marked saying who wrote it. (declaim (notinline called-fin-without-function)) (defun called-fin-without-function (&rest args) (declare (ignore args)) - (error "Attempt to funcall a funcallable-instance without first~%~ - setting its funcallable-instance-function.")) + (error "~@<Attempt to funcall a funcallable instance without first ~ + setting its function.~@:>")) ;;;; Implementation of funcallable instances for CMU Common Lisp: @@ -138,9 +137,6 @@ explicitly marked saying who wrote it. ;; Hash code. (hash-code (get-instance-hash-code) :type fixnum)) -(defmacro fsc-instance-hash-code (fin) - `(kernel:%funcallable-instance-info ,fin 2)) - ;;; Note: returns true for non-pcl funcallable structures. (import 'kernel:funcallable-instance-p) @@ -167,14 +163,5 @@ explicitly marked saying who wrote it. (defmacro fsc-instance-slots (fin) `(kernel:%funcallable-instance-info ,fin 0)) -;;; Implement proper sxhashing of standard instances. -(defun common-lisp::sxhash-instance (instance) - (cond - ((and (std-instance-p instance) - (typep (std-instance-wrapper instance) 'wrapper)) - (std-instance-hash-code instance)) - ((and (fsc-instance-p instance) - (typep (fsc-instance-wrapper instance) 'wrapper)) - (fsc-instance-hash-code instance)) - (t - 42))) +(defmacro fsc-instance-hash (fin) + `(kernel:%funcallable-instance-info ,fin 2)) diff --git a/pcl/fixup.lisp b/pcl/fixup.lisp index 71b18edfc..f8c365b06 100644 --- a/pcl/fixup.lisp +++ b/pcl/fixup.lisp @@ -23,12 +23,15 @@ ;;; ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* -;;; (in-package :pcl) -(fix-early-generic-functions) -(setq *boot-state* 'complete) +#-loadable-pcl +(progn + (/show "Fixing generic functions") + (fix-early-generic-functions) + (/show "PCL boot state COMPLETE") + (setq *boot-state* 'complete)) (defun print-std-instance (instance stream depth) (declare (ignore depth)) diff --git a/pcl/fngen.lisp b/pcl/fngen.lisp index 34c34a27c..a00a49806 100644 --- a/pcl/fngen.lisp +++ b/pcl/fngen.lisp @@ -23,11 +23,9 @@ ;;; ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* -;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/fngen.lisp,v 1.9 2002/08/26 02:23:14 pmai Exp $") -;;; + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/fngen.lisp,v 1.10 2003/03/22 16:15:16 gerd Exp $") (in-package :pcl) @@ -56,20 +54,15 @@ ;;; Whether the returned function is actually compiled depends on whether ;;; the compiler is present (see COMPILE-LAMBDA) and whether this shape of ;;; code was precompiled. -;;; -(defun get-function (lambda - &optional (test-converter #'default-test-converter) - (code-converter #'default-code-converter) - (constant-converter #'default-constant-converter)) - (function-apply (get-function-generator lambda test-converter code-converter) - (compute-constants lambda constant-converter))) - -(defun get-function1 (lambda - &optional (test-converter #'default-test-converter) - (code-converter #'default-code-converter) - (constant-converter #'default-constant-converter)) - (values (the function (get-function-generator lambda test-converter code-converter)) - (compute-constants lambda constant-converter))) +;;; + +(defun get-function1 (lambda &optional + (test-converter #'default-test-converter) + (code-converter #'default-code-converter) + (constant-converter #'default-constant-converter)) + (values (the function (get-function-generator lambda test-converter + code-converter)) + (compute-constants lambda constant-converter))) (defun default-constantp (form) (and (constantp form) @@ -91,6 +84,13 @@ nil)) +(defstruct (fgen (:constructor %make-fgen)) + test + gensyms + generator + generator-lambda + system) + ;;; ;;; *fgens* is a list of all the function generators we have so far. Each ;;; element is a FGEN structure as implemented below. Don't ever touch this @@ -98,31 +98,20 @@ ;;; (defvar *fgens* ()) +(defun lookup-fgen (test) + (find test (the list *fgens*) :key #'fgen-test :test #'equal)) + (defun store-fgen (fgen) (let ((old (lookup-fgen (fgen-test fgen)))) (if old - (setf (svref old 2) (fgen-generator fgen) - (svref old 4) (or (svref old 4) - (fgen-system fgen))) + (setf (fgen-generator old) (fgen-generator fgen) + (fgen-system old) (or (fgen-system old) + (fgen-system fgen))) (setq *fgens* (nconc *fgens* (list fgen)))))) -(defun lookup-fgen (test) - (find test (the list *fgens*) :key #'fgen-test :test #'equal)) - (defun make-fgen (test gensyms generator generator-lambda system) - (let ((new (make-array 6))) - (setf (svref new 0) test - (svref new 1) gensyms - (svref new 2) generator - (svref new 3) generator-lambda - (svref new 4) system) - new)) - -(defun fgen-test (fgen) (svref fgen 0)) -(defun fgen-gensyms (fgen) (svref fgen 1)) -(defun fgen-generator (fgen) (svref fgen 2)) -(defun fgen-generator-lambda (fgen) (svref fgen 3)) -(defun fgen-system (fgen) (svref fgen 4)) + (%make-fgen :test test :gensyms gensyms :generator generator + :generator-lambda generator-lambda :system system)) @@ -146,7 +135,6 @@ (compute-code lambda code-converter) (values gensyms `(lambda ,gensyms (function ,code))))) - (defun compute-test (lambda test-converter) (let ((walk-form-expand-macros-p t)) (walk-form lambda @@ -169,7 +157,8 @@ f (multiple-value-bind (converted gens) (funcall code-converter f) - (when gens (setq gensyms (append gensyms gens))) + (when gens + (setq gensyms (append gensyms gens))) (values converted (neq converted f)))))) gensyms))) @@ -201,11 +190,11 @@ (when (or (null (fgen-system fgen)) (eq (fgen-system fgen) system)) (when system - (setf (svref fgen 4) system)) + (setf (fgen-system fgen) system)) (push (make-top-level-form `(precompile-function-generators ,system ,(incf index)) - '(load) + '(:load-toplevel) `(load-function-generator ',(fgen-test fgen) ',(fgen-gensyms fgen) diff --git a/pcl/fsc.lisp b/pcl/fsc.lisp index 24671eb11..434b20ff3 100644 --- a/pcl/fsc.lisp +++ b/pcl/fsc.lisp @@ -23,10 +23,9 @@ ;;; ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* -;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/fsc.lisp,v 1.10 2002/08/27 19:01:39 pmai Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/fsc.lisp,v 1.11 2003/03/22 16:15:16 gerd Exp $") ;;; ;;; This file contains the definition of the FUNCALLABLE-STANDARD-CLASS ;;; metaclass. Much of the implementation of this metaclass is actually @@ -77,28 +76,3 @@ slot-name) (make-std-writer-method-function (class-name class) slot-name)) -;;;; -;;;; See the comment about reader-function--std and writer-function--sdt. -;;;; -;(define-function-template reader-function--fsc () '(slot-name) -; `(function -; (lambda (instance) -; (slot-value-using-class (wrapper-class (get-wrapper instance)) -; instance -; slot-name)))) -; -;(define-function-template writer-function--fsc () '(slot-name) -; `(function -; (lambda (nv instance) -; (setf -; (slot-value-using-class (wrapper-class (get-wrapper instance)) -; instance -; slot-name) -; nv)))) -; -;(eval-when (:load-toplevel) -; (pre-make-templated-function-constructor reader-function--fsc) -; (pre-make-templated-function-constructor writer-function--fsc)) - - - diff --git a/pcl/generic-functions.lisp b/pcl/generic-functions.lisp index 74229192e..2e3536ba5 100644 --- a/pcl/generic-functions.lisp +++ b/pcl/generic-functions.lisp @@ -1,8 +1,7 @@ ;;;-*-Mode:LISP; Package:PCL; Base:10; Syntax:Common-lisp -*- -;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/generic-functions.lisp,v 1.17 2003/01/03 18:50:23 pmai Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/generic-functions.lisp,v 1.18 2003/03/22 16:15:16 gerd Exp $") ;;; (in-package :pcl) @@ -51,9 +50,6 @@ ; (short-method-combination) ; (t) -(defgeneric long-method-combination-p (object)) -; (long-method-combination) -; (t) (defgeneric slot-class-p (object)) ; (t) ; (slot-class) @@ -141,9 +137,6 @@ (defgeneric eql-specializer-object (eql-specializer)) ; (eql-specializer) -(defgeneric generic-function-declarations (standard-generic-function)) -; (standard-generic-function) - (defgeneric generic-function-method-class (standard-generic-function)) ; (standard-generic-function) @@ -278,9 +271,6 @@ (defgeneric (setf generic-function-method-combination) (new-value standard-generic-function)) ; (t standard-generic-function) -(defgeneric (setf generic-function-declarations) (new-value standard-generic-function)) -; (t standard-generic-function) - (defgeneric (setf generic-function-methods) (new-value standard-generic-function)) ; (t standard-generic-function) @@ -406,6 +396,8 @@ ; (structure-class) ; :around (structure-class) +(defgeneric default-initargs (class initargs defaults)) + (defgeneric finalize-inheritance (class)) ; (structure-class) ; (std-class) @@ -506,9 +498,6 @@ ; (funcallable-standard-object funcallable-standard-class) ; (t symbol) -(defgeneric class-slot-value (class slot-name)) -; (std-class t) - (defgeneric compatible-meta-class-change-p (class proto-new-class)) ; (t t) @@ -525,9 +514,6 @@ ; (slot-class t) ; :around (structure-class t) -(defgeneric default-initargs (class supplied-initargs)) -; (slot-class t) - (defgeneric describe-object (object stream)) ; (class t) ; (standard-generic-function t) @@ -582,6 +568,7 @@ ; (dependent-update-mixin t) (defgeneric no-next-method (generic-function method &rest args)) +(defgeneric no-primary-method (generic-function &rest args)) ;(defgeneric maybe-update-constructors (generic-function method)) ; (generic-function method) @@ -664,9 +651,6 @@ (defgeneric add-writer-method (class generic-function slot-name)) ; (slot-class t t) -(defgeneric (setf class-slot-value) (nv class slot-name)) -; (t std-class t) - ;;; ;;; According to AMOP, COMPUTE-EFFECTIVE-METHOD should return two ;;; values. Alas, the second value is only vaguely described in AMOP, @@ -675,9 +659,7 @@ ;;; COMPUTE-EFFECTIVE-METHOD returns one value as do Allegro and ;;; Lispworks. ;;; - -(defgeneric compute-effective-method - (generic-function combin applicable-methods)) +(defgeneric compute-effective-method (generic-function combin applicable-methods)) ; (generic-function long-method-combination t) ; (generic-function short-method-combination t) ; (generic-function standard-method-combination t) @@ -772,8 +754,6 @@ (defgeneric no-applicable-method (generic-function &rest args)) ; (t) -(defgeneric no-primary-method (generic-function &rest args)) - (defgeneric reader-method-class (class direct-slot &rest initargs)) ; (slot-class t) diff --git a/pcl/gf-call-optimization.lisp b/pcl/gf-call-optimization.lisp new file mode 100644 index 000000000..e83a28796 --- /dev/null +++ b/pcl/gf-call-optimization.lisp @@ -0,0 +1,212 @@ +;;; Copyright (C) 2003 Gerd Moellmann <gerd.moellmann@t-online.de> +;;; All rights reserved. +;;; +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: +;;; +;;; 1. Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. +;;; 2. Redistributions in binary form must reproduce the above copyright +;;; notice, this list of conditions and the following disclaimer in the +;;; documentation and/or other materials provided with the distribution. +;;; 3. The name of the author may not be used to endorse or promote +;;; products derived from this software without specific prior written +;;; permission. +;;; +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE +;;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +;;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT +;;; OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR +;;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE +;;; USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH +;;; DAMAGE. + +(ext:file-comment "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/gf-call-optimization.lisp,v 1.2 2003/03/22 16:15:16 gerd Exp $") + +(in-package "PCL") + +;;; *************************************************** +;;; General Generic Function Call Optimization ******* +;;; *************************************************** +;;; +;;; This optimizes calls to generic functions to calls of effective +;;; method functions, which are stored in the pv-table cache of a +;;; method. +;;; +;;; Each method has a pv table associated with it, whose cache maps +;;; the wrappers of actual method arguments to pv-cells. The cdr of +;;; these pv-cells is a vector of effective methods, one for each +;;; pv-optimized generic function call in the pv-table's call-list. +;;; The local variable .CALLS. is bound to the call vector in a method +;;; function. + +(defvar *optimize-gf-calls-p* t) + +(defmacro callsref (call-vector i) + `(%svref ,call-vector ,i)) + +(define-walker-template call-optimization-barrier) +(defmacro call-optimization-barrier (x) x) + +(defun optimize-gf-call (form required-method-parameters calls env) + (flet ((make-call-optimization-barrier (form) + `(,(first form) (call-optimization-barrier ,(second form)) + ,@(cddr form))) + (call-optimization-barrier-p (form) + (let ((arg (second form))) + (and (consp arg) (eq 'call-optimization-barrier (car arg)))))) + (when (and *optimize-gf-calls-p* + (eq *boot-state* 'complete) + (not (eq 'apply (first form))) + (not (call-optimization-barrier-p form))) + (let ((call (make-pv-call form required-method-parameters env))) + (when call + (let ((entry (assoc call calls :test #'equal)) + (pv-offset-form (list 'pv-offset -1))) + (when (null entry) + (push (setq entry (cons call nil)) (cdr calls))) + (push pv-offset-form (cdr entry)) + ;; + (let* ((nreq (length (cdr call))) + (gf-info (gf-info (car call))) + ;; + ;; According to MAKE-FAST-METHOD-CALL-LAMBDA-LIST, a + ;; fast method function has a rest arg if the generic + ;; function's applyp flag is set. + (rest-p (gf-info-applyp gf-info)) + (rest (when rest-p (nthcdr nreq (cdr form)))) + (required-args (when rest-p (ldiff (cdr form) rest)))) + (setq form + `(let ((.emf. (callsref .calls. ,pv-offset-form))) + (declare #.*optimize-speed*) + (cond ((fast-method-call-p .emf.) + ,@(if rest-p + `((invoke-fast-method-call + .emf. ,@required-args + (list ,@rest))) + `((invoke-fast-method-call + .emf. ,@(cdr form))))) + (.emf. + (funcall (lambda (&rest args) + (invoke-emf .emf. args)) + ,@(cdr form))) + (t + ,(make-call-optimization-barrier form)))))))))) + form)) + +;;; +;;; Value is NIL if FORM is not optimizable. Otherwise, a list +;;; (GF-NAME <pos0> <pos1> ...) is returned. GF-NAME is the name of +;;; the generic function being called, and each <posN> is the index of +;;; a method parameter used as argument N to the generic function. +;;; +(defun make-pv-call (form required-method-parameters env) + (let* ((gf-name (first form)) + (gf-info (gf-info gf-name)) + (nreq (gf-info-nreq gf-info))) + (labels (;; + ;; If VAR is the name of a required method parameter, or a + ;; variable rebinding of a required method parameter, + ;; return the method parameter's name. Otherwise return + ;; NIL. + (method-parameter (var) + (when (and (consp var) (eq 'the (car var))) + (setq var (caddr var))) + (when (symbolp var) + (let ((rebound (caddr (variable-declaration + 'variable-rebinding var env)))) + (car (memq (or rebound var) required-method-parameters))))) + ;; + ;; If VAR is the name of a specialized method parameter, + ;; or a rebinding of it, return the method parameter's name, + ;; otherwise return NIL. + (specialized-method-parameter (var) + (let ((param (method-parameter var))) + (when param + (let ((cname (caddr (variable-declaration 'class param + env)))) + (when (and cname (not (eq t cname))) + param)))))) + ;; + ;; Check the generic function call argument list. If all + ;; arguments are required method parameter, and no method + ;; parameter is used more than once, we can optimize the call. + ;; Method parameters may not appear twice in the argument list + ;; because we can only have one wrapper for each method + ;; parameter the pv-table cache. + (unless (case nreq + ((1 2) (info-accessor-p gf-name)) + (t nil)) + (loop with optimizable-p = t + for arg in (rest form) and i below nreq + as param = (specialized-method-parameter arg) + as pos = (and param (posq param required-method-parameters)) + when (or (null param) (member pos posns)) do + (setq optimizable-p nil) + (loop-finish) + collect pos into posns + finally + (return (and optimizable-p (cons gf-name posns)))))))) + +(defun compute-calls (table call-list all-method-wrappers) + (unwind-protect + (progn + ;; + ;; Small quirk here: set this flag so that GET-METHOD-FUNCTION + ;; won't try to use the PV cache while it's being computed. + (setf (pv-table-computing-cache-p table) t) + (loop for call in call-list + collect (compute-call call all-method-wrappers) into emfs + finally (return (make-array (length emfs) :initial-contents emfs)))) + (setf (pv-table-computing-cache-p table) nil))) + +(defun compute-call (call all-method-wrappers) + (let ((gf-name (car call))) + ;; + ;; We have to check that GF-NAME is actually a generic function + ;; here. There can concievably be cases where GF-NAME appears to + ;; be a generic function when files are compiled, but isn't, or + ;; isn't yet, when compiled files are loaded. + (when (and (fboundp gf-name) + (generic-function-p (gdefinition gf-name))) + (loop with all-wrappers = + (if (atom all-method-wrappers) + (list all-method-wrappers) + all-method-wrappers) + with gf = (gdefinition gf-name) + for wrapper-index in (cdr call) + as wrapper = (nth wrapper-index all-wrappers) + as class = (wrapper-class* wrapper) + as type = `(class-eq ,class) + collect wrapper into wrappers + collect class into classes + collect type into types + finally + (return (cache-miss-values-internal gf (gf-arg-info gf) + wrappers classes types + 'caching)))))) + +(defun update-pv-calls-for-gf (gf &optional gf-removed-p) + (when (eq *boot-state* 'complete) + (let ((call-key `(call ,(generic-function-name gf)))) + (do-pv-tables (table call-key) + (let ((cache (pv-table-cache table))) + (when cache + (map-cache (lambda (wrappers pv-cell) + (let ((call-vector (cdr pv-cell))) + (do-pv-calls (call index table) + (setf (callsref call-vector index) + (if gf-removed-p + nil + (compute-call call wrappers)))))) + cache)))) + (when gf-removed-p + (remhash call-key *pv-key->pv-tables*))))) + +;;; end of gf-call-optimization.lisp diff --git a/pcl/gray-streams-class.lisp b/pcl/gray-streams-class.lisp index 6d66b8570..a5fd6f221 100644 --- a/pcl/gray-streams-class.lisp +++ b/pcl/gray-streams-class.lisp @@ -3,8 +3,9 @@ ;;; This code was written by Douglas T. Crosher and has been placed in ;;; the Public domain, and is provided 'as is'. ;;; + (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/gray-streams-class.lisp,v 1.3 2003/02/24 10:04:11 emarsden Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/gray-streams-class.lisp,v 1.4 2003/03/22 16:15:16 gerd Exp $") ;;; ;;; ********************************************************************** ;;; @@ -31,25 +32,31 @@ (defclass fundamental-binary-stream (fundamental-stream) ()) -(defclass fundamental-character-input-stream - (fundamental-input-stream fundamental-character-stream) ()) +(defclass fundamental-character-input-stream (fundamental-input-stream + fundamental-character-stream) + ()) -(defclass fundamental-character-output-stream - (fundamental-output-stream fundamental-character-stream) ()) +(defclass fundamental-character-output-stream (fundamental-output-stream + fundamental-character-stream) + ()) -(defclass fundamental-binary-input-stream - (fundamental-input-stream fundamental-binary-stream) ()) +(defclass fundamental-binary-input-stream (fundamental-input-stream + fundamental-binary-stream) + ()) -(defclass fundamental-binary-output-stream - (fundamental-output-stream fundamental-binary-stream) ()) +(defclass fundamental-binary-output-stream (fundamental-output-stream + fundamental-binary-stream) + ()) ;;; Example character input and output streams. (defclass character-output-stream (fundamental-character-output-stream) - ((lisp-stream :initarg :lisp-stream - :accessor character-output-stream-lisp-stream))) + ((lisp-stream + :initarg :lisp-stream + :accessor character-output-stream-lisp-stream))) (defclass character-input-stream (fundamental-character-input-stream) - ((lisp-stream :initarg :lisp-stream - :accessor character-input-stream-lisp-stream))) + ((lisp-stream + :initarg :lisp-stream + :accessor character-input-stream-lisp-stream))) diff --git a/pcl/gray-streams.lisp b/pcl/gray-streams.lisp index 13451d121..1373236e8 100644 --- a/pcl/gray-streams.lisp +++ b/pcl/gray-streams.lisp @@ -3,8 +3,9 @@ ;;; This code was written by Douglas T. Crosher and has been placed in ;;; the Public domain, and is provided 'as is'. ;;; + (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/gray-streams.lisp,v 1.8 2002/10/09 14:19:11 pmai Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/gray-streams.lisp,v 1.9 2003/03/22 16:15:16 gerd Exp $") ;;; ;;; ********************************************************************** ;;; @@ -95,9 +96,6 @@ t) -(eval-when (:compile-toplevel) - (pushnew 'compile pcl::*defgeneric-times*)) - ;;; Character input streams. ;;; ;;; A character input stream can be created by defining a class that diff --git a/pcl/herald.lisp b/pcl/herald.lisp new file mode 100644 index 000000000..369d49989 --- /dev/null +++ b/pcl/herald.lisp @@ -0,0 +1,8 @@ +(in-package "PCL") + +#+(or loadable-pcl bootable-pcl) +(progn + (defvar *pcl-system-date* "$Date: 2003/03/22 16:15:16 $") + (setf (getf ext:*herald-items* :pcl) + `(" CLOS based on Gerd's PCL " ,(subseq *pcl-system-date* 7 26)))) + diff --git a/pcl/info.lisp b/pcl/info.lisp new file mode 100644 index 000000000..8be50ad2f --- /dev/null +++ b/pcl/info.lisp @@ -0,0 +1,702 @@ +;;; Copyright (C) 2002, 2003 Gerd Moellmann <gerd.moellmann@t-online.de> +;;; All rights reserved. +;;; +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: +;;; +;;; 1. Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. +;;; 2. Redistributions in binary form must reproduce the above copyright +;;; notice, this list of conditions and the following disclaimer in the +;;; documentation and/or other materials provided with the distribution. +;;; 3. The name of the author may not be used to endorse or promote +;;; products derived from this software without specific prior written +;;; permission. +;;; +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE +;;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +;;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT +;;; OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR +;;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE +;;; USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH +;;; DAMAGE. + +;;; The function SPLIT-DECLARATION appeared first in Xerox PCL +;;; vector.lisp, and was moved here for concentrating all declaration +;;; stuff. See vector.lisp for Xerox' copyright and license. + +;;; To Do +;;; +;;; GF is actually non-accessor GF. Clean this up. +;;; (setf symbol-value) should be handled like (setf fdefinition) + +(ext:file-comment "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/info.lisp,v 1.2 2003/03/22 16:15:16 gerd Exp $") + +(in-package "PCL") + +(defstruct class-info + ;; + ;; List of SLOT-INFO structures for each slot. + (slots () :type list) + ;; + ;; The class' metaclass. + (metaclass nil :type symbol) + ;; + ;; List of slot reader and writer function names. + (accessors () :type list) + ;; + ;; Slot access optimization info. + (slot-access () :type list)) + + +(defstruct slot-info + (name nil :type symbol) + ;; + ;; Specified slot allocation.or :INSTANCE. + (allocation :instance :type (member :class :instance)) + ;; + ;; Specified slot type or T. + (type t :type (or symbol list))) + + +(defstruct gf-info + ;; + ;; Number of required parameters. + (nreq 0 :type fixnum) + ;; + ;; True if this generic function has key, optional, or rest parameters. + (applyp nil :type boolean) + ;; + ;; READER if this generic function has a slot reader method. + ;; WRITER if this gf has a slot writer method. + ;; NIL if this is an ordinary generic function. + (type nil :type (member nil reader writer)) + ;; + ;; List of class names for slot accessor. A class C occurring in + ;; this list means that this is a slot accessor for some slot of C. + (classes () :type list) + ;; + ;; Alist of AUTO-COMPILE declaration infos for methods. Keys are + ;; (QUALIFIER* SPECIALIZERS), value is T or NIL for do or don't + ;; auto-compile. + (auto-compile () :type list) + ;; + ;; The default auto-compilation policy used for methods of this + ;; generic function which don't have explicit entries in + ;; AUTO-COMPILE. T means auto-compile, NIL don't auto-compile, + ;; MAYBE means use the global default. + (auto-compile-default 'maybe :type (member t nil maybe))) + +(defstruct seal-info + (seals () :type list)) + +;;; +;;; Declare some new INFO type, under class PCL, plus nicer accessors. +;;; +(ext:define-info-class pcl) +(ext:define-info-type pcl class (or null class-info) nil) +(ext:define-info-type pcl gf (or null gf-info) nil) +(ext:define-info-type pcl seal (or null seal-info) nil) + +(declaim (inline class-info (setf class-info) + gf-info (setf gf-info) + seal-info (setf seal-info))) + +(defun class-info (class-name) + (ext:info pcl class class-name)) + +(defun (setf class-info) (new-value class-name) + (setf (ext:info pcl class class-name) new-value)) + +(defun class-info-or-make (class-name) + (let ((info (class-info class-name))) + (or info + (setf (class-info class-name) (make-class-info))))) + +(defun gf-info (gf-name) + (ext:info pcl gf gf-name)) + +(defun (setf gf-info) (new-value gf-name) + (setf (ext:info pcl gf gf-name) new-value)) + +(defun gf-info-or-make (gf-name) + (let ((info (gf-info gf-name))) + (or info + (setf (gf-info gf-name) (make-gf-info))))) + +(defun seal-info (name) + (ext:info pcl seal name)) + +(defun (setf seal-info) (new-value name) + (setf (ext:info pcl seal name) new-value)) + +(defun seal-info-or-make (name) + (let ((info (seal-info name))) + (or info + (setf (seal-info name) (make-seal-info))))) + + +;;; ****************** +;;; Classes ******** +;;; ****************** + +;;; +;;; Set compile-time info for class CLASS-NAME. Called from +;;; EXPAND-DEFCLASS. +;;; +;;; METACLASS is the metaclass of the declared class. SLOTS is a +;;; list of slot specs as they appear in DEFCLASS. +;;; +(defun set-class-info (class-name metaclass slots) + (let ((readers ()) + (writers ()) + (slot-infos ()) + (class-info (class-info class-name))) + (when class-info + (loop for a in (class-info-accessors class-info) + as info = (gf-info a) + when info do + ;; INFO can be NIL when the accessor has been redefined + ;; as an ordinary function. + (setf (gf-info-classes info) + (delete class-name (gf-info-classes info))))) + ;; + (dolist (slot slots) + (typecase slot + (list + (loop for (key value) on (cdr slot) by #'cddr do + (case key + (:reader + (push value readers)) + (:writer + (push value writers)) + (:accessor + (push value readers) + (push `(setf ,value) writers)))) + (push (make-slot-info + :name (car slot) + :allocation (getf (cdr slot) :allocation :instance) + :type (getf (cdr slot) :type t)) + slot-infos)) + (t + (push (make-slot-info :name slot) slot-infos)))) + ;; + (setf (class-info class-name) + (make-class-info + :slots (nreverse slot-infos) + :accessors (append readers writers) + :metaclass metaclass + :slot-access (and class-info + (class-info-slot-access class-info)))) + ;; + (flet ((add-class (accessors type) + (loop for a in accessors as info = (gf-info a) + if (null info) do + (setf (gf-info a) + (make-gf-info :nreq (ecase type + (reader 1) + (writer 2)) + :applyp nil + :classes (list class-name) + :type type)) + else do + (setf (gf-info-type info) type) + (push class-name (gf-info-classes info))))) + (add-class readers 'reader) + (add-class writers 'writer)))) + +;;; +;;; Decide what type slot SLOT-NAME in CLASS-OR-NAME has. +;;; CLASS-OR-NAME can be a class or class name. +;;; +(defun decide-slot-type (class-or-name slot-name) + (or (let* ((class-info (class-info (if (symbolp class-or-name) + class-or-name + (class-name class-or-name)))) + (slot-info (when class-info + (find slot-name (class-info-slots class-info) + :key #'slot-info-name :test #'eq)))) + (when slot-info + (slot-info-type slot-info))) + (let* ((class (if (symbolp class-or-name) + (find-class class-or-name nil) + class-or-name)) + (slotd (when class + (find-slot-definition class slot-name)))) + (when slotd + (slot-definition-type slotd))))) + +;;; +;;; Return T if CLASS-NAME names a STD-CLASS, that is, either a +;;; STANDARD-CLASS or FUNCALLABLE-STANDARD-CLASS in normal MOP spaak. +;;; +;;; Structure classes are defined at compile-time, see the EVAL in +;;; EXPAND-DEFCLASS. If it's a structure, the class must be defined, +;;; and be a structure class. +;;; +(defun info-std-class-p (class-name) + (let ((class (find-class class-name nil))) + (if class + (std-class-p class) + (class-info class-name)))) + + +;;; ************** +;;; Slots ******* +;;; ************** + +;;; +;;; Return true if NAME should be considerd a slot reader/writer name. +;;; +(defun info-accessor-p (name) + (or (let ((info (gf-info name))) + (when info + (not (null (gf-info-type info))))) + (when (and (eq *boot-state* 'complete) + (fboundp name)) + (let ((gf (gdefinition name)) + (accessorp nil)) + (when (generic-function-p gf) + (loop for method in (generic-function-methods gf) + when (standard-accessor-method-p method) do + (setq accessorp t) + (let ((type (if (standard-reader-method-p method) + 'reader 'writer))) + (setf (gf-info name) + (make-gf-info :nreq (ecase type + (reader 1) + (writer 2)) + :applyp nil + :type type + :classes ()))) + (loop-finish))) + accessorp)))) + +;;; +;;; Decide if a call to GF-NAME should be optimized as a slot +;;; reader/writer call of type TYPE. TYPE must be one of the symbols +;;; READER or WRITER. +;;; +(defun decide-optimize-accessor-p (gf-name type) + (let ((info (gf-info gf-name))) + (when info + (eq type (gf-info-type info))))) + +;;; +;;; Decide if access to slot SLOT-NAME in class CLASS-NAME should be +;;; optimized. TYPE is the type of access, one of READER/WRITER/ALL. +;;; +;;; This function is called from COMPUTE-PV-SLOT and from the code +;;; actually generating the code for optimized slot access. It's +;;; suboptimal but okay if this function errs: either we'll be doing a +;;; superfluous optimization or prevent a possible optimization. The +;;; PV code must anyway be able to cope with optimizations that must +;;; be "undone" by setting pv-values to nil. +;;; +;;; It's worthwhile optimizing slot access if we know or suspect at +;;; method compilation time that slots are accessed in the standard +;;; way, which means that there is no non-standard +;;; SLOT-VALUE-USING-CLASS method defined. +;;; +;;; If we know that there is or will be such a method, it's not worth +;;; optimizing. +;;; +(defun decide-optimize-slot-p (class-name slot-name type) + (or (let ((class-info (class-info class-name))) + (and class-info + (member slot-name (class-info-slots class-info) + :key #'slot-info-name :test #'eq) + ;; FUNCALLABLE-STANDARD-CLASS might be ok, too, I haven't + ;; checked. It's not terribly important, though. + (eq (class-info-metaclass class-info) 'standard-class))) + (let* ((class (find-class class-name nil)) + (slotd (and class (find-slot-definition class slot-name)))) + (when slotd + (slot-accessor-std-p slotd type))))) + +;;; +;;; Decide if SLOT-NAME should be considered a class slot in class +;;; CLASS-NAME. +;;; +(defun decide-class-slot-p (class-name slot-name) + (or (let* ((class-info (class-info class-name)) + (slot-info (and class-info + (find slot-name (class-info-slots class-info) + :key #'slot-info-name :test #'eq)))) + (when slot-info + (eq :class (slot-info-allocation slot-info)))) + (let* ((class (find-class class-name nil)) + (slotd (and class (find-slot-definition class slot-name)))) + (when slotd + (eq :class (slot-definition-allocation slotd)))))) + + +;;; *************************** +;;; Generic Functions ******* +;;; *************************** + +;;; +;;; Record compile-time information about the declaration of +;;; generic function GF-NAME with lambda list LAMBDA-LIST. +;;; +(defun set-gf-info (gf-name lambda-list) + (multiple-value-bind (required optional restp rest keyp keys + allow-other-keys-p) + (parse-generic-function-lambda-list lambda-list) + (declare (ignore rest keys)) + (setf (gf-info gf-name) + (make-gf-info :nreq (length required) + ;; Like in ARG-INFO-APPLYP. + :applyp (or restp keyp (not (null optional)) + allow-other-keys-p))))) + +;;; +;;; Return true if NAME is the name of a known generic function. +;;; +(defun info-gf-name-p (name) + (when (ext:valid-function-name-p name) + (or (gf-info name) + (when (and (fboundp name) + (eq *boot-state* 'complete)) + (let ((gf (gdefinition name))) + (when (standard-generic-function-p gf) + (set-gf-info name (generic-function-lambda-list gf)) + t)))))) + +;;; +;;; Called to update the info database and pv caches when function +;;; NAME gets redefined to NEWDEF. If NAME is a generic function, +;;; flush pv caches referring to it. +;;; +(defun %check-gf-redefinition (name newdef) + (when (eq *boot-state* 'complete) + (let ((gf (and (fboundp name) + (not (memq (car-safe name) + '(effective-method method fast-method + slot-accessor))) + (gdefinition name)))) + (when (and gf + (generic-function-p gf) + (not (generic-function-p newdef))) + (setf (gf-info name) nil) + (update-accessor-pvs 'removed-gf gf) + (update-pv-calls-for-gf gf 'removed-gf))))) + +(push #'%check-gf-redefinition lisp::*setf-fdefinition-hook*) + + +;;; ********************** +;;; Declarations ******** +;;; ********************** + +(defvar *non-variable-declarations* + '(ftype + inline + method-lambda-list + method-name + notinline + optimize + values)) + +(defvar *variable-declarations-with-argument* + '(class + type)) + +(defvar *variable-declarations-without-argument* + '(array + atom + base-char + bignum + bit + bit-vector + character + compiled-function + complex + cons + double-float + dynamic-extent + extended-char + fixnum + float function + hash-table + ignorable + ignore + integer + keyword + list + long-float + nil + null + number + package + pathname + random-state + ratio + rational + readtable + sequence + short-float + signed-byte + simple-array + simple-bit-vector + simple-string + simple-vector + single-float + special + standard-char + stream + string + symbol + t + unsigned-byte + vector)) + +(defvar *slots-qualities* + '(inline + slot-boundp)) + +(defun split-declarations (body args calls-next-method-p) + (let ((inner-decls nil) (outer-decls nil) decl) + (loop (when (null body) (return nil)) + (setq decl (car body)) + (unless (and (consp decl) + (eq (car decl) 'declare)) + (return nil)) + (dolist (form (cdr decl)) + (when (consp form) + (let ((declaration-name (car form))) + (if (member declaration-name *non-variable-declarations*) + (push `(declare ,form) outer-decls) + (let ((arg-p + (member declaration-name + *variable-declarations-with-argument*)) + (non-arg-p + (member declaration-name + *variable-declarations-without-argument*)) + (dname (list (pop form)))) + (unless (or arg-p non-arg-p) + (warn "~@<The declaration ~S is not understood by ~S. ~ + Please put ~S on one of the lists ~S, ~S, or ~S. ~ + (Assuming it is a variable declarations without ~ + argument).~@:>" + declaration-name 'split-declarations + declaration-name + '*non-variable-declarations* + '*variable-declarations-with-argument* + '*variable-declarations-without-argument*) + (push declaration-name + *variable-declarations-without-argument*)) + (when arg-p + (setq dname (append dname (list (pop form))))) + ;; + ;; The PCL-internal declaration CLASS has the + ;; form (DECLARE (CLASS <parameter> <class>), + ;; which is incompatible with what the DOLIST + ;; below does. + (case (car dname) + (class + (push `(declare (,@dname ,@form)) inner-decls)) + (t + (let ((inners nil) (outers nil)) + (dolist (var form) + (if (member var args) + ;; quietly remove ignore declarations + ;; on args when a next-method is + ;; involved to prevent compiler warns + ;; about ignored args being read + (unless (and calls-next-method-p + (eq (car dname) 'ignore)) + (push var outers)) + (push var inners))) + (when outers + (push `(declare (,@dname ,@outers)) outer-decls)) + (when inners + (push `(declare (,@dname ,@inners)) inner-decls)))))))))) + (setq body (cdr body))) + (values outer-decls inner-decls body))) + +;;; +;;; Set up SLOTS, AUTO-COMPILE, and NOT-AUTO-COMPILE as a recognizable +;;; declaration. +;;; +(export '(slots auto-compile not-auto-compile)) +(declaim (declaration slots auto-compile not-auto-compile)) +(pushnew 'slots *variable-declarations-with-argument*) +(pushnew 'slots walker:*variable-declarations*) + +(defvar *auto-compile-global-default* nil) + +;;; +;;; True if there is a slot optimization declaration DECLARATION in +;;; ENV for CLASS and SLOT-NAME. Slot optimization declarations look +;;; like +;;; +;;; declare (pcl:slots specifier*) +;;; +;;; specifier ::= (quality class-entry*) +;;; quality ::= SLOT-BOUNDP | INLINE +;;; class-entry ::= class | (class slot-name*) +;;; class ::= the name of a class +;;; slot-name ::= the name of a slot +;;; +;;; Examples: +;;; +;;; (declare (slots (slot-boundp my-class))) +;;; (declare (slots (inline (my-class slot-a)))) +;;; +(defun slot-declaration (env quality class &optional slot-name) + (assert (memq quality *slots-qualities*)) + (or (when env + (local-slot-declaration env quality class slot-name)) + (global-slot-declaration quality class slot-name))) + +(defun local-slot-declaration (env quality class &optional slot-name) + (let ((class-name (if (symbolp class) class (class-name class)))) + (dolist (decl (walker::env-declarations env)) + (when (and (consp decl) + (eq (car decl) 'slots) + (slot-access-specifier (cdr decl) quality class-name + slot-name)) + (return t))))) + +(defun slot-access-specifier (specifiers quality class-name + &optional slot-name) + (dolist (specifier specifiers) + (when (and (consp specifier) (eq quality (car specifier))) + (dolist (entry (cdr specifier)) + (when (typecase entry + (symbol + (eq entry class-name)) + (cons + (and (eq (car entry) class-name) + (or (null slot-name) + (null (cdr entry)) + (memq slot-name (cdr entry))))) + (t (warn "~@<Invalid slot access declaration ~s.~@:>" + specifier))) + (return-from slot-access-specifier entry)))))) + +(defun global-slot-declaration (quality class &optional slot-name) + (let* ((info (class-info (if (symbolp class) class (class-name class)))) + (spec (when info (assq quality (class-info-slot-access info))))) + (and spec + (or (null slot-name) + (null (cdr spec)) + (memq slot-name (cdr spec)))))) + +(defun proclamation-hook (form) + (when (consp form) + (case (car form) + (slots (slot-access-proclamation form)) + (auto-compile (auto-compile-proclamation form t)) + (not-auto-compile (auto-compile-proclamation form nil))))) + +(defun slot-access-proclamation (form) + (flet ((invalid (&optional subform) + (if subform + (warn "~@<Invalid slot access specifier ~s in ~s.~@:>" + subform form) + (warn "~@<Invalid slot access declaration ~s.~@:>" + form)))) + (dolist (specifier (cdr form)) + (if (and (consp specifier) + (memq (car specifier) *slots-qualities*)) + (dolist (class-entry (cdr specifier)) + (let (class slots) + (typecase class-entry + (symbol + (setq class class-entry)) + (cons + (setq class (car class-entry)) + (setq slots (cdr class-entry))) + (t + (invalid specifier))) + (when class + (let* ((info (class-info-or-make class)) + (entry (assoc (car specifier) + (class-info-slot-access info)))) + (if entry + (setf (cdr entry) slots) + (push (list* (car specifier) slots) + (class-info-slot-access info))))))) + (invalid))))) + +(defun auto-compile-proclamation (form compilep) + (flet ((invalid (&optional subform) + (if subform + (warn "~@<Invalid auto-compile specifier ~s in ~s.~@:>" + subform form) + (warn "~@<Invalid auto-compile declaration ~s.~@:>" + form))) + (gf-name-p (name) + (ext:valid-function-name-p name))) + (if (null (cdr form)) + (setq *auto-compile-global-default* compilep) + (dolist (specifier (cdr form)) + (cond ((or (gf-name-p specifier) + (and (consp specifier) + (gf-name-p (car specifier)) + (null (cdr specifier)))) + (let ((info (gf-info-or-make (if (gf-name-p specifier) + specifier + (car specifier))))) + (setf (gf-info-auto-compile-default info) compilep))) + ((and (consp specifier) + (gf-name-p (car specifier))) + (let* ((info (gf-info-or-make (car specifier))) + (entry (assoc (cdr specifier) + (gf-info-auto-compile info) + :test #'equal))) + (if entry + (setf (cdr entry) compilep) + (setf (gf-info-auto-compile info) + (acons (cdr specifier) compilep + (gf-info-auto-compile info)))))) + (t + (invalid specifier))))))) + +(pushnew 'proclamation-hook c::*proclamation-hooks*) + +;;; +;;; Return true if class CLASS-NAME should be defined at compile time. +;;; Called from EXPAND-DEFCLASS. ENV is the environment in which the +;;; DEFCLASS of CLASS-NAME appears. SUPERS is the list of superclass +;;; names for CLASS-NAME. +;;; +(defun define-class-at-compile-time-p (env class-name &optional supers) + (or (slot-declaration env 'inline class-name) + (some (lambda (super) + (let ((class (find-class super nil))) + (and class + (not (forward-referenced-class-p class)) + (some (lambda (c) + (slot-declaration env 'inline c)) + (class-precedence-list class))))) + supers))) + +;;; +;;; Return true if method with the given name, qualifiers, and +;;; specializers should be auto-compiled. +;;; +(defun auto-compile-p (gf-name qualifiers specializers) + (when (eq *boot-state* 'complete) + (let* ((info (gf-info gf-name)) + (key (append qualifiers (list specializers))) + (compilep (if info + (let ((entry (assoc key (gf-info-auto-compile info) + :test #'equal))) + (if entry + (cdr entry) + (gf-info-auto-compile-default info))) + 'maybe))) + (if (eq 'maybe compilep) + *auto-compile-global-default* + compilep)))) + +;;; end of info.lisp diff --git a/pcl/init.lisp b/pcl/init.lisp index e0c596efb..2976f679b 100644 --- a/pcl/init.lisp +++ b/pcl/init.lisp @@ -26,7 +26,8 @@ ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/init.lisp,v 1.14 2002/10/09 15:32:29 pmai Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/init.lisp,v 1.15 2003/03/22 16:15:16 gerd Exp $") + ;;; ;;; This file defines the initialization and related protocols. ;;; @@ -37,46 +38,46 @@ (apply #'make-instance (find-class class) initargs)) (defmethod make-instance ((class class) &rest initargs) - (unless (class-finalized-p class) (finalize-inheritance class)) - (setq initargs (default-initargs class initargs)) - #|| - (check-initargs-1 - class initargs - (list (list* 'allocate-instance class initargs) - (list* 'initialize-instance (class-prototype class) initargs) - (list* 'shared-initialize (class-prototype class) t initargs))) - ||# - (let* ((info (initialize-info class initargs)) - (valid-p (initialize-info-valid-p info))) - (when (and (consp valid-p) (eq (car valid-p) :invalid)) - (simple-program-error "Invalid initialization argument ~S for class ~S" - (cdr valid-p) (class-name class)))) - (let ((instance (apply #'allocate-instance class initargs))) - (apply #'initialize-instance instance initargs) - instance)) + ;; + ;; Try to use an optimized constructor if there is one. + (let ((instance (call-ctor class initargs))) + (when instance + (return-from make-instance instance))) + ;; + (unless (class-finalized-p class) + (finalize-inheritance class)) + (let ((class-default-initargs (class-default-initargs class))) + (when class-default-initargs + (setf initargs (default-initargs class initargs class-default-initargs))) + (when initargs + (when (and (eq *boot-state* 'complete) + (not (getf initargs :allow-other-keys))) + (let ((class-proto (class-prototype class))) + (check-initargs + class initargs + (append (compute-applicable-methods + #'allocate-instance (list class)) + (compute-applicable-methods + #'initialize-instance (list class-proto)) + (compute-applicable-methods + #'shared-initialize (list class-proto t))))))) + (let ((instance (apply #'allocate-instance class initargs))) + (apply #'initialize-instance instance initargs) + instance))) -(defmethod default-initargs ((class slot-class) supplied-initargs) - (call-initialize-function - (initialize-info-default-initargs-function - (initialize-info class supplied-initargs)) - nil supplied-initargs)) +(defmethod default-initargs ((class slot-class) supplied-initargs + class-default-initargs) + (loop for (key fn) in class-default-initargs + when (eq (getf supplied-initargs key '.not-there.) '.not-there.) + append (list key (funcall fn)) into default-initargs + finally + (return (append supplied-initargs default-initargs)))) (defmethod initialize-instance ((instance slot-object) &rest initargs) (apply #'shared-initialize instance t initargs)) (defmethod reinitialize-instance ((instance slot-object) &rest initargs) - #|| - (check-initargs-1 - (class-of instance) initargs - (list (list* 'reinitialize-instance instance initargs) - (list* 'shared-initialize instance nil initargs))) - ||# - (let* ((class (class-of instance)) - (info (initialize-info class initargs)) - (valid-p (initialize-info-ri-valid-p info))) - (when (and (consp valid-p) (eq (car valid-p) :invalid)) - (simple-program-error "Invalid initialization argument ~S for class ~S" - (cdr valid-p) (class-name class)))) + (check-ri-initargs instance initargs) (apply #'shared-initialize instance nil initargs) instance) @@ -94,7 +95,7 @@ (if (and (not (memq (slot-definition-name slotd) previous-slot-names)) (eq (slot-definition-allocation slotd) :instance)) (push (slot-definition-name slotd) added-slots))) - (check-initargs-1 + (check-initargs (class-of current) initargs (list (list* 'update-instance-for-different-class previous current initargs) (list* 'shared-initialize current added-slots initargs))) @@ -105,86 +106,96 @@ discarded-slots property-list &rest initargs) - (check-initargs-1 + (check-initargs (class-of instance) initargs (list (list* 'update-instance-for-redefined-class instance added-slots discarded-slots property-list initargs) (list* 'shared-initialize instance added-slots initargs))) (apply #'shared-initialize instance added-slots initargs)) -(defmethod shared-initialize - ((instance slot-object) slot-names &rest initargs) - (when (eq slot-names t) - (return-from shared-initialize - (call-initialize-function - (initialize-info-shared-initialize-t-function - (initialize-info (class-of instance) initargs)) - instance initargs))) - (when (eq slot-names 'nil) - (return-from shared-initialize - (call-initialize-function - (initialize-info-shared-initialize-nil-function - (initialize-info (class-of instance) initargs)) - instance initargs))) - ;; - ;; initialize the instance's slots in a two step process - ;; (1) A slot for which one of the initargs in initargs can set - ;; the slot, should be set by that initarg. If more than - ;; one initarg in initargs can set the slot, the leftmost - ;; one should set it. - ;; - ;; (2) Any slot not set by step 1, may be set from its initform - ;; by step 2. Only those slots specified by the slot-names - ;; argument are set. If slot-names is: - ;; T - ;; any slot not set in step 1 is set from its - ;; initform - ;; <list of slot names> - ;; any slot in the list, and not set in step 1 - ;; is set from its initform - ;; - ;; () - ;; no slots are set from initforms - ;; - (let* ((class (class-of instance)) - (slotds (class-slots class)) - (std-p (pcl-instance-p instance))) - (dolist (slotd slotds) - (let ((slot-name (slot-definition-name slotd)) - (slot-initargs (slot-definition-initargs slotd))) - (unless (progn - ;; Try to initialize the slot from one of the initargs. - ;; If we succeed return T, otherwise return nil. - (doplist (initarg val) initargs - (when (memq initarg slot-initargs) - (setf (slot-value-using-class class instance slotd) - val) - (return t)))) - ;; Try to initialize the slot from its initform. - (if (and slot-names - (or (eq slot-names t) - (memq slot-name slot-names)) - (or (and (not std-p) (eq slot-names t)) - (not (slot-boundp-using-class class instance slotd)))) - (let ((initfunction (slot-definition-initfunction slotd))) - (when initfunction - (setf (slot-value-using-class class instance slotd) - (funcall initfunction)))))))) - instance)) +;;; +;;; initialize the instance's slots in a two step process +;;; (1) A slot for which one of the initargs in initargs can set +;;; the slot, should be set by that initarg. If more than +;;; one initarg in initargs can set the slot, the leftmost +;;; one should set it. +;;; +;;; (2) Any slot not set by step 1, may be set from its initform +;;; by step 2. Only those slots specified by the slot-names +;;; argument are set. If slot-names is: +;;; T +;;; any slot not set in step 1 is set from its +;;; initform +;;; <list of slot names> +;;; any slot in the list, and not set in step 1 +;;; is set from its initform +;;; +;;; () +;;; no slots are set from initforms +;;; + +(defmethod shared-initialize ((instance slot-object) slot-names &rest initargs) + (let ((structure-p (structure-class-p (class-of instance)))) + (flet ((initialize-slot-from-initarg (class instance slotd) + (let ((slot-initargs (slot-definition-initargs slotd))) + (doplist (initarg value) initargs + (when (memq initarg slot-initargs) + (setf (slot-value-using-class class instance slotd) + value) + (return t))))) + (initialize-slot-from-initfunction (class instance slotd) + ;; CLHS: If a before method stores something in a slot, + ;; that slot won't be initialized from its :INITFORM, if any. + (if structure-p + (when (eq '.unbound. + (slot-value-using-class class instance slotd)) + (let ((initfn (slot-definition-initfunction slotd))) + (setf (slot-value-using-class class instance slotd) + (if (null initfn) + nil + (funcall initfn))))) + (unless (slot-boundp-using-class class instance slotd) + (let ((initfn (slot-definition-initfunction slotd))) + (unless (null initfn) + (setf (slot-value-using-class class instance slotd) + (funcall initfn)))))))) + (let* ((class (class-of instance)) + (initfn-slotds + (loop for slotd in (class-slots class) + unless (initialize-slot-from-initarg class instance slotd) + collect slotd))) + (loop for slotd in initfn-slotds + when (and (not (eq :class (slot-definition-allocation slotd))) + (or (eq t slot-names) + (memq (slot-definition-name slotd) slot-names))) do + (initialize-slot-from-initfunction class instance slotd))) + instance))) -;;; +;;; ;;; if initargs are valid return nil, otherwise signal an error +;;; If ERROR-P is false, return a list of invalid initkeys. ;;; -(defun check-initargs-1 (class initargs call-list &optional (plist-p t) (error-p t)) +(defun check-initargs (class initargs call-list + &optional (plist-p t) (error-p t)) (multiple-value-bind (legal allow-other-keys) - (check-initargs-values class call-list) + (valid-initargs class call-list) (unless allow-other-keys - (if plist-p - (check-initargs-2-plist initargs class legal error-p) - (check-initargs-2-list initargs class legal error-p))))) + (let ((invalid-keys ())) + (if plist-p + (unless (getf initargs :allow-other-keys) + (doplist (key val) initargs + (unless (memq key legal) + (push key invalid-keys)))) + (unless (memq :allow-other-keys initargs) + (dolist (key initargs) + (unless (memq key legal) + (push key invalid-keys))))) + (when (and invalid-keys error-p) + (invalid-initargs-error class invalid-keys)) + invalid-keys)))) -(defun check-initargs-values (class call-list) +(defun valid-initargs (class call-list) (let ((methods (mapcan (lambda (call) (if (consp call) (copy-list (compute-applicable-methods @@ -205,33 +216,13 @@ (method-lambda-list method))) (declare (ignore nreq nopt keysp restp)) (when allow-other-keys - (return-from check-initargs-values (values nil t))) + (return-from valid-initargs (values nil t))) (setq legal (append keys legal)))) (values legal nil))) -(defun check-initargs-2-plist (initargs class legal &optional (error-p t)) - (unless (getf initargs :allow-other-keys) - ;; Now check the supplied-initarg-names and the default initargs - ;; against the total set that we know are legal. - (doplist (key val) initargs - (unless (memq key legal) - (if error-p - (simple-program-error - "Invalid initialization argument ~S for class ~S" - key (class-name class)) - (return-from check-initargs-2-plist nil))))) - t) - -(defun check-initargs-2-list (initkeys class legal &optional (error-p t)) - (unless (memq :allow-other-keys initkeys) - ;; Now check the supplied-initarg-names and the default initargs - ;; against the total set that we know are legal. - (dolist (key initkeys) - (unless (memq key legal) - (if error-p - (simple-program-error - "Invalid initialization argument ~S for class ~S" - key (class-name class)) - (return-from check-initargs-2-list nil))))) - t) - +(defun invalid-initargs-error (class invalid-keys) + (simple-program-error "~@<Invalid initialization argument~P ~2I~_~ + ~<~{~S~^, ~}~@:> ~I~_in call for class ~S.~:>" + (length invalid-keys) + (list invalid-keys) + class)) diff --git a/pcl/lap.text b/pcl/lap.text deleted file mode 100644 index b7419f74f..000000000 --- a/pcl/lap.text +++ /dev/null @@ -1,655 +0,0 @@ --*- Mode: Text -*- - -Copyright (c) 1985, 1986, 1987, 1988, 1989 Xerox Corporation. -All rights reserved. - -Use and copying of this document is permitted. Any distribution of this -document must comply with all applicable United States export control -laws. - -Last updated: 6/3/89 by Gregor - 10/26/89 by Gregor -- added :RETURN, removed :ISHIFT - -This file contains documentation of the PCL abstract LAP code. Any port -of PCL is required to implement the abstract LAP code interface. There -is a portable, relatively good performance implementation in the file -lap.lisp, port-specific implementations are in that file as well. - -The PCL abstract LAP code mechanism exists to provide PCL with a way to -create high-performance method lookup functions. Using this mechanism, -PCL can produce "LAP closures" which do the method lookup. By allowing -PCL to specify these closures using abstract LAP code rather that Lisp -code we hope to achieve the following: - - * Better runtime performance. By using abstract LAP code, we - will get better machine instruction sequences than we would - from compiling Lisp code. - - * Better load and update time performance. Because it should - be possible to "assemble" the LAP code more quickly than - compiling Lisp code, PCL will spend less time building the - method lookup code. - - * Ability to use PCL without a compiler. The LAP assembler will - still be required but this should be much smaller than the full - lisp compiler. - -Of course, not all implementations of the LAP code mechanism will -satisfy all of these goals. The first is the most important. - -In particular, many PCL ports will use the portable LAP implementation. -KCL will use the portable implementation in all of its ports. Other -Lisps may have custom LAP implementations for some ports and use the -portable implementation for other ports. - -Some Lisps will have a custom LAP implementation but will nonetheless -require the compiler to be loaded to generate LAP closure constructors. - -An important point is why we have chosen to take this route rather than -have each implementation implement the method lookup codes itself. This -was done because we are, at PARC, just beginning to study cache behavior -for CLOS programs. As we learn more about this we will want to modify -the caching strategy PCL uses. This architecture, because it leaves -PCL to implement caching behavior makes it possible to do this. Once -this study is complete, implementations may want to do their own, ultra -high performance implementations of caching strategies. - - - -Production of LAP closures is a two step process. In the first step, a -port-specific function is called to take abstract LAP code and produce a -a "lap closure generator". Lap closure generators are functions which -are called with a set of closure variable values and return a LAP -closure. - -The intermediary of the lap closure generators provides an important -optimization. Because it is assumed that producing the LAP closure -generator can take much longer than producing a LAP closure from the -generator, PCL attempts to make only one closure generator for each -sequence of LAP code. Because of the way PCL generates the LAP code -sequences, this is quite easy for it to do. - -The rest of this document is divided into six parts. - - * the metatypes std-instance and fsc-instance - - * an abstraction for simple vector indices - - * important optimizations - - * the port specific function for making lap closure generators - - * the actual abstract LAP code - - * examples - -*** The metatypes STD-INSTANCE and FSC-INSTANCE *** - -In PCL, instances with metaclass STANDARD-CLASS are represented using -the metatype STD-INSTANCE. (Note that in Cinco de Mayo PCL, this -metatype is called IWMC-CLASS.) Each port must implement this metatype. -The metatype could be implemented by the following DEFSTRUCT. - - (defstruct (std-instance - (:predicate std-instance-p) - (:conc-name %std-instance-) - (:constructor %allocate-std-instance (wrapper slots)) - (:constructor %allocate-std-instance-1 ()) - (:print-function print-std-instance)) - (wrapper nil) - (slots nil)) - - PCL itself will guarantee correct access to this structure and the - accessors and constructors. With this in mind, the following are - important. - - * Being able to type test this structure quickly is critical. See - the :STD-INSTANCE-P opcode. - - * The allocation functions should compile inline, do no argument - checking and be as fast as possible. - - * The accessor functions should compile inline, do no checking of their - arguments and be as fast as possible. SETF of the accessors should - do the same. - -The port is also required to implement the metatype FSC-INSTANCE (called -FUNCALLABLE-INSTANCE, or FIN for short, in Cinco de Mayo PCL). Objects -with this metatype are used, among other things, to implement generic -functions. These objects have field structure associated with them and -are also functions that can be applied to arguments. The fields are the -same as those for STD-INSTANCE, the FSC-INSTANCE metatype has -predicates, print-functions, constructors and accessors as follows: - - fsc-instance-p - print-fsc-instance - %fsc-instance-wrapper - %fsc-instance-slots - %allocate-fsc-instance (wrapper slots) - %allocate-fsc-instance-1 () - -In addition, objects of metatype FSC-INSTANCE have a property called the -funcallable instance function. When an FSC-INSTANCE is applied to -arguments, the funcallable instance function is what is actually called. -The funcallable instance function of an FSC-INSTANCE can be changed -using the function SET-FUNCALLABLE-INSTANCE-FUNCTION. There is no -mechanism for obtaining the funcallable instance function of an -FSC-INSTANCE. - -It is possible to implement the FSC-INSTANCE metatype in pure Common -Lisp. A simple implementation which uses lexical closures as the -instances and a hash table to record that the lexical closures are of -metatype FSC-INSTANCE is easy to write. Unfortunately, this -implementation adds significant overhead: - - to generic-function-invocation (1 function call) - to slot-access (1 function call or one hash table lookup) - to class-of a generic-function (1 hash-table lookup) - -In addition, it would prevent the FSC-INSTANCEs from being garbage -collected. In short, the pure Common Lisp implementation really isn't -practical. - -Note that previous implementations of FINS were always based on the -lexical closure metatype. In some ports, that provides poor -performance. Those ports may want to consider reimplementing to use the -compiled code metatype. In that implementation strategy, LAP closure -variables would become constants of the compiled code object. - -The following note from JonL is of interest when working on a FIN -implementation: - - Date: Tue, 16 May 89 05:45:56 PDT - From: Jon L White <jonl@lucid.com> - - This isn't a bug in Lucid's compiler -- it's a lurking bug in PCL - that will "bite" most implementations where different settings of - the compiler optimization switches will produce morphologically - different (but of course functionally equivalent) function objects. - - The difficulty is in how discriminator codes service cache misses. - They "call out" to (potentially) random functions that will in some - cases "smash" the function object that was actually running as the - discriminator code. This is all right providing you don't return to - that function frame, but alas ... - - I know this is a more extensive problem because the code in the - port-independent function 'notice-methods-change' goes out of - its way to do a tail-recursive call to the function that is going - to smash the possibly-executing discriminator code. Here is the - commentary from that code (sic): - - ;; In order to prevent this we take a simple measure: we just - ;; make sure that it doesn't try to reference our its own closure - ;; variables after it makes the dcode change. This is done by - ;; having notice-methods-change-2 do the work of making the change - ;; AND calling the actual generic function (a closure variable) - ;; over. This means that at the time the dcode change is made, - ;; there is a pointer to the generic function on the stack where - ;; it won't be affected by the change to the closure variables. - - - A similar thing should be done in the construction of standard-accessor, - checking, and caching dcodes. In an experimental version here at Lucid, - I rewrote dcode.lisp to do that, and there is no problem with it. - Although that code is somewhat Lucid-specific, it could be of help to - someone who wanted to rewrite the generic dcode.lisp (no pun intended). - Contact me privately if you are interested. - - Doing a tail-recursive call out of dcodes when there is a cache miss - is a good thing, regardless of other problems. I think one might as - well do it. However, I should point out that in the presence of - multiprocessing, there is another more serious problem that cannot be - solved so simply. Think about what happens when one process decides - to update a dcode while another process is still using it; no such - stack-maintenance discipline will fix this case. A tail-recursive - exit from the dcode will *immensely* reduce the likelihood that - another process can sneak in during the interval in which the dcode - requires consistency in its function; but it can't reduce that - likelihood to zero. - - The more desirable thing to do is to put the whole "dcode" down one - more level of indirection through the symbol-function cell of the - generic function. This is effectively what PCL's 'make-trampoline' - function does, but unfortunately that is not a very efficient approach - when you consider how most compilers will compile it. Something akin - to the "mattress-pads" in Steve Haflich's code (in the fin.lisp file) - could probably be done for many other implementations as well. - - -*** Index Operations *** - -Indexes are an abstraction for indexes into a simple vector. This -abstraction is used to make it possible to generate more efficient -code to access simple vectors. The idea being that this may make it -possible to use alternate addressing modes to address these. - -The "index value" of an index is defined to be the fixnum of which that -index is an alternate form. So, using the Lisp function SVREF with the -index value of an index accesses the same element as using the index -with the appropriate access function or operand. - -The format of an index is unspecified, but is assumed to be something -like a fixnum with certain bits ignored. Accessing a vector using an -index must be done using the appropriate special accessor function or -opcode. - -Conversion from index values to indices and vice-versa can be done with -the following functions: - -INDEX-VALUE->INDEX (index-value) -INDEX->INDEX-VALUE (index) - - -The following constant indicates the maximum index value an index can -have in a given port. This must be at least 2^16. - -INDEX-VALUE-LIMIT - a fixnum, must be at least 2^16. - - -MAKE-INDEX-MASK (<cache-size> <line-size>) - -This function is used to make index masks. Because I am lazy, I show an -implementation of it in the common case where indexes are just fixnums: - - (defun make-index-mask (cache-size line-size) - (let ((cache-size-in-bits (floor (log cache-size 2))) - (line-size-in-bits (floor (log line-size 2))) - (mask 0)) - (dotimes (i cache-size-in-bits) (setq mask (dpb 1 (byte 1 i) mask))) - (dotimes (i line-size-in-bits) (setq mask (dpb 0 (byte 1 i) mask))) - mask)) - -*** Optimizations *** - -This section discusses two important optimizations related to LAP -closures. The first relates to calling LAP closures themselves, the -second relates to calling other functions from LAP closures. - -The important point about calling LAP closures is that almost all of the -time, LAP closures will be used as the funcallable-instance-function of -funcallable instances. It is required that LAP closures be funcallable -themselves, but usually they will be stored in a FIN and the fin will -then be funcalled. This brings up several optimizations, including ones -having to do with access to the closure variables of a LAP closure. - -When a LAP closure is used to do method lookup, the function the LAP -closure ends up calling has the same number of required arguments as the -LAP closure itself. Since the LAP closure must check its required -arguments to do the lookup, it is redundant for the function called to -do so as well. Since LAP closures do all calls in a tail recursive way, -it should even be possible to optimize out certain parts of the normal -stack frame initialization. - -A similar situation occurs between effective method functions and the -individual method functions; the difference is that in effective method -functions, the calls are not necessarily tail recursive. - -Consequently, it would be nice to have a way to call certain functions -and inhibit the checking of required arguments. This is made possible -by use of the PCL-FAST-APPLY and PCL-FAST-FUNCALL macros together with -the PCL-FAST-CALL compiler declaration. - -The PCL-FAST-CALL compiler declaration declares that a function may be -fast called. Not all callers of the function will necessarily fast call -it, but most probably will. The :JMP opcode can only be used to call a -function compiled with the PCL-FAST-CALL declaration. - -The PCL-FAST-APPLY and PCL-FAST-FUNCALL macros are used to fast call a -function. The function argument must be a compiled function that has -the PCL-FAST-CALL compiler declaration in its lambda declarations. - -The basic idea is that the PCL-FAST-CALL compiler declaration causes the -compiler to set up an additional entrypoint to the function. This -entrypoint comes after checking of required arguments but before -processing of other arguments. - -Note: When FAST-APPLY is used, the required arguments will be given as -separate arguments and all other arguments will appear as a single -spread argument. For example: - -(let ((fn (compile () '(lambda (a b &optional (c 'z)) - (declare (pcl-fast-call)) - (list a b c))))) - - (pcl-fast-apply fn 'x 'y ()) ;legal - (pcl-fast-apply fn 'x 'y '(foo)) ;legal - (pcl-fast-apply fn '(a b c)) ;illegal - ) - -*** Producing LAP Closure Generators *** - -Each implementation of the LAP code mechanism must provide a port -specific function making lap closure generators. In the portable -implementation, this function is called PLAP-CLOSURE-GENERATOR. In -ExCL it should be called EXCL-LAP-CLOSURE-GENERATOR etc. - -At any time, the value of the variable *make-lap-closure-generator* is a -symbol which names the function currently being used to make lap closure -generators. - -The port specific function must accept arguments as follows: - -PLAP-CLOSURE-GENERATOR (<closure-vars> - <args> - <index-registers> - <simple-vector-registers> - <lap-code>) - -This returns a lap-closure generator. A lap-closure generator is a -function which is called with a number of arguments equal to the length -of <closure-vars>. These arguments are the values of the closure -variables for the lap closure. These values cannot be changed once the -LAP closure is created. PCL takes care of keeping track of -lap-closure-generators it already has on hand and reusing them. The -function RESET-LAP-CLOSURE-GENERATORS can be called to force PCL to -forget all the lap closure generators it has remembered. - - <args> - -A list of symbols. This provides a way to name particular arguments to -the LAP closure. Arguments which will not be referenced by name are -given as NIL. All required arguments to the LAP closure are explicitly -included (perhaps as NIL). If &REST appears at the end of arguments it -means that non-required arguments are allowed, these will be processed -by the methods. If &REST does not appear at the end of arguments, the -lap closure should signal an error if more than the indicated number of -arguments are supplied. - -Examples: - - - (obj-0 obj-1) - - Specifies a two argument lap closure. If more or less than - two arguments are supplied an error is signalled. Within - the actual lap code, both arguments can be referenced by - name (see the :ARG operand). - - - (obj-0 nil &rest) - - Specifies a two or more argument lap closure. If less than - two arguments are supplied an error is signalled. Within - the actual lap code, the first argument can be referenced by - name (see the :ARG operand). - - - <closure-vars> - -A list of symbols. The closure will have these as closure variables. -Within the lap code these can be accessed using the :CVAR operand. The -lap code cannot change these values. SET-FUNCALLABLE-INSTANCE-FUNCTION -is permitted to have the special knowledge that there are at most ?? of -these and to be prepared to do something special when the funcallable -instance function of a funcallable instance is set to a lap closure. - - <index-registers> - -A list of register numbers. These registers will be used only to hold -indexes. Other registers may be used to hold indexes as well, but the -only values put into these registers will be indexes. - - <simple-vector-registers> - -A list of register numbers. These registers will be used only to hold -simple-vectors. Other registers may be used to hold simple-vectors as -well, but the only values put into these registers will be -simple-vectors. - - - <lap-code> - -The actual lap code for this closure. This is a list of LAP code -opcodes. See the section "Abstract LAP Code" for more details. - -Each implementation must also supply a function named PRE-MAKE-xxx where -xxx is the same as the name of its make-lap-closure-generator function. -The macro doesn't evaluate its arguments, and when it appears in a file -it should try to do some of the work at load time. It might appear in a -file like this: - -(eval-when (load) - (setq 1-arg-std-lap - (pre-make-plap-closure-generator ...))) - -*** Abstract LAP Code *** - -Each lap code operand has the form: (opcode operand1 ... operandn). - -In some cases, the distinction between an operand and an opcode is -somewhat arbitrary. In general, opcodes have a significant "action" -component to their behavior. Operands select a piece of data to operate -on. Some operands select their data in a more complex way, but they are -operands anyways. - -All data must be in a register before it can be operated on. This -requirement means that the only place a non-register operand can appear -is as the first argument to the :move opcode. (Actually, there is one -other exception, a :iref operand can be the target of a move as well.) -Moreover, only register operands can appear as the second argument to -the :move opcode and this register must not appear in the <from> -operand. - ->> The operands are: - - (:reg <n>) - -A pseudo register. <n> is an integer in the range [0 , 31]. - -A particular implementation can map this to a real register, a memory -location or the stack. The abstract LAP code itself does not include -the notion of a stack. - -PCL will attempt to optimize register use in two ways. PCL itself will -attempt to re-use registers whenever possible. That is, the port should -not have to worry with doing live register analysis for the registers. -In addition, PCL will consider lower numbered registers to be "faster" -than higher numbered ones. - - - (:cvar <name>) - -A closure variable of the lap-closure. <name> is a symbol. - - - (:arg <name>) - -An argument to the LAP closure. <name> is a symbol. - - (:std-wrapper <from>) - (:fsc-wrapper <from>) - (:built-in-wrapper <from>) - (:structure-wrapper <from>) - (:other-wrapper <from>) - -Get the class wrapper of <from>. For std-instances and fsc-instances -this just fetches the wrapper field. The specific port is required to -implement fast access to the wrappers of built-in, structure and other -metatypes. A callback mechanism allows the port to ask PCL to generate -a class and wrapper for objects for which no class and wrapper exists -yet. This mechanism is <<to be spec'd out>>. - - - (:std-slots <operand>) - (:fsc-slots <operand>) - -Fetch the slots field of a std-instance or a fsc-instance. - - (:constant <constant>) - -This just allows inline constants. <constant> can be any Lisp object. - -The following operands operate on indexes. Each is patterned after a -Lisp function which would have a corresponding effect on the index value -of the index. - - (:i1+ <index>) - (:i+ <index-1> <index-2>) - (:i- <index-1> <index-2>) - (:ilogand <index-1> <index-2>) - (:ilogxor <index-1> <index-2>) - -Like the corresponding Lisp functions. - - - (:iref <vector> <index>) - -Like the SVREF function. <vector> must be a simple vector. - - (:cref <vector> <constant>) - -The :cref operand is for constant vector references. <constant> must be -a fixnum. - ->> The opcodes are: - - (:move <from> <to>) - -A full word move operation. - - - (:eq <from1> <from2> <label>) - (:neq <from1> <from2> <label>) - -EQ and NOT EQ conditional branches. If the value contained in <from1> -is EQ (or not) to the value contained in <from2>, jump to <label>. -Otherwise continue execution at the next opcode. <label> is a symbol. - - (:fix= <from1> <from2> <label>) - -A fixnum = conditional branch. - - (:izerop <from> <label>) - -Jump to label if and only if the index <from> is 0. - - (:std-instance-p <from> <destination-label>) - (:fsc-instance-p <from> <destination-label>) - (:built-in-instance-p <from> <destination-label>) - (:structure-instance-p <from> <destination-label>) - -Test the metatype of <from> and dispatch. If the metatype of from is of -the specified type execution jumps to <destination-label>. Otherwise, -execution proceeds normally at the next opcode. See the :xxx-wrapper -operands. - - (:jmp <function>) - -fcn contains a function to call. This must be a compiled function, -which had the PCL-FAST-CALL declaration in it. The call should be "tail -recursive" in that whatever values it returns should be returned -immediately from the LAP closure itself. - -Method lookup is implemented by finding a function in the cache and then -using :JMP to call it. The various kinds of traps are implemented by -using :JMP to call a trap function that was stored in one of the closure -variables. - - (:return <value>) - -Return immediately from the LAP closure. <value> is the single value to -return. - -In certain cases of method lookup when all the methods are accessor methods, -there is an important optimization which implements the slot access in the -discriminating function itself. This opcode is used in that case. - - (:label <label>) - -Identifies a point in the lap code. <label> is a symbol. This can be -the target of any of the control transfer opcodes (:GO, :EQ, :NEQ, -:FIX=, :STD-INSTANCE-P, :FSC-INSTANCE-P, :STRUCTURE-INSTANCE-P, -:BUILT-IN-INSTANCE-P) - - (:go <label>) - -Jump to the label <label>. <label> is a symbol. - -*** Examples *** - -Here is an example of the use of the abstract LAP mechanism. It doesn't -use all operands or opcodes, but it is representative of the LAP -sequences PCL will use. - -Several things are worth noting: - * This is, I believe, just about the simplest such sequence. There - are some others of comparable simplicity, but none much simpler. - - * A total of only 5 registers are used. I haven't checked, but I - am pretty sure most all such code sequences will get by with 16 - or less and many will stay under 8. - -(defun make-1-arg-std-dfun () - (let ((cg - (making-lap-closure-generator - (initialize-lap-cvars '(cache mask reflect trap)) - (initialize-lap-args '(a0)) - (initialize-lap-registers 4 4 3) - (let ((cache (allocate-lap-register 'simple-vector)) - (count (allocate-lap-register)) - (wrapper (allocate-lap-register)) - (index (allocate-lap-register 'index)) - (t1 (allocate-lap-register)) - (t2 (allocate-lap-register)) - (i1 (allocate-lap-register 'index)) - (i2 (allocate-lap-register 'index))) - - (opcode :move (operand :cvar 'cache) cache) - (opcode :move (operand :arg 'a0) t1) - (opcode :std-instance-p t1 'std-instance) - (opcode :go 'trap) - (opcode :label 'std-instance) - ;; - ;; The stable register pattern for the rest of the code is: - ;; cache Cache - ;; count Cache count - ;; wrapper Wrapper - ;; index index under consideration - ;; - ;; Whenever we jump to HIT, this pattern must be in force. - ;; - (opcode :move (operand :std-wrapper t1) wrapper); - (opcode :move (operand :cref cache 0) count) ; - (opcode :move (operand :cref wrapper 0) i2) ;wrapper-no -> i2 - (opcode :move (operand :cvar 'mask) i1) ;mask -> i1 - (opcode :move (operand :ilogand i1 i2) index) ; - ; - (opcode :move (operand :iref cache index) t1) ;key -> t1 - (opcode :eq t1 wrapper 'hit) ; - (opcode :move (operand :cvar 'reflect) i1) ;reflect -> i1 - (opcode :move index i2) ;index -> i2 - (opcode :move (operand :i- i1 i2) index) ; - (opcode :move (operand :iref cache index) t1) ;key -> t1 - (opcode :eq t1 wrapper 'hit) ; - (opcode :go 'trap) - - ;; - ;; To do the hit, we use registers as follows: - ;; 0 cache comes in here - ;; 1 cache count comes in here - ;; 2 use this for the function - ;; 3 index comes in here - ;; 4 1+ index, then new count - ;; - (opcode :label 'hit) - (opcode :move (operand :i1+ index) i1) - (opcode :move (operand :iref cache i1) t1) - - (opcode :move (operand :cref cache 0) t2) - (opcode :fix= count t2 'call) - (opcode :go 'trap) - - (opcode :label 'call) - (opcode :jmp t1) - - (opcode :label 'trap) - (opcode :move (operand :cvar 'trap) t1) - (opcode :jmp t1))))) - - (funcall cg - (make-array 16) - (make-index-mask 16 2) - (- 16 2) - #'(lambda (a) - (declare (pcl-fast-call) (ignore a)) - (break "Trap"))))) - diff --git a/pcl/low.lisp b/pcl/low.lisp index bcbbe0f46..e8b7ae5e9 100644 --- a/pcl/low.lisp +++ b/pcl/low.lisp @@ -26,7 +26,7 @@ ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/low.lisp,v 1.21 2002/11/22 15:20:18 pmai Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/low.lisp,v 1.22 2003/03/22 16:15:16 gerd Exp $") ;;; ;;; This file contains optimized low-level constructs for PCL. @@ -35,11 +35,8 @@ (in-package :pcl) (eval-when (:compile-toplevel :load-toplevel :execute) -(defvar *optimize-speed* - '(optimize (speed 3) (safety 0) (ext:inhibit-warnings 3) #+small (debug 0.5)) - "This variable is used in various places in PCL as an optimization -declaration.") -) + (defvar *optimize-speed* '(optimize (speed 3) (safety 0) + (ext:inhibit-warnings 3) #+small (debug 0.5)))) ;;; Various macros that include necessary declarations for maximum ;;; performance. @@ -52,10 +49,12 @@ declaration.") (defsetf %svref %set-svref) (defmacro %set-svref (vector index new-value) - `(locally (declare #.*optimize-speed* - (inline svref)) - (setf (svref (the simple-vector ,vector) (the fixnum ,index)) - ,new-value))) + ;; Do it this way so that the evaluation of NEW-VALUE doesn't fall + ;; under the *OPTIMIZE-SPEED*. + (ext:once-only ((value new-value)) + `(locally (declare #.*optimize-speed* (inline svref)) + (setf (svref (the simple-vector ,vector) (the fixnum ,index)) + ,value)))) ;;; ;;; With-Pcl-Lock @@ -93,11 +92,7 @@ declaration.") ;;; ;;; set-function-name ;;; When given a function should give this function the name <new-name>. -;;; Note that <new-name> is sometimes a list. Some lisps get the upset -;;; in the tummy when they start thinking about functions which have -;;; lists as names. To deal with that there is intern-function-name -;;; which takes a list spec for a function name and turns it into a symbol -;;; if need be. +;;; Note that <new-name> is sometimes a list. ;;; ;;; When given a funcallable instance, set-function-name MUST side-effect ;;; that FIN to give it the name. When given any other kind of function @@ -106,40 +101,31 @@ declaration.") ;;; ;;; In all cases, set-function-name must return the new (or same) function. ;;; -(defun set-function-name (fcn new-name) +(defun set-function-name (function new-name) "Set the name of a compiled function object and return the function." (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)) - (eval:interpreted-function - (setf (eval:interpreted-function-name fcn) new-name)))) - fcn) - (t fcn))) - -;;; -;;; Note: While we don't need intern-function-name for -;;; set-function-name, this is used in boot.lisp. -;;; -(defun intern-function-name (name) - (cond ((symbolp name) name) - ((listp name) - (intern (let ((*package* *the-pcl-package*) - (*print-case* :upcase) - (*print-pretty* nil) - (*print-gensym* 't)) - (format nil "~S" name)) - *the-pcl-package*)))) + (when (ext:valid-function-name-p function) + (setq function (fdefinition function))) + (when (funcallable-instance-p function) + (if (if (eq *boot-state* 'complete) + (typep function 'generic-function) + (eq (class-of function) *the-class-standard-generic-function*)) + (setf (kernel:%funcallable-instance-info function 1) new-name) + (typecase function + (kernel:byte-closure + (set-function-name (kernel:byte-closure-function function) + new-name)) + (kernel:byte-function + (setf (kernel:byte-function-name function) new-name)) + (eval:interpreted-function + (setf (eval:interpreted-function-name function) new-name))))) + (when (memq (car-safe new-name) '(method fast-method slot-accessor)) + (setf (fdefinition new-name) function)) + function) + +(defun symbolicate (pkg &rest things) + (let ((*package* pkg)) + (apply #'ext:symbolicate things))) ;;; @@ -165,7 +151,7 @@ the compiler as completely as possible. Currently this means that ;;; ;;; This macro will precompile various PCL-generated code fragments, ;;; so that those won't have to be compiled lazily at run-time. For -;;; correct usage the invokation of `precompile-random-code-segments' +;;; correct usage the invocation of `precompile-random-code-segments' ;;; needs to be put in a file, which is compiled via `compile-file', ;;; and then loaded. ;;; @@ -173,13 +159,10 @@ the compiler as completely as possible. Currently this means that (defmacro precompile-random-code-segments (&optional system) `(progn (eval-when (:compile-toplevel) - (update-dispatch-dfuns) - (compile-iis-functions nil)) + (update-dispatch-dfuns)) (precompile-function-generators ,system) (precompile-dfun-constructors ,system) - (precompile-iis-functions ,system) - (eval-when (:load-toplevel) - (compile-iis-functions t)))) + (precompile-ctors))) ;;;; STD-INSTANCE @@ -205,12 +188,16 @@ the compiler as completely as possible. Currently this means that (deftransform pcl::pcl-instance-p ((object)) (let* ((otype (continuation-type object)) (std-obj (specifier-type 'pcl::std-object))) - (cond - ;; Flush tests whose result is known at compile time. - ((csubtypep otype std-obj) 't) - ((not (types-intersect otype std-obj)) 'nil) - (t - `(typep (kernel:layout-of object) 'pcl::wrapper))))) + ;; Flush tests whose result is known at compile time. + (cond ((csubtypep otype std-obj) + 't) + ((not (types-intersect otype std-obj)) + 'nil) + ((and (kernel::standard-class-p otype) + (pcl::info-std-class-p (kernel:%class-name otype))) + 't) + (t + `(typep (kernel:layout-of object) 'pcl::wrapper))))) (in-package "PCL") @@ -218,12 +205,14 @@ the compiler as completely as possible. Currently this means that (defun pcl-instance-p (x) (typep (kernel:layout-of x) 'wrapper)) -;;; Support for sensible sxhash codes for instances (let ((hash-code 0)) - (declare (fixnum hash-code) (optimize (speed 3) (safety 0))) + (declare (fixnum hash-code)) (defun get-instance-hash-code () - (setq hash-code (ext:truly-the fixnum (+ hash-code 1))))) + (if (< hash-code most-positive-fixnum) + (incf hash-code) + (setq hash-code 0)))) +;;; ;;; 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. @@ -231,19 +220,17 @@ the compiler as completely as possible. Currently this means that (defstruct (standard-instance (:predicate nil) (:constructor %%allocate-instance--class ()) - (:alternate-metaclass kernel:instance lisp:standard-class + (:alternate-metaclass kernel:instance kernel::standard-class kernel:make-standard-class)) (slots nil) (hash-code (get-instance-hash-code) :type fixnum)) -;;; This doesn't work on structures, but is only called from sxhash which -;;; ensures it isn't called with a structure. -(defmacro std-instance-hash-code (x) `(kernel:%instance-ref ,x 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-hash (x) `(kernel:%instance-ref ,x 2)) (defmacro std-instance-wrapper (x) `(kernel:%instance-layout ,x)) (defmacro built-in-or-structure-wrapper (x) `(kernel:layout-of ,x)) @@ -260,10 +247,15 @@ the compiler as completely as possible. Currently this means that ,wrapper nil))) +(defmacro get-hash (instance) + `(cond ((std-instance-p ,instance) (std-instance-hash ,instance)) + ((fsc-instance-p ,instance) (fsc-instance-hash ,instance)) + (t (internal-error "What kind of instance is this?")))) + (defmacro get-slots (inst) `(cond ((std-instance-p ,inst) (std-instance-slots ,inst)) ((fsc-instance-p ,inst) (fsc-instance-slots ,inst)) - (t (error "What kind of instance is this?")))) + (t (internal-error "What kind of instance is this?")))) (defmacro get-slots-or-nil (inst) (ext:once-only ((n-inst inst)) @@ -285,21 +277,38 @@ the compiler as completely as possible. Currently this means that ;;; Slot access itself -(defmacro %instance-ref (slots index) +(defmacro %slot-ref (slots index) `(%svref ,slots ,index)) -(defmacro instance-ref (slots index) +(defmacro slot-ref (slots index) `(svref ,slots ,index)) ;;; -;;; This is the value that we stick into a slot to tell us that it is unbound. -;;; It may seem gross, but for performance reasons, we make this an interned -;;; symbol. That means that the fast check to see if a slot is unbound is to -;;; say (EQ <val> '..SLOT-UNBOUND..). That is considerably faster than looking -;;; at the value of a special variable. +;;; The problem with unbound markers is that they cannot be dumped to +;;; fasl files. So, we need to create unbound markers in some way, +;;; which can be done by returning one from a compiled function. The +;;; problem with that is that it's awefully slow, and inlining the +;;; function creating the unbound marker doesn't work with interpreted +;;; code, because C::%%PRIMITIVE, which is used to create the unbound +;;; marker isn't defined when inlining happens. Using LOAD-TIME-VALUE +;;; and a symbol macro is relatively fast, but not fast enough. +;;; +;;; Maybe one should support dumping unbound markers to fasl files? ;;; +#+nil +(progn + (defun make-unbound-marker () + (lisp::%primitive c:make-other-immediate-type 0 vm:unbound-marker-type)) + (define-symbol-macro +slot-unbound+ + (load-time-value (make-unbound-marker) t))) + +#-nil (defconstant +slot-unbound+ '..slot-unbound..) +(defun internal-error (format-control &rest format-args) + (error (format nil "~~@<Internal error: ~?~~@:>" + format-control format-args))) + ;;;; Structure-instance stuff: @@ -310,21 +319,32 @@ the compiler as completely as possible. Currently this means that (typep x 'lisp:structure-object)) (defun structure-type (x) - (lisp:class-name (kernel:layout-class (kernel:%instance-layout x)))) - + (kernel:%class-name (kernel:layout-class (kernel:%instance-layout x)))) +;;; +;;; Return true if TYPE is the name of a structure. Note that we +;;; return false for conditions, which aren't "real" structures. +;;; (defun structure-type-p (type) (and (symbolp type) - (let ((class (lisp:find-class type nil))) + (not (condition-type-p type)) + (let ((class (kernel::find-class type nil))) (and class ;; class may not be complete if created by ;; inform-type-system-aboutd-std-class - (kernel:class-layout class) - (typep (kernel:layout-info (kernel:class-layout class)) + (kernel:%class-layout class) + (typep (kernel:layout-info (kernel:%class-layout class)) 'kernel:defstruct-description))))) +;;; +;;; Returne true if TYPE is the name of a condition. +;;; +(defun condition-type-p (type) + (and (symbolp type) + (conditions::condition-class-p (kernel::find-class type nil)))) + (defun get-structure-dd (type) - (kernel:layout-info (kernel:class-layout (lisp:find-class type)))) + (kernel:layout-info (kernel:%class-layout (kernel::find-class type)))) (defun structure-type-included-type-name (type) (let ((include (kernel::dd-include (get-structure-dd type)))) @@ -363,6 +383,9 @@ the compiler as completely as possible. Currently this means that ;;; reporting. ;;; +(defun kernel::kernel-class-of-pcl-class (class) + (kernel::find-class (class-name class))) + (in-package "C") (def-source-context pcl:defmethod (name &rest stuff) @@ -372,3 +395,26 @@ the compiler as completely as possible. Currently this means that ,(nth-value 2 (pcl::parse-specialized-lambda-list (elt stuff arg-pos)))) `(pcl:defmethod ,name "<illegal syntax>")))) + +(in-package "PCL") + +(defun early-pcl-init () + ;; defsys + (setq *the-pcl-package* (find-package "PCL")) + (setq *boot-state* nil) + (setq *dfun-constructors* nil) + ;; + ;; Show us when we use the compiler. + (setq *compile-lambda-silent-p* nil) + ;; + ;; Wait with installing optimized constructors until we can + ;; invoke the compiler. + (setq *cold-boot-state* t)) + +(defun final-pcl-init () + (setq *cold-boot-state* nil) + (setq *compile-lambda-silent-p* t) + (dolist (ctor *all-ctors*) + (install-optimized-constructor ctor))) + +;;; end of low.lisp diff --git a/pcl/macros.lisp b/pcl/macros.lisp index 24e86e70f..ba3a1f0a0 100644 --- a/pcl/macros.lisp +++ b/pcl/macros.lisp @@ -26,7 +26,7 @@ ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/macros.lisp,v 1.21 2002/08/27 19:01:39 pmai Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/macros.lisp,v 1.22 2003/03/22 16:15:16 gerd Exp $") ;;; ;;; Macros global variable definitions, and other random support stuff used ;;; by the rest of the system. @@ -37,42 +37,51 @@ (in-package :pcl) -(declaim (declaration - values ;;I use this so that Zwei can remind - ;;me what values a function returns. - - arglist ;;Tells me what the pretty arglist - ;;of something (which probably takes - ;;&rest args) is. - - indentation ;;Tells ZWEI how to indent things - ;;like defclass. - class - variable-rebinding - pcl-fast-call - method-name - method-lambda-list - )) +(declaim (declaration class variable-rebinding method-name + method-lambda-list)) +(eval-when (:compile-toplevel :load-toplevel :execute) + + ;; (CLASS-PREDICATE <CLASS-NAME> + (ext:define-function-name-syntax class-predicate (name) + (symbolp (cadr name))) + + ;; (SLOT-ACCESSOR <CLASS> <SLOT> <READER/WRITER/BOUNDP>) + ;; <CLASS> is :GLOBAL for functions used by ACCESSOR-SLOT-VALUE etc. + (ext:define-function-name-syntax slot-accessor (name) + (and (symbolp (cadr name)) + (consp (cddr name)) + (symbolp (caddr name)) + (consp (cdddr name)) + (member (cadddr name) '(reader writer boundp)))) + + ;; (METHOD NAME QUALIFIERS (SPECIALIZERS)) + (ext:define-function-name-syntax method (name) + (ext:valid-function-name-p (cadr name))) + + ;; (FAST-METHOD NAME QUALIFIERS (SPECIALIZERS)) + (ext:define-function-name-syntax fast-method (name) + (ext:valid-function-name-p (cadr name))) + + ;; (EFFECTIVE-METHOD GF-NAME METHOD-SPEC ...) + (ext:define-function-name-syntax effective-method (name) + (ext:valid-function-name-p (cadr name))) + + ;; (CALL FUNCTION)? + ) + +;;; ;;; Age old functions which CommonLisp cleaned-up away. They probably exist ;;; in other packages in all CommonLisp implementations, but I will leave it ;;; to the compiler to optimize into calls to them. ;;; -;;; Common Lisp BUG: -;;; Some Common Lisps define these in the Lisp package which causes -;;; all sorts of lossage. Common Lisp should explictly specify which -;;; symbols appear in the Lisp package. -;;; (eval-when (:compile-toplevel :load-toplevel :execute) - -(defmacro memq (item list) `(member ,item ,list :test #'eq)) -(defmacro assq (item list) `(assoc ,item ,list :test #'eq)) -(defmacro rassq (item list) `(rassoc ,item ,list :test #'eq)) -(defmacro delq (item list) `(delete ,item ,list :test #'eq)) -(defmacro posq (item list) `(position ,item ,list :test #'eq)) -(defmacro neq (x y) `(not (eq ,x ,y))) - -) + (defmacro memq (item list) `(member ,item ,list :test #'eq)) + (defmacro assq (item list) `(assoc ,item ,list :test #'eq)) + (defmacro rassq (item list) `(rassoc ,item ,list :test #'eq)) + (defmacro delq (item list) `(delete ,item ,list :test #'eq)) + (defmacro posq (item list) `(position ,item ,list :test #'eq)) + (defmacro neq (x y) `(not (eq ,x ,y)))) (defun true (&rest ignore) (declare (ignore ignore)) t) (defun false (&rest ignore) (declare (ignore ignore)) nil) @@ -85,7 +94,7 @@ (return-from get-declaration (cdr form)))))) -(defvar *keyword-package* (find-package 'keyword)) +(defvar *keyword-package* (find-package "KEYWORD")) (defun make-keyword (symbol) (intern (symbol-name symbol) *keyword-package*)) @@ -125,30 +134,6 @@ (declare (ignore thing stream)) nil) - ;; -;;;;;; - ;; - -(defun capitalize-words (string &optional (dashes-p t)) - (let ((string (copy-seq (string string)))) - (declare (string string)) - (do* ((flag t flag) - (length (length string) length) - (char nil char) - (i 0 (+ i 1))) - ((= i length) string) - (setq char (elt string i)) - (cond ((both-case-p char) - (if flag - (and (setq flag (lower-case-p char)) - (setf (elt string i) (char-upcase char))) - (and (not flag) (setf (elt string i) (char-downcase char)))) - (setq flag nil)) - ((char-equal char #\-) - (setq flag t) - (unless dashes-p (setf (elt string i) #\space))) - (t (setq flag nil)))))) - ;;; ;;; FIND-CLASS ;;; @@ -177,7 +162,7 @@ (or (gethash symbol *find-class*) (unless dont-create-p (unless (legal-class-name-p symbol) - (error "~S is not a legal class name." symbol)) + (error "~@<~S is not a legal class name.~@:>" symbol)) (setf (gethash symbol *find-class*) (make-find-class-cell symbol))))) (defvar *create-classes-from-internal-structure-definitions-p* t) @@ -185,11 +170,11 @@ (defun find-class-from-cell (symbol cell &optional (errorp t)) (or (find-class-cell-class cell) (and *create-classes-from-internal-structure-definitions-p* - (structure-type-p symbol) - (find-structure-class symbol)) + (or (condition-type-p symbol) (structure-type-p symbol)) + (ensure-non-standard-class symbol)) (cond ((null errorp) nil) ((legal-class-name-p symbol) - (error "No class named: ~S." symbol)) + (error "No class named ~S." symbol)) (t (error "~S is not a legal class name." symbol))))) @@ -199,16 +184,14 @@ (find-class-cell-predicate cell)) (defun legal-class-name-p (x) - (and (symbolp x) - (not (keywordp x)))) + (symbolp x)) (defun find-class (symbol &optional (errorp t) environment) "Returns the PCL class metaobject named by SYMBOL. An error of type SIMPLE-ERROR is signaled if the class does not exist unless ERRORP is NIL in which case NIL is returned. SYMBOL cannot be a keyword." (declare (ignore environment)) - (find-class-from-cell - symbol (find-class-cell symbol t) errorp)) + (find-class-from-cell symbol (find-class-cell symbol t) errorp)) (defun find-class-predicate (symbol &optional (errorp t) environment) (declare (ignore environment)) @@ -217,16 +200,21 @@ (defvar *boot-state* nil) ; duplicate defvar to defs.lisp -; Use this definition in any CL implementation supporting -; both define-compiler-macro and load-time-value. -; Note that in CMU, lisp:find-class /= pcl:find-class -(define-compiler-macro find-class (&whole form - symbol &optional (errorp t) environment) +;;; +;;; When compiling #+BOOTABLE, *BOOT-STATE* is COMPLETE because that's +;;; the setting of the host PCL. We'd could use something like +;;; *COMPILE-STATE* to tell the compiler macro when it should optimize +;;; or not in such a setting. For simplicity we just don't optimize +;;; in the bootable PCL. +;;; +(define-compiler-macro find-class (&whole form symbol + &optional (errorp t) environment) (declare (ignore environment)) (if (and (constantp symbol) (legal-class-name-p (eval symbol)) (constantp errorp) - (member *boot-state* '(braid complete))) + (member *boot-state* '(braid complete)) + (not (intersection '(:loadable-pcl :bootable-pcl) *features*))) (let ((symbol (eval symbol)) (errorp (not (null (eval errorp)))) (class-cell (make-symbol "CLASS-CELL"))) @@ -247,13 +235,8 @@ (eq *boot-state* 'braid)) (when (and new-value (class-wrapper new-value)) (setf (find-class-cell-predicate cell) - (symbol-function (class-predicate-name new-value)))) - (when (and new-value (not (forward-referenced-class-p new-value))) - - (dolist (keys+aok (find-class-cell-make-instance-function-keys cell)) - (update-initialize-info-internal - (initialize-info new-value (car keys+aok) nil (cdr keys+aok)) - 'make-instance-function)))) + (fdefinition (class-predicate-name new-value)))) + (update-ctors 'setf-find-class :class new-value :name symbol)) new-value) (error "~S is not a legal class name." symbol))) @@ -271,16 +254,28 @@ (defsetf slot-value set-slot-value) -(defvar *redefined-functions* nil) +(declaim (inline car-safe)) + +(defun car-safe (obj) + (when (consp obj) + (car obj))) + +(defvar *cold-boot-state* nil) + +#+pcl-debug +(defmacro %print (&rest args) + `(when *cold-boot-state* + (system:%primitive print ,@args))) + +#-pcl-debug +(defmacro %print (&rest args) + (declare (ignore args))) -(defmacro original-definition (name) - `(get ,name :definition-before-pcl)) +#+bootable-pcl +(defmacro /show (msg) + `(system:%primitive print ,msg)) -(defun redefine-function (name new) - (pushnew name *redefined-functions*) - (unless (original-definition name) - (setf (original-definition name) - (symbol-function name))) - (setf (symbol-function name) - (symbol-function new))) +#-bootable-pcl +(defmacro /show (&rest args) + ) diff --git a/pcl/march-92-notes.text b/pcl/march-92-notes.text deleted file mode 100644 index 913ee4e97..000000000 --- a/pcl/march-92-notes.text +++ /dev/null @@ -1,311 +0,0 @@ -These notes correspond to the "March 92 PCL (beta1)" version of PCL. - - This version of PCL is much closer than previous versions of PCL -to the metaobject protocol specified in "The Art of the Metaobject Protocol", -chapters 5 and 6, by Gregor Kiczales, Jim des Riveres, and Daniel G. Bobrow. - - -[Please read the file may-day-notes.text also. Most of that file still applies.] - -Support for structures - You can use structure-class as a metaclass to create new classes. - Classes created this way create and evaluate defstruct forms which - have generated symbols for the structure accessors and constructor. - The generated symbols are used by the primary slot-value-using-class - methods and by the primary allocate-instance method for structures. - Defmethod optimizes usages of slot-value (when no user-defined - slot-value-using-class methods exist) into direct calls of the - generated symbol accessor, which the compiler can then optimize further. - Even when there are user-defined methods on slot-value-using-class, - PCL does a variety of optimizations. - - If your implementation's version of the *-low.lisp file - contains definitions of certain structure functions (see the end of - low.lisp, cmu-low.lisp, lucid-low.lisp, and kcl-low.lisp), then - structure classes are supported for all defstructs. In this case, - structure classes are created automatically, when necessary. - -New Classes: -structure-class -structure-object -slot-class -slot-object -structure-direct-slot-definition -structure-effective-slot-definition - -Improvements to slot-access - Optimization for slot-value outsize of defmethod - Optimization for slot-value inside of defmethod, but not of a specialized parameter. - Optimizations that work even when there are :around methods - on slot-value-using-class. - -New types: - `(class ,class-object) - `(class-eq ,class-object) - -New specializer class: class-eq-specializer - Every class has a class-eq specializer which represents all - the direct instances of that class. - This is useful in *subtypep. For example, here is the way - generic-function initialization checks that the method-class is valid: - (and (classp method-class) - (*subtypep (class-eq-specializer method-class) - (find-class 'standard-method))) - If you want to define methods having class-eq specializers, - see "Initialization of method metaobjects". The default behavior of PCL - is to disallow this. - -compute-applicable-methods-using-types - -caching improvements - -no magic-generic-functions list - This simplifies some things, but complicates some other things. - I wanted to support user-defined classes which are their own metaclass. - You can now do: -(defclass y (standard-class) ()) -(defmethod validate-superclass ((c y) (sc standard-class)) t) -(defclass y (standard-class) () (:metaclass y)) - -method-function changes (see the comments for make-method-lambda, below) - -final dfuns - -------------------------- - -gfs which obey AMOP ch 6 - add-dependent - add-direct-method - add-direct-subclass - add-method - allocate-instance - compute-class-precedence-list - compute-default-initargs - compute-effective-slot-definition -[Note: compute-effective-slot-definition relys on - compute-effective-slot-definition-initargs and effective-slot-definition-class. - compute-effective-slot-definition-initargs is quite useful, but is not in - AMOP ch 6.] - compute-slots - direct-slot-definition-class - effective-slot-definition-class - ensure-class - ensure-class-using-class - ensure-generic-function - ensure-generic-function-using-class - eql-specializer-object - extract-lambda-list - extract-specializer-names - finalize-inheritance - find-method-combination - funcallable-standard-instance-access - {generic-function-method-class, generic-function-method-combination, - generic-function-lambda-list, generic-function-methods, generic-function-name} - intern-eql-specializer - make-instance - map-dependents - {method-function, method-generic-function, method-lambda-list, - method-specializers, method-qualifiers} - {class-default-initargs, class-direct-default-initargs, class-direct-slots, - class-direct-subclasses, class-direct-superclasses, class-finalized-p, - class-name, class-precedence-list, class-prototype, class-slots} - {slot-definition-allocation, slot-definition-initargs, slot-definition-initform, - slot-definition-initfunction, slot-definition-name, slot-definition-type} - {slot-definition-readers, slot-definition-writers} - {slot-definition-location} - remove-dependent - remove-direct-method - remove-direct-subclass - remove-method - set-funcallable-instance-function - (setf slot-value-using-class) - slot-boundp-using-class - slot-makunbound-using-class - specializer-direct-generic-functions - specializer-direct-methods - standard-instance-access - update-dependent - -gfs which DO NOT obey AMOP ch 6 - -accessor-method-slot-definition - Not yet defined. Use accessor-method-slot-name and method-specializers - to get the direct-slot-definition. - -compute-applicable-methods -compute-applicable-methods-using-classes - Handles class-eq specializers without signalling an error. - But see "Initialization of method metaobjects", below. - -compute-discriminating-function - [the resulting function works differently different because - compute-effective-method is different, and because make-method-lambda - does not exist.] - -compute-effective-method - Returns only one value. The utility of bringing this into conformance with - AMOP ch 6 is limited by the lack of make-method-lambda. - -generic-function-argument-precedence-order - Not yet defined. Can get this information from the arg-info structure. - -generic-function-declarations - Not yet defined. - -make-method-lambda - Does not exist. This will be hard to add in a way that is compatible with - AMOP ch 6. - 1. In March 92 PCL, there are two kinds of method-functions. The first kind - is what method-function returns (which has no special restrinctions on its use). - The second kind is returned by method-function-for-caching, which is used - when the wrappers of the required arguments are known. Each call to - method-function-for-caching might return a new function. Both kinds of - method functions can be closures. March 92 PCL currently uses this scheme - to do the pv-lookup ahead of time, thereby eliminating pv caching. - (pv-lookup means the lookup of the permutation vectors which are used for - fast instance varaible access.) Method function closures can also be used - in the optimization of calls to generic-functions, but this has not yet been - implemented. - 2. Since method-functions can be closures, we would need an extra step between - compiling (or coercing) the method-lambda into a function, before it can be - applied to arguments with apply or funcall. - -reader-method-class - Not yet defined. Some bootstrapping considerations are involved, - but adding this will not be very hard. - -(setf class-name) - Currently just a writer method. Does not call reinitialize-instance or - (setf find-class). - -(setf generic-function-name) - Currently just a writer method. Does not call reinitialize-instance. - -writer-method-class - Not yet defined. Some bootstrapping considerations are involved, - but adding this will not be very hard. - ---------------------------- - -Initialization of method metaobjects - The following methods are defined: - legal-qualifiers-p (method standard-method) qualifiers - legal-lambda-list-p (method standard-method) lambda-list - legal-specializers-p (method standard-method) specializers - legal-method-function-p (method standard-method) function - legal-documentation-p (method standard-method) documentation - - legal-specializer-p (method standard-method) specializer - - You can override them if you want. - The method for legal-specializers-p calls legal-specializer-p - on each specializer. - The method for legal-specializer-p allows any kind of specializer - when the variable *allow-experimental-specializers-p* is t - (this variable is initially nil). - ---------------------------- -Optimizations on slot-value - Outside of a defmethod when define-compiler-macro is not implemented - or the slot-name is not constant, or - Inside a defmethod when the slot-name is not a constant: -(1) no optimization of slot-value, slot-value-using-class is called. - slot-value-using-class has a special dfun, though, which calls - the slot's slot-definition-reader-function. This function is - a result of get-accessor-method-function. - Outside of a defmethod when define-compiler-macro is implemented and - the slot-name is a constant, or - Inside a defmethod when the slot-name is a constant but the object is - not either (the value of a parameter specialized to a subclass of structure-object - for which no user-defined slot-value-using-class methods apply at defmethod time), - or (the value of a parameter specialized to a subclass of standard-object). -(2) PCL arranges to call an automatically created generic function - which has one method: a reader method defined on class slot-object. - Inside a defmethod when the slot-name is a constant and the object - is (the value of a parameter specialized to a subclass of structure-object - for which no user-defined slot-value-using-class methods apply). -(3) The slot-value form is converted to a call of the structure slot's - accessor function, which the compiler can then optimize further. - Inside a defmethod when the slot-name is a constant and the object - is (the value of a parameter specialized to a subclass of standard-object). -(4) The access requires two arefs, a call to (typep x 'fixnum), and a call to eq, - in the best case. If user defined slot-value-using-class methods apply - at slot-value execution time, or the slot is unbound, the unoptimized - slot-value function (1) is called. This was in May Day PCL; what is new here - is that the PV (permutation vector) is looked up at defmethod load time - rather than at run time, if the effective method is cached. - -Generic functions containing only accessor methods for which no user-defined -methods on slot-value-using-class apply and which involve only standard-classes: - A special dfun is called: one-class, two-class, one-index, or n-n. - These were all in May Day PCL. -Generic functions excluded by the above, which contain accessor methods: - In place of each accessor method's method-function, a function returned by - get-accessor-method-function is used. - -get-accessor-method-function (gf type class slotd) ; type is reader, writer, or boundp. - If there is only one applicable method, - (This method will be the system supplied one) - the function that is returned is optimized for the current state of the - class. When the class changes, it must be recomputed. - otherwise, - a secondary dispatch function for slot-value-using-class is computed - (using what is known about the types of the arguments) and converted - into an accessor function. - -get-secondary-dispatch-function (gf methods types &optional method-alist wrappers) - The types argument describes what is known about the types of the arguments. - Method-alist is used (when supplied) to do things like replace the - standard slot-value-using-class method function with a function optimized - for what is known about the arguments. - Wrappers (when supplied) means that the resulting function is guaranteed to - be called only whith those wrappers. Make-effective-method-function calls - the generic-function method-function-for-caching with method-alist and - wrappers to get a optimized method function. (PV lookup is done at the time - method-function-for-caching is called). - -compute-applicable-methods: Here I tried to stick with the MOP. - The function cache-miss-values looks at the second value of the result of - compute-applicable-methods-using-classes. If this value is null, we aren't - supposed to cache the result of camuc. So we don't. Instead we cache a - result of (default-secondary-dispatch-function gf), which in turn calls - compute-applicable-methods each time it is called. ---------------------------- - -To do: - -1. Make the metaobject protocol function symbols be the external symbols - of a package, so they can be used easily. - -Problem: sometimes there is no need to call a gf's dfun: the emf that is invoked - can be cached in the caller's method closure. - make-instance is slow. -2. In expand-defmethod-internal, optimize calls to generic-functions. - Add the support for this optimization. - -3. Make sure that use-dispatch-dfun-p is doing the right thing. - -4. [When CMUCL improves its setf handling, remove the comment in - the file macros.lisp beginning the line ";#+cmu (pushnew :setf *features*)"] - - - --------------- -1) Generalize expand-defmethod-internal so that it can be used for non-defmethod -code. Maybe by (a) having a parameter that says whether it is being called by -defmethod, and (b) using the techniques used by the series package (shadowing -defun and some others, making the shadowed definitions call e-d-i, making it -easy for people to do the relevant package modifications) - -2) Extending generic-functions by allowing the user at defgeneric time to supply -the name of a function which will be supplied (by the system) with a definition -which will return equivalent results to those returned by the generic function, -but which will (in some cases) have less checking than the generic function. -One-class, two-class, and one-index gf dfuns will map to a result of -get-optimized-std-accessor-method-function, checking gf dfuns will map to their -function, and any other dfun will remain the same. - -3) Extending expand-defmethod-internal to optimize calls to generic-functions. -There are a variety of possibilities that need to be considered; one of them -will be to arrange to call the optimized functions produced by (2) when it -is known to be safe. diff --git a/pcl/may-day-notes.text b/pcl/may-day-notes.text deleted file mode 100644 index 3e2175e24..000000000 --- a/pcl/may-day-notes.text +++ /dev/null @@ -1,98 +0,0 @@ -Copyright (c) Xerox Corporation 1989, 1990. All rights reserved. - -These notes correspond to the "5/1/90 May Day PCL (REV 2)" version of PCL. - -This version is just Rainy Day PCL with the various patches people have -mailed out included. Barring unforseen circumstances, this will be the -last version of PCL. We are now working on the Metaobject Protocol. - - -Please read this entire file carefully. Failure to do so guarantees -that you will have problems porting your code from the previous release -of PCL. - -You may also be interested in looking at previous versions of the -notes.text file. These are called xxx-notes.text where xxx is the -version of the PCL system the file corresponds to. At least the last -two versions of this file contain useful information for any PCL user. - -This version of PCL has been tested at PARC in the following Common -Lisps: - - Symbolics 7.2, 7.4 - Coral 1.3 - Lucid 3.0 - Allegro 3.0.1 - -These should work, but haven't been tested yet: - - TI - Golden Common Lisp 3.1 - EnvOS Medley - IBCL (October 15, 1987) - -This release of PCL is substantially different from previous releases. -The architecture of the runtime system (method lookup and slot access) -is different, and the metaobject protocol is different. Much of the -code in this release is new or modified from the last release. - -When it stabilizes, this release should be much faster for all -applications especially large ones. - -This beta version of the new release includes a number of known -problems. These include: - -* Even less documentation than ever before. I haven't written much of a -notes file for what is different yet. Please send me comments for what -to include in this file. - -* Some known performance problems in development versions of compilers. -At the very least, you want to compile PCL itself using the highest -performance compiler settings you have. - - -=== Notes for this release (such as they are) === - -* There is one major incompatible change in this release. In this -release compiling files with defmethod and defclass forms doesn't, by -default, affect the running lisp image. The winning part of this is you -can compile a file without `installing' the class and method definitions -in the file. The losing part is that because PCL is a portable program, -it can't both do this and let a class definition and a method which -specializes to that class appear in the same file. - -So, you can't (by default) have: - - (defclass foo () ()) - (defmethod bar ((f foo)) 'foo) - -in the same file. - -But you say you want to do this, almost everyone does. If you want to -do this just evaluate the following form before after loading PCL but -before working with it: - - (pushnew 'compile pcl::*defclass-times*) - -You may also want to do: - - (pushnew 'compile pcl::*defmethod-times*) - - -* You probably also want to begin using a precom file for your system. -Do this by having a file whose only contents is - - (pcl::precompile-random-code-segments <your-system-name>) - -don't quote <your-system-name> - -for example, for the clim system, the precom file has the one line: - - (pcl::precompile-random-code-segments clim) - -compile this file after loading and running your system for a while. -load it before loading your compiled system. A future version of this -feature won't require you to have run your system for a while, it will -only require that you have loaded it. - - diff --git a/pcl/method-slot-access-optimization.lisp b/pcl/method-slot-access-optimization.lisp new file mode 100644 index 000000000..9eaccf605 --- /dev/null +++ b/pcl/method-slot-access-optimization.lisp @@ -0,0 +1,779 @@ +;;; Copyright (C) 2002, 2003 Gerd Moellmann <gerd.moellmann@t-online.de> +;;; All rights reserved. +;;; +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: +;;; +;;; 1. Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. +;;; 2. Redistributions in binary form must reproduce the above copyright +;;; notice, this list of conditions and the following disclaimer in the +;;; documentation and/or other materials provided with the distribution. +;;; 3. The name of the author may not be used to endorse or promote +;;; products derived from this software without specific prior written +;;; permission. +;;; +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE +;;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +;;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT +;;; OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR +;;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE +;;; USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH +;;; DAMAGE. + +;;; *************** +;;; Overview ***** +;;; *************** +;;; +;;; Code generation for optimized slot access in methods. +;;; +;;; Parts of this code may be derived from code in Xerox-PCL's +;;; vector.lisp, although heavily rewritten. See vector.lisp for +;;; Xerox' copyright and licensing information. +;;; +;;; ******************** +;;; Entry Points ****** +;;; ******************** +;;; +;;; OPTIMIZE-SLOT-ACCESS, OPTIMIZE-SLOT-READER, OPTIMIZE-SLOT-WRITER +;;; are called from WALK-METHOD-LAMBDA. +;;; +;;; ******************* +;;; To Do/Ideas ****** +;;; ******************* +;;; +;;; - Prevent PV lookup if only inline access is done? +;;; + +(ext:file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/method-slot-access-optimization.lisp,v 1.2 2003/03/22 16:15:16 gerd Exp $") + +(in-package "PCL") + +(defvar *optimize-inline-slot-access-p* t + "Set to true to activate the inline slot access optimization.") + +(defvar *use-slot-types-p* t + "When true, check slot values against specified slot types.") + +(defvar *optimize-accessor-calls-p* t + "When true, optimize slot access through slot reader/writer functions.") + + +;;; ******************* +;;; Conditions ******* +;;; ******************* + +(define-condition slot-access-warning (simple-warning) + ((class :reader slot-access-warning-class :initarg :class) + (title :reader slot-access-warning-title :initarg :title)) + (:report (lambda (condition stream) + (format stream + (format nil "~~@<~a ~s. ~?~~@:>" + (slot-access-warning-title condition) + (slot-access-warning-class condition) + (simple-condition-format-control condition) + (simple-condition-format-arguments condition)))))) + +(define-condition cant-optimize-warning (slot-access-warning) ()) +(define-condition method-recompilation-warning (slot-access-warning) ()) + +(defun cant-optimize (class format-control &rest format-args) + (warn 'cant-optimize-warning + :title "Cannot optimize slot access to" + :class class + :format-control format-control + :format-arguments format-args)) + + +;;; ************************** +;;; Support Functions ******* +;;; ************************** + +;;; +;;; This macro is used to make optimized forms which should not be +;;; further optimized recognizable while walking the method body. +;;; +(defmacro optimized-marker (x) x) +(define-walker-template optimized-marker) + +;;; +;;; Return the type of slot SLOT-NAME in class CLASS for slot access +;;; optimizations. Return T if no type is specified for the slot. +;;; +(defun slot-type (class slot-name) + (or (and *use-slot-types-p* + (decide-slot-type class slot-name)) + t)) + +;;; +;;; Add an entry for accessing slot SLOT-NAME through parameter PARAM +;;; to PARAM-SLOTS, if it's not already there. Add PV-OFFSET to the +;;; list of pv offset forms used for accessing SLOT-NAME through PARAM, +;;; if a PV-OFFSET form is specified. +;;; +;;; Value is the name of the variable that will be bound to the slot +;;; vector of PARAM on method entry. +;;; +(defun add-param-slot-entry (param slot-name param-slots + &optional (pv-offset nil pv-offset-supplied-p)) + (let* ((param-entry (assoc param param-slots :test #'eq)) + (slot-entry (assoc slot-name (cdr param-entry) + :test (if (symbolp slot-name) #'eq #'equal)))) + (unless slot-entry + (setq slot-entry (list slot-name)) + (push slot-entry (cdr param-entry))) + (when pv-offset-supplied-p + (push pv-offset (cdr slot-entry))) + (slot-vector-symbol (position param-entry param-slots :test #'eq)))) + +;;; +;;; Return true if PARAM-ENTRY has anything in it required a pv lookup. +;;; +(defun pv-optimized-param-p (param-entry) + (loop for (slot-name . pv-offsets) in (cdr param-entry) + thereis (or (symbolp slot-name) + (not (equal '(inline-access) slot-name))))) + + +;;; ************************************************************************ +;;; ******** Optimizing SLOT-VALUE, SLOT-BOUNDP, (SETF SLOT-VALUE) ******* +;;; ************************************************************************ + +;;; +;;; This function is called from WALK-METHOD-LAMBDA for optimizing +;;; SLOT-VALUE, (SETF SLOT-VALUE), and SLOT-BOUNDP. +;;; +;;; FORM is the form to optimize, and ENV is the environment where +;;; the form occurs. +;;; +;;; REQUIRED-PARAMS is a list of the required parameters of the method +;;; in which FORM occurs. +;;; +;;; PARAM-SLOTS is an alist with an entry for each required parameter. +;;; The CAR of each entry is the name of a required parameter to the +;;; method. The CDR of of each entry is a list of (SLOT-NAME +;;; PV-OFFSET ...) lists, where SLOT-NAME is either the name of a +;;; slot, or a pseudo slot name like (READER <gf-name>). Each +;;; PV-OFFSET is a form (PV-OFFSET -1) used in a pv-optimization. The +;;; -1 gets backpatched to an actual pv-index (index in permutation +;;; vector) by MUTATE-SLOTS. +;;; +;;; The alist is in order, so the position of an entry in the alist +;;; corresponds to the argument's position in the method lambda list. +;;; +(defun optimize-slot-access (form env required-params param-slots) + (destructuring-bind (fn instance slot-name &optional value) form + (multiple-value-bind (access fallback-macro) + (ecase fn + (slot-value (values 'slot-value 'accessor-slot-value)) + (slot-boundp (values 'slot-boundp 'accessor-slot-boundp)) + (set-slot-value (values 'setf 'accessor-set-slot-value))) + (assert (constantp slot-name)) + (let ((slot-name (eval slot-name)) + (fallback-access `(,fallback-macro (optimized-marker ,instance) + ,@(cddr form)))) + (multiple-value-bind (param class optimize-p) + (get-param/class-to-optimize instance required-params env + access slot-name) + (cond ((not optimize-p) + (when param + (check-inline-access-p class slot-name env)) + fallback-access) + ((and (eq *boot-state* 'complete) + (classp class) + (member *the-class-structure-object* + (class-precedence-list class) :test #'eq)) + (emit-structure-access access param class slot-name value)) + ((check-inline-access-p class slot-name env) + (emit-inline-access access param class slot-name value + param-slots env)) + (t + (emit-pv-access access param class slot-name value + param-slots fallback-access env)))))))) + +;;; +;;; Determine method parameter and its class for slot access +;;; optimization. INSTANCE is the instance part of the form being +;;; optimized. REQUIRED-PARAMS is a list of the names of the required +;;; parameters of the method being optimized. ENV is the environment +;;; in which the slot access occurs. +;;; +;;; SLOT-VALUE-ACCESS being one of the symbols SLOT-VALUE, +;;; SLOT-BOUNDP, or SETF means the slot access is through one of these +;;; operators. SLOT-NAME must be the name of the slot being accessed +;;; in these cases. SLOT-VALUE-ACCESS NIL means the access is through +;;; a reader/writer generic function. +;;; +;;; Values are either NIL or PARAM and CLASS. The NIL case means that +;;; this access shouldn't or can't be optimized. Otherwise, PARAM is +;;; the name of the method parameter through which the slot is +;;; accessed and CLASS is its class or the name of its class. +;;; +(defun get-param/class-to-optimize (instance required-params env + &optional slot-value-access slot-name) + (flet ((declared-rebound (instance env) + (caddr (variable-declaration 'variable-rebinding instance env))) + (declared-class (param env) + (caddr (variable-declaration 'class param env)))) + (let* ((instance (if (and (consp instance) (eq 'the (car instance))) + (caddr instance) + instance)) + (param (when (symbolp instance) + (car (member (or (declared-rebound instance env) instance) + required-params :test #'eq)))) + (class-name (when param + (declared-class param env))) + class + optimize-p) + (when (and class-name (not (eq class-name t))) + (setq class (when (eq *boot-state* 'complete) + (let ((class (find-class class-name nil))) + (when (and class (class-finalized-p class)) + class)))) + (setq optimize-p + ;; + ;; When access is through a slot reader/writer, it's + ;; not easy to tell which slot that reads, which we + ;; need below, so just optimize it and let the PV + ;; machinery figure out what to do. + (or (null slot-value-access) + ;; + ;; Problem during bootstrapping PCL: some generic + ;; functions are not yet available when this function + ;; is called, esp. SLOT-ACCESSOR-STD-P which is used + ;; in DECIDE-OPTIMIZE-SLOT-P. Calling these + ;; functions results in an error that the funcallable + ;; instance function of these generic functions is + ;; not set. + (not (eq *boot-state* 'complete)) + ;; + (decide-optimize-slot-p class-name slot-name + (ecase slot-value-access + (slot-value 'reader) + (slot-boundp 'boundp) + (setf 'writer)))))) + (values param (or class class-name) optimize-p)))) + +;;; +;;; Return true if access to slot SLOT-NAME of class CLASS should use +;;; the inline access method. +;;; +;;; Use inline slot access only if the class is known at compile time. +;;; To overcome this restriction, we would need to compute slot +;;; locations in the compile-time environment, that is, we would need +;;; to duplicate COMPUTE-SLOTS or something. Also, we would have to +;;; prevent methods on COMPUTE-SLOTS and maybe other methods that +;;; influence slot location computation. +;;; +(defun check-inline-access-p (class slot-name env) + (when (and *optimize-inline-slot-access-p* + (slot-declaration env 'inline class slot-name)) + (let ((slotd nil)) + (cond + ;; + ;; For now only for standard classes. If this + ;; is changed we need to get smart. + ((not (standard-class-p class)) + (cant-optimize class "The class is not a standard class")) + ;; + ((null (setq slotd (find-slot-definition class slot-name))) + (cant-optimize class "The class doesn't contain a slot with name ~s" + slot-name)) + ;; + ;; Class slots not implemented because it's difficult to + ;; back-patch the class slot cons cell into the code. It's + ;; anyway not important to optimize this. + ((consp (slot-definition-location slotd)) + (cant-optimize class "Slot ~s is a class slot" slot-name)) + ;; + ;; Check for non-standard slot accessors, SLOT-VALUE-USING-CLASS. + ((not (optimize-slot-value-by-class-p class slot-name 'all)) + (cant-optimize class "There are non-standard accessors for slot ~s" + slot-name)) + ;; + ;; Check if the accessed slot is at the same location in the + ;; class and all its subclasses. + ((not (slot-at-fixed-location-p class slot-name)) + (cant-optimize class "Slot ~s is not at the same location ~ + in the class and all of its subclasses" + slot-name)) + ;; + (t t))))) + +(defun optimize-slot-value-by-class-p (class slot-name type) + (or (not (eq *boot-state* 'complete)) + (let ((slotd (find-slot-definition class slot-name))) + (and slotd (slot-accessor-std-p slotd type))))) + + +;;; *************************** +;;; Inline Slot Access ******* +;;; *************************** + +;;; +;;; Return a form for reading, setting, or boundp-testing slot +;;; SLOT-NAME of a inline class CLASS. +;;; +;;; ENV is the enviroment in which the slot access occurs. It is used +;;; for the declarations in it. ACCESS is one of the symbols +;;; SLOT-VALUE, SETF, or SLOT-BOUNDP specifying the kind of slot +;;; access to generate code for. +;;; +;;; PARAM-SLOTS is the usual alist of slots accessed through +;;; parameters; see OPTIMIZE-SLOT-ACCESS. +;;; +;;; VALUE is the new-value form for the case of SETF SLOT-VALUE. +;;; +(defun emit-inline-access (access param class slot-name value + param-slots env) + (let ((slots-variable (add-param-slot-entry param '(inline-access) + param-slots))) + (pushnew (class-name class) *inline-access*) + (ecase access + (slot-value + (let ((boundp (slot-declaration env 'slot-boundp class slot-name))) + `(inline-slot-value ,param ,class ,slot-name ,slots-variable + ,(not boundp)))) + (setf + `(inline-set-slot-value ,class ,slot-name ,slots-variable ,value)) + (slot-boundp + `(inline-slot-boundp ,class ,slot-name ,slots-variable))))) + +;;; +;;; The following three macros implement slot access for the inline +;;; slot access method. +;;; + +(defmacro inline-slot-value (param class slot-name slots-variable + check-bound-p) + (multiple-value-bind (read-form slot-type) + (inline-slot-read-form class slot-name slots-variable) + (if check-bound-p + `(the ,slot-type + (let ((.slot-value. ,read-form)) + (if (eq .slot-value. +slot-unbound+) + (inline-slot-unbound ,param ',slot-name) + .slot-value.))) + `(the ,slot-type ,read-form)))) + +(defun inline-slot-unbound (instance slot-name) + (slot-unbound (class-of instance) instance slot-name)) + +(defmacro inline-slot-boundp (class slot-name slots-variable) + (multiple-value-bind (read-form slot-type) + (inline-slot-read-form class slot-name slots-variable) + (declare (ignore slot-type)) + `(not (eq ,read-form +slot-unbound+)))) + +(defmacro inline-set-slot-value (class slot-name slots-variable value-form) + (multiple-value-bind (read-form slot-type) + (inline-slot-read-form class slot-name slots-variable) + `(setf ,read-form (the ,slot-type ,value-form)))) + +;;; +;;; Return two values READ-FORM and SLOT-TYPE for reading slot +;;; SLOT-NAME of an instance of a inline class CLASS. READ-FORM is a +;;; form that can be used to read the value of the slot. SLOT-TYPE is +;;; the type of the slot. +;;; +;;; SLOTS-VARIABLE is the name of a variable bound to the instance's +;;; slot vector. +;;; +(defun inline-slot-read-form (class slot-name slots-variable) + (let* ((slotd (find-slot-definition class slot-name)) + (location (slot-definition-location slotd))) + (values (etypecase location + (fixnum + `(%svref ,slots-variable ,location))) + (slot-type class slot-name)))) + +;;; +;;; True if slot SLOT-NAME has the same location in CLASS and all of +;;; its subclasses. +;;; +(defun slot-at-fixed-location-p (class slot-name) + (labels ((location (class slot-name) + (let ((slot (find-slot-definition class slot-name))) + (slot-definition-location slot))) + (fixed-p (class slot-name location) + (loop for subclass in (class-direct-subclasses class) + as subclass-location = (location subclass slot-name) + always (and (eql location subclass-location) + (fixed-p subclass slot-name location))))) + (fixed-p class slot-name (location class slot-name)))) + + +;;; ******************************************************** +;;; Inline Slot Access Info on Classes and Methods ******** +;;; ******************************************************** + +(defun methods-using-inline-slot-access (class) + (let ((class (if (classp class) class (find-class class)))) + (plist-value class 'inline-access))) + +(defun method-info (method) + (plist-value method 'method-info)) + +(defun record-inline-access-info (method class-names method-info) + (when (eq *boot-state* 'complete) + (setf (plist-value method 'inline-access) class-names) + (setf (plist-value method 'method-info) method-info) + (loop for class-name in class-names + as class = (find-class class-name) do + (pushnew method (plist-value class 'inline-access))))) + +(defun remove-inline-access-method (class method) + (let ((methods (methods-using-inline-slot-access class))) + (when methods + (setf (plist-value class 'inline-access) + (remove method methods))))) + +(defun update-inline-access (class) + (let ((methods (loop for class in (class-precedence-list class) + append (methods-using-inline-slot-access class)))) + (loop for method in methods + as defmethod-form = (reconstruct-defmethod-form method) + if defmethod-form do + (warn "Auto-compiling method ~s." method) + (eval defmethod-form) + else + collect method into remaining-methods + finally + (setq methods remaining-methods)) + (when methods + (warn 'method-recompilation-warning + :title "Methods may need to be recompiled for the changed ~ + class layout of" + :class class + :format-control "~{~% ~s~}" + :format-arguments (list methods))))) + +(defun reconstruct-defmethod-form (method) + (let ((method-info (method-info method))) + (when method-info + (destructuring-bind (body lambda-list) method-info + (let ((method-name (generic-function-name + (method-generic-function method))) + (qualifiers (method-qualifiers method))) + `(defmethod ,method-name ,@qualifiers ,lambda-list + ,@body)))))) + + +;;; ************************ +;;; PV Slot Access ******** +;;; ************************ + +;;; +;;; Return a form for accessing slot SLOT-NAME of method parameter PARAM +;;; using the pv indirection. +;;; +;;; ENV is the environment in which the slot access occurs. It is +;;; used to find declarations in it. ACCESS is the type of access, +;;; one of SLOT-VALUE, SETF, SLOT-BOUNDP. PARAM is the name of the +;;; method parameter whose slot is accessed, and CLASS is the +;;; parameter's class. VALUE is a form for the value part of (SETF +;;; SLOT-VALUE). FALLBACK-ACCESS is a form for accessing the slot +;;; when its pv-entry says the fast method can't be used. +;;; +(defun emit-pv-access (access param class slot-name value + param-slots fallback-access env) + (let* ((pv-offset (list 'pv-offset -1)) + (slots-variable (add-param-slot-entry param slot-name + param-slots pv-offset))) + (ecase access + (slot-value + (let ((boundp (slot-declaration env 'slot-boundp class slot-name))) + `(pv-slot-value ,class ,slot-name ,slots-variable ,pv-offset + ,(not boundp) t ,fallback-access))) + (setf + `(pv-set-slot-value ,class ,slot-name ,slots-variable + ,pv-offset ,value t ,fallback-access)) + (slot-boundp + `(pv-slot-boundp ,class ,slot-name ,slots-variable + ,pv-offset ,fallback-access))))) + +;;; +;;; The following three macros expand to code for SLOT-VALUE, (SETF +;;; SLOT-VALUE), and SLOT-BOUNDP when pv optimization is used. +;;; + +(defmacro pv-slot-value (class slot-name slots-variable pv-offset + check-bound-p use-type-p fallback-access) + (multiple-value-bind (read-form predicate slot-type) + (pv-slot-read-form class slot-name slots-variable) + (let ((slot-type (if use-type-p slot-type t))) + (if check-bound-p + `(the ,slot-type + (let* ((.location. (%svref .pv. ,pv-offset)) + (.slot-value. (if ,predicate ,read-form +slot-unbound+))) + (declare #.*optimize-speed*) + (if (eq .slot-value. +slot-unbound+) + ,fallback-access + .slot-value.))) + `(the ,slot-type + (let ((.location. (%svref .pv. ,pv-offset))) + (declare #.*optimize-speed*) + (if ,predicate + ,read-form + ,fallback-access))))))) + +(defmacro pv-slot-boundp (class slot-name slots-variable pv-offset + fallback-access) + (multiple-value-bind (read-form predicate slot-type) + (pv-slot-read-form class slot-name slots-variable) + (declare (ignore slot-type)) + `(let ((.location. (%svref .pv. ,pv-offset))) + (declare #.*optimize-speed*) + (if ,predicate + (not (eq +slot-unbound+ ,read-form)) + ,fallback-access)))) + +(defmacro pv-set-slot-value (class slot-name slots-variable + pv-offset value use-type-p fallback-access) + (multiple-value-bind (read-form predicate slot-type) + (pv-slot-read-form class slot-name slots-variable) + ;; + ;; Frob the fallback form because we put the value in a let-binding + ;; for checking its type. + (let ((fallback-access + (let ((copy (copy-seq fallback-access))) + (ecase (car fallback-access) + ((funcall setf) + (setf (third copy) '(optimized-marker .value.))) + (accessor-set-slot-value + (setf (fourth copy) '.value.))) + copy)) + (slot-type (if use-type-p slot-type t))) + `(let ((.value. (the ,slot-type ,value))) + (let ((.location. (%svref .pv. ,pv-offset))) + (declare #.*optimize-speed*) + (if ,predicate + (setf ,read-form .value.) + ,fallback-access)))))) + +;;; +;;; Return three values READ-FORM, PREDICATE, SLOT-TYPE for access +;;; to slot SLOT-NAME of class CLASS. SLOTS-VARIABLE is the name of +;;; the local variable holding the instance's slot vector. +;;; +;;; READ-FORM is a form that can be used to read the value of the +;;; slot. +;;; +;;; The returned PREDICATE is a form that can be used to check if a +;;; permutation vector contains a valid entry for the slot access. +;;; The variable .LOCATION. is assumed to hold the slot location that +;;; was retrieved from the pv vector. +;;; +;;; SLOT-TYPE is the slot's type. +;;; +(defun pv-slot-read-form (class slot-name slots-variable) + (let ((slot-type (slot-type class slot-name)) + (likely-a-class-slot-p + (and (eq *boot-state* 'complete) + (constantp class) + (constantp slot-name) + (decide-class-slot-p (eval class) (eval slot-name))))) + (if likely-a-class-slot-p + (values '(cdr .location.) + '(consp .location.) + slot-type) + (values `(%svref ,slots-variable .location.) + '(ext:fixnump .location.) + slot-type)))) + + +;;; ****************************** +;;; Structure Slot Access ******* +;;; ****************************** + +(defun emit-structure-access (access param class slot-name value) + (let* ((slotd (find-slot-definition class slot-name)) + (accessor (slot-definition-defstruct-accessor-symbol slotd))) + (ecase access + (slot-value `(,accessor ,param)) + (setf `(setf (,accessor ,param) ,value)) + (slot-boundp t)))) + + +;;; ******************************************************** +;;; ******** Slot Reader/Writer Call Optimization ******** +;;; ******************************************************** + +;;; +;;; Optimize slot reader function calls in the same way as SLOT-VALUE. +;;; ??? I think FORM can be (APPLY ...), which we could optimize here +;;; as well, for completeness. +;;; +(defun optimize-slot-reader (form required-parms param-slots env) + (when (and (eq *boot-state* 'complete) + *optimize-accessor-calls-p* + (or (not (consp (cadr form))) + (not (eq 'optimized-marker (caadr form))))) + (destructuring-bind (gf-name instance) form + (when (decide-optimize-accessor-p gf-name 'reader) + (multiple-value-bind (param class optimize-p) + (get-param/class-to-optimize instance required-parms env) + (when optimize-p + (setq form (optimize-slot-access/call + param-slots 'slot-value param class + gf-name nil env))))))) + form) + +;;; +;;; Optimize setf's of slot readers. Called from WALK-METHOD-LAMBDA. +;;; +;;; FORM is (setf (GF OBJECT) VALUE), where GF is known to be a +;;; generic function. REQUIRED-PARMS is a list of the required +;;; parameters of the method in whose body FORM appears. PARAM-SLOTS +;;; is an alist of pairs (PARM . PV-OFFSETS). PARM is one of the +;;; required parameters. +;;; +;;; Value is either an optimized form that replaces FORM, or FORM. +;;; +(defun optimize-slot-writer (form required-parms param-slots env) + (when (and (eq *boot-state* 'complete) + *optimize-accessor-calls-p*) + (destructuring-bind (setf (reader instance) value) form + (declare (ignore setf)) + (let ((gf-name `(setf ,reader))) + (when (decide-optimize-accessor-p gf-name 'writer) + (multiple-value-bind (param class optimize-p) + (get-param/class-to-optimize instance required-parms env) + (when optimize-p + (setq form (optimize-slot-access/call + param-slots 'setf param class + gf-name value env)))))))) + form) + +;;; +;;; Generate code for reading/writing a slot using a slot accessor +;;; generic function. +;;; +;;; ACCESS is one of SETF or SLOT-VALUE for writing or reading a slot. +;;; PARAM is the method parameter through which the slot is accessed, +;;; and CLASS is its class. GF-NAME is the name of the generic +;;; reader or writer function called to access the slot. VALUE is the +;;; value part for the SETF case. ENV is the environment in which the +;;; access occurs. +;;; +(defun optimize-slot-access/call (param-slots access param class + gf-name value env) + (let ((slot-name (check-inline-accessor-call-p access gf-name class env))) + (if slot-name + (emit-inline-access/call param-slots access param class + slot-name value env) + (emit-pv-access/call param-slots access param class gf-name + value env)))) + +;;; +;;; Check if a slot accessor call can/should be optimized to a inline +;;; slot access. ACCESS is one of SLOT-VALUE or SETF for read or write +;;; access. GF-NAME is the name of the generic function being called. +;;; CLASS is the class of the instance being accessed. ENV is the +;;; environment in which the access occurs. Value is true if the call +;;; should and can be optimized. +;;; +(defun check-inline-accessor-call-p (access gf-name class env) + (when *optimize-inline-slot-access-p* + ;; + ;; Check if CLASS is defined. If not, we can't use inline + ;; access because we won't be able to determine slot locations. + (unless (classp class) + (let ((real-class (find-class class nil))) + (when (null real-class) + (when (slot-declaration env 'inline class) + (cant-optimize class "The class is not defined at compile time")) + (return-from check-inline-accessor-call-p nil)) + (setq class real-class))) + ;; + (flet ((declared-inline (slot-name) + (slot-declaration env 'inline class slot-name))) + (multiple-value-bind (slot-names all-standard-accessors-p) + (slot-accessor-slot-names access gf-name class) + (cond ((and all-standard-accessors-p + slot-names + (null (cdr slot-names)) + (check-inline-access-p class (car slot-names) env)) + (car slot-names)) + ((not (some #'declared-inline slot-names)) + nil) + ((not all-standard-accessors-p) + (cant-optimize class "~s has a method that is not a standard ~ + slot accessor" gf-name)) + (t + (cant-optimize class "Methods of ~s access different slots" + gf-name))))))) + +;;; +;;; Return two values SLOT-NAMES, ALL-STANDARD-P. SLOT-NAMES is a +;;; list of the names of slots accessed by standard accessor methods +;;; of type ACCESS (one of SETF/SLOT-VALUE for writers/readers) +;;; applicable to CLASS. ALL-STANDARD-P true means all applicable +;;; methods are standard accessor methods. +;;; +(defun slot-accessor-slot-names (access gf-name class) + (loop with all-standard-p = t + for method in (compute-applicable-methods + (gdefinition gf-name) + (let ((proto (class-prototype class))) + (ecase access + (slot-value (list proto)) + (setf (list t proto))))) + if (not (standard-accessor-method-p method)) do + (setq all-standard-p nil) + else + collect (slot-definition-name + (accessor-method-slot-definition method)) into slot-names + finally + (return (values slot-names all-standard-p)))) + +;;; +;;; Emit code for a pv slot accessor call. +;;; +;;; This generates entries ((READER <gf-name>) <pv-offet-form> ...) or +;;; ((WRITER <gf-name>) <pv-offet-form> ...) in PARAM-SLOTS. +;;; +(defun emit-pv-access/call (param-slots access param class gf-name value env) + (let* ((slot-name (ecase access + (slot-value `(reader ,gf-name)) + (setf `(writer ,gf-name)))) + (pv-offset (list 'pv-offset -1)) + (slots-variable + (add-param-slot-entry param slot-name param-slots pv-offset))) + (ecase access + (slot-value + (let ((boundp (slot-declaration env 'slot-boundp class slot-name))) + `(pv-slot-value ,class ,slot-name ,slots-variable ,pv-offset + ,(not boundp) nil + (,gf-name (optimized-marker ,param))))) + (setf + `(pv-set-slot-value ,class ,slot-name ,slots-variable + ,pv-offset ,value nil + (funcall #',gf-name (optimized-marker ,value) + ,param)))))) + +;;; +;;; Emit code for a inline slot accessor call. This generates entries +;;; ((INLINE-ACCESS)) in PARAM-SLOTS. +;;; +(defun emit-inline-access/call (param-slots access param class + slot-name value env) + (let ((slots-variable (add-param-slot-entry param '(inline-access) + param-slots))) + (pushnew (class-name class) *inline-access*) + (ecase access + (slot-value + (let ((boundp (slot-declaration env 'slot-boundp class slot-name))) + `(inline-slot-value ,param ,class ,slot-name ,slots-variable + ,(not boundp)))) + (setf + `(inline-set-slot-value ,class ,slot-name ,slots-variable ,value))))) + +;; end of method-slot-access-optimization.lisp diff --git a/pcl/methods.lisp b/pcl/methods.lisp index 5fc3cf4f3..45050c696 100644 --- a/pcl/methods.lisp +++ b/pcl/methods.lisp @@ -26,11 +26,26 @@ ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/methods.lisp,v 1.23 2003/01/03 18:52:14 pmai Exp $") -;;; + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/methods.lisp,v 1.24 2003/03/22 16:15:16 gerd Exp $") (in-package :pcl) +;;;; ********************* +;;;; PRINT-OBJECT ******* +;;;; ********************* + +(defun named-object-print-function (instance stream + &optional (extra nil extra-p)) + (printing-random-thing (instance stream) + (if extra-p + (format stream "~A ~S ~:S" + (class-name (class-of instance)) + (slot-value-or-default instance 'name) + extra) + (format stream "~A ~S" + (class-name (class-of instance)) + (slot-value-or-default instance 'name))))) + (defmethod print-object (instance stream) (printing-random-thing (instance stream) (let ((name (class-name (class-of instance)))) @@ -44,39 +59,58 @@ (defmethod print-object ((slotd slot-definition) stream) (named-object-print-function slotd stream)) -(defun named-object-print-function (instance stream - &optional (extra nil extra-p)) - (printing-random-thing (instance stream) - (if extra-p - (format stream "~A ~S ~:S" - (capitalize-words (class-name (class-of instance))) - (slot-value-or-default instance 'name) - extra) - (format stream "~A ~S" - (capitalize-words (class-name (class-of instance))) - (slot-value-or-default instance 'name))))) - (defmethod print-object ((mc standard-method-combination) stream) (printing-random-thing (mc stream) (format stream "Method-Combination ~S ~S" (slot-value-or-default mc 'type) (slot-value-or-default mc 'options)))) - +(defmethod print-object ((method standard-method) stream) + (printing-random-thing (method stream) + (if (slot-boundp method 'generic-function) + (let ((gf (method-generic-function method)) + (class-name (class-name (class-of method)))) + (format stream "~A ~S ~{~S ~}~:S" + class-name + (and gf (generic-function-name gf)) + (method-qualifiers method) + (unparse-specializers method))) + (call-next-method)))) + +(defmethod print-object ((method standard-accessor-method) stream) + (printing-random-thing (method stream) + (if (slot-boundp method 'generic-function) + (let ((gf (method-generic-function method)) + (class-name (class-name (class-of method)))) + (format stream "~A ~S, slot:~S, ~:S" + class-name + (and gf (generic-function-name gf)) + (accessor-method-slot-name method) + (unparse-specializers method))) + (call-next-method)))) + +(defmethod print-object ((gf generic-function) stream) + (named-object-print-function + gf + stream + (if (slot-boundp gf 'methods) + (list (length (generic-function-methods gf))) + "?"))) + + ;;; ;;; ;;; -(defmethod shared-initialize :after - ((slotd structure-slot-definition) slot-names - &key (allocation :instance) allocation-class) +(defmethod shared-initialize :after ((slotd structure-slot-definition) + slot-names + &key (allocation :instance) + allocation-class) (declare (ignore slot-names allocation-class)) (unless (eq allocation :instance) - (error "structure slots must have :instance allocation"))) - -(defmethod inform-type-system-about-class ((class structure-class) (name t)) - nil) + (error "~@<Structure slots must have ~s allocation.~@:>" :instance))) + ;;; ;;; METHODS ;;; @@ -91,41 +125,23 @@ (defmethod method-function ((method standard-method)) (or (slot-value method 'function) (let ((fmf (slot-value method 'fast-function))) - (unless fmf ; the :before shared-initialize method prevents this - (error "~S doesn't seem to have a method-function" method)) + ;; The :before shared-initialize method prevents this + (unless fmf + (internal-error "~@<~S doesn't seem to have a method function.~@:>" + method)) (setf (slot-value method 'function) (method-function-from-fast-function fmf))))) +(defmethod method-qualifiers ((method standard-method)) + (plist-value method 'qualifiers)) + (defmethod accessor-method-class ((method standard-accessor-method)) (car (slot-value method 'specializers))) (defmethod accessor-method-class ((method standard-writer-method)) (cadr (slot-value method 'specializers))) -(defmethod print-object ((method standard-method) stream) - (printing-random-thing (method stream) - (if (slot-boundp method 'generic-function) - (let ((generic-function (method-generic-function method)) - (class-name (capitalize-words (class-name (class-of method))))) - (format stream "~A ~S ~{~S ~}~:S" - class-name - (and generic-function (generic-function-name generic-function)) - (method-qualifiers method) - (unparse-specializers method))) - (call-next-method)))) - -(defmethod print-object ((method standard-accessor-method) stream) - (printing-random-thing (method stream) - (if (slot-boundp method 'generic-function) - (let ((generic-function (method-generic-function method)) - (class-name (capitalize-words (class-name (class-of method))))) - (format stream "~A ~S, slot:~S, ~:S" - class-name - (and generic-function (generic-function-name generic-function)) - (accessor-method-slot-name method) - (unparse-specializers method))) - (call-next-method)))) - + ;;; ;;; INITIALIZATION ;;; @@ -135,16 +151,57 @@ ;;; Methods are not reinitializable. ;;; +(defvar *allow-experimental-specializers-p* t) + +(defvar *the-class-generic-function* + (find-class 'generic-function)) + +(defvar *the-class-standard-generic-function* + (find-class 'standard-generic-function)) + + (defmethod reinitialize-instance ((method standard-method) &rest initargs) (declare (ignore initargs)) - (error "Attempt to reinitialize the method ~S.~%~ - Method objects cannot be reinitialized." + (error "~@<Attempt to reinitialize the method ~S. ~ + Method objects cannot be reinitialized.~@:>" method)) +(defmethod shared-initialize :before ((method standard-method) + slot-names + &key qualifiers + lambda-list + specializers + function + fast-function + documentation) + (declare (ignore slot-names)) + (flet ((lose (initarg value string) + (error "~@<When initializing the method ~S, ~ + the ~S initialization argument was ~S, ~ + which ~A.~@:>" + method initarg value string))) + (let ((check-qualifiers (legal-qualifiers-p method qualifiers)) + (check-lambda-list (legal-lambda-list-p method lambda-list)) + (check-specializers (legal-specializers-p method specializers)) + (check-function (legal-method-function-p + method + (or function fast-function))) + (check-documentation (legal-documentation-p method documentation))) + (unless (eq check-qualifiers t) + (lose :qualifiers qualifiers check-qualifiers)) + (unless (eq check-lambda-list t) + (lose :lambda-list lambda-list check-lambda-list)) + (unless (eq check-specializers t) + (lose :specializers specializers check-specializers)) + (unless (eq check-function t) + (lose :function function check-function)) + (unless (eq check-documentation t) + (lose :documentation documentation check-documentation))))) + (defmethod legal-documentation-p ((object standard-method) x) (if (or (null x) (stringp x)) t - "a string or NULL")) + "is not a string or NULL")) (defmethod legal-lambda-list-p ((object standard-method) x) (declare (ignore x)) @@ -153,7 +210,7 @@ (defmethod legal-method-function-p ((object standard-method) x) (if (functionp x) t - "a function")) + "is not a function")) (defmethod legal-qualifiers-p ((object standard-method) x) (flet ((improper-list () @@ -179,7 +236,7 @@ (defmethod legal-specializers-p ((object standard-method) x) (flet ((improper-list () - (return-from legal-specializers-p "Is not a proper list."))) + (return-from legal-specializers-p "is not a proper list."))) (dolist-carefully (s x improper-list) (let ((ok (legal-specializer-p object s))) (unless (eq ok t) @@ -187,8 +244,6 @@ (format nil "Contains ~S which ~A" s ok))))) t)) -(defvar *allow-experimental-specializers-p* nil) - (defmethod legal-specializer-p ((object standard-method) x) (if (if *allow-experimental-specializers-p* (specializerp x) @@ -197,37 +252,6 @@ t "is neither a class object nor an eql specializer")) -(defmethod shared-initialize :before ((method standard-method) - slot-names - &key qualifiers - lambda-list - specializers - function - fast-function - documentation) - (declare (ignore slot-names)) - (flet ((lose (initarg value string) - (error "When initializing the method ~S:~%~ - The ~S initialization argument was: ~S.~%~ - which ~A." - method initarg value string))) - (let ((check-qualifiers (legal-qualifiers-p method qualifiers)) - (check-lambda-list (legal-lambda-list-p method lambda-list)) - (check-specializers (legal-specializers-p method specializers)) - (check-function (legal-method-function-p method (or function - fast-function))) - (check-documentation (legal-documentation-p method documentation))) - (unless (eq check-qualifiers t) - (lose :qualifiers qualifiers check-qualifiers)) - (unless (eq check-lambda-list t) - (lose :lambda-list lambda-list check-lambda-list)) - (unless (eq check-specializers t) - (lose :specializers specializers check-specializers)) - (unless (eq check-function t) - (lose :function function check-function)) - (unless (eq check-documentation t) - (lose :documentation documentation check-documentation))))) - (defmethod shared-initialize :before ((method standard-accessor-method) slot-names &key slot-name slot-definition) @@ -235,17 +259,14 @@ (unless slot-definition (let ((legalp (legal-slot-name-p method slot-name))) (unless (eq legalp t) - (error "The value of the :SLOT-NAME initarg ~A." legalp))))) + (error "The value of the ~s initarg ~A." :slot-name legalp))))) (defmethod shared-initialize :after ((method standard-method) slot-names &rest initargs &key qualifiers method-spec plist) (declare (ignore slot-names method-spec plist)) (initialize-method-function initargs nil method) - (setf (plist-value method 'qualifiers) qualifiers) - #+ignore - (setf (slot-value method 'closure-generator) - (method-function-closure-generator (slot-value method 'function)))) + (setf (plist-value method 'qualifiers) qualifiers)) (defmethod shared-initialize :after ((method standard-accessor-method) slot-names @@ -261,26 +282,8 @@ (when (and slot-definition (null slot-name)) (setq slot-name (slot-definition-name slot-definition))))) -(defmethod method-qualifiers ((method standard-method)) - (plist-value method 'qualifiers)) - - - -(defvar *the-class-generic-function* (find-class 'generic-function)) -(defvar *the-class-standard-generic-function* (find-class 'standard-generic-function)) - - - -(defmethod print-object ((generic-function generic-function) stream) - (named-object-print-function - generic-function - stream - (if (slot-boundp generic-function 'methods) - (list (length (generic-function-methods generic-function))) - "?"))) - (defmethod shared-initialize :before - ((generic-function standard-generic-function) + ((gf standard-generic-function) slot-names &key (name nil namep) (lambda-list () lambda-list-p) @@ -294,210 +297,188 @@ lambda-list lambda-list-p)) (when namep - (set-function-name generic-function name)) + (set-function-name gf name)) (flet ((initarg-error (initarg value string) - (error "When initializing the generic-function ~S:~%~ - The ~S initialization argument was: ~A.~%~ - It must be ~A." - generic-function initarg value string))) + (error (format nil "~~@<When initializing the generic-function ~S: ~ + The ~S initialization argument was ~A. ~ + It must be ~A.~~@:>" + gf initarg value string)))) (cond (method-class-supplied-p (when (symbolp method-class) (setq method-class (find-class method-class))) (unless (and (classp method-class) (*subtypep (class-eq-specializer method-class) *the-class-method*)) - (initarg-error :method-class - method-class - "a subclass of the class METHOD")) - (setf (slot-value generic-function 'method-class) method-class)) - ((slot-boundp generic-function 'method-class)) + (initarg-error :method-class method-class "a method class")) + (setf (slot-value gf 'method-class) method-class)) + ((slot-boundp gf 'method-class)) (t - (initarg-error :method-class - "not supplied" - "a subclass of the class METHOD"))) + (initarg-error :method-class "not supplied" "a method class"))) (cond (method-combination-supplied-p (unless (method-combination-p method-combination) - (initarg-error :method-combination - method-combination + (initarg-error :method-combination method-combination "a method combination object"))) - ((slot-boundp generic-function 'method-combination)) + ((slot-boundp gf 'method-combination)) (t (initarg-error :method-combination "not supplied" "a method combination object"))))) - -#|| -(defmethod reinitialize-instance ((generic-function standard-generic-function) - &rest initargs - &key name - lambda-list - argument-precedence-order - declarations - documentation - method-class - method-combination) - (declare (ignore documentation declarations argument-precedence-order - lambda-list name method-class method-combination)) - (macrolet ((add-initarg (check name slot-name) - `(unless ,check - (push (slot-value generic-function ,slot-name) initargs) - (push ,name initargs)))) -; (add-initarg name :name 'name) -; (add-initarg lambda-list :lambda-list 'lambda-list) -; (add-initarg argument-precedence-order -; :argument-precedence-order -; 'argument-precedence-order) -; (add-initarg declarations :declarations 'declarations) -; (add-initarg documentation :documentation 'documentation) -; (add-initarg method-class :method-class 'method-class) -; (add-initarg method-combination :method-combination 'method-combination) - (apply #'call-next-method generic-function initargs))) -||# - ;;; ;;; These three are scheduled for demolition. ;;; -(defmethod remove-named-method (generic-function-name argument-specifiers - &optional extra) - (let ((generic-function ()) - (method ())) - (cond ((or (null (fboundp generic-function-name)) - (not (generic-function-p - (setq generic-function - (symbol-function generic-function-name))))) - (error "~S does not name a generic-function." - generic-function-name)) - ((null (setq method (get-method generic-function - extra - (parse-specializers - argument-specifiers) - nil))) - (error "There is no method for the generic-function ~S~%~ - which matches the argument-specifiers ~S." - generic-function - argument-specifiers)) +(defmethod remove-named-method (gf-name argument-specifiers &optional extra) + (let (gf method) + (cond ((or (not (fboundp gf-name)) + (not (generic-function-p (setq gf (gdefinition gf-name))))) + (error "~@<~S does not name a generic function.~@:>" gf-name)) + ((null (setq method + (get-method gf extra + (parse-specializers argument-specifiers) + nil))) + (error "~@<There is no method for the generic function ~S ~ + matching argument specifiers ~S.~@:>" + gf argument-specifiers)) (t - (remove-method generic-function method))))) + (remove-method gf method))))) -(defun real-add-named-method (generic-function-name - qualifiers - specializers - lambda-list - &rest other-initargs) +(defun #+loadable-pcl add-named-method + #-loadable-pcl real-add-named-method + (gf-name qualifiers specializers lambda-list &rest other-initargs) ;; What about changing the class of the generic-function if there is ;; one. Whose job is that anyways. Do we need something kind of ;; like class-for-redefinition? - (let* ((generic-function - (ensure-generic-function generic-function-name)) + (let* ((gf (ensure-generic-function gf-name)) (specs (parse-specializers specializers)) -; (existing (get-method generic-function qualifiers specs nil)) - (proto (method-prototype-for-gf generic-function-name)) + (proto (method-prototype-for-gf gf-name)) (new (apply #'make-instance (class-of proto) - :qualifiers qualifiers - :specializers specs - :lambda-list lambda-list - other-initargs))) -; (when existing (remove-method generic-function existing)) - (add-method generic-function new))) + :qualifiers qualifiers + :specializers specs + :lambda-list lambda-list + other-initargs))) + (add-method gf new))) - -(defun real-get-method (generic-function qualifiers specializers - &optional (errorp t)) - (let ((hit - (dolist (method (generic-function-methods generic-function)) - (when (and (equal qualifiers (method-qualifiers method)) - (every #'same-specializer-p specializers - (method-specializers method))) - (return method))))) - (cond (hit hit) - ((null errorp) nil) - (t - (error "No method on ~S with qualifiers ~:S and specializers ~:S." - generic-function qualifiers specializers))))) - -(defmethod find-method ((generic-function standard-generic-function) +#+loadable-pcl +(defmethod get-method ((gf standard-generic-function) + qualifiers specializers &optional (errorp t)) + (loop with nspecializers = (length specializers) + for method in (generic-function-methods gf) + as quals = (method-qualifiers method) + as specs = (method-specializers method) + when (and (equal quals qualifiers) + (= (length specs) nspecializers) + (every #'same-specializer-p specs specializers)) do + (return-from get-method method)) + (when errorp + (error "~@<No method on ~S with qualifiers ~S and ~ + specializers ~S.~@:>" + gf qualifiers specializers))) + +#-loadable-pcl +(defun real-get-method (gf qualifiers specializers &optional (errorp t)) + (loop with nspecializers = (length specializers) + for method in (generic-function-methods gf) + as quals = (method-qualifiers method) + as specs = (method-specializers method) + when (and (equal quals qualifiers) + (= (length specs) nspecializers) + (every #'same-specializer-p specs specializers)) do + (return-from real-get-method method)) + (when errorp + (error "~@<No method on ~S with qualifiers ~S and ~ + specializers ~S.~@:>" + gf qualifiers specializers))) + +(defmethod find-method ((gf standard-generic-function) qualifiers specializers &optional (errorp t)) - (real-get-method generic-function qualifiers + (real-get-method gf qualifiers (parse-specializers specializers) errorp)) - ;;; -;;; Compute various information about a generic-function's arglist by looking -;;; at the argument lists of the methods. The hair for trying not to use -;;; &rest arguments lives here. -;;; The values returned are: -;;; number-of-required-arguments -;;; the number of required arguments to this generic-function's -;;; discriminating function -;;; &rest-argument-p -;;; whether or not this generic-function's discriminating -;;; function takes an &rest argument. -;;; specialized-argument-positions -;;; a list of the positions of the arguments this generic-function -;;; specializes (e.g. for a classical generic-function this is the -;;; list: (1)). ;;; -(defmethod compute-discriminating-function-arglist-info - ((generic-function standard-generic-function)) - ;;(declare (values number-of-required-arguments &rest-argument-p - ;; specialized-argument-postions)) - (let ((number-required nil) - (restp nil) - (specialized-positions ()) - (methods (generic-function-methods generic-function))) - (dolist (method methods) - (multiple-value-setq (number-required restp specialized-positions) - (compute-discriminating-function-arglist-info-internal - generic-function method number-required restp specialized-positions))) - (values number-required restp (sort specialized-positions #'<)))) - -(defun compute-discriminating-function-arglist-info-internal - (generic-function method number-of-requireds restp - specialized-argument-positions) - (declare (ignore generic-function) (type (or null fixnum) number-of-requireds)) - (let ((requireds 0)) - (declare (fixnum requireds)) - ;; Go through this methods arguments seeing how many are required, - ;; and whether there is an &rest argument. - (dolist (arg (method-lambda-list method)) - (cond ((eq arg '&aux) (return)) - ((memq arg '(&optional &rest &key)) - (return (setq restp t))) - ((memq arg lambda-list-keywords)) - (t (incf requireds)))) - ;; Now go through this method's type specifiers to see which - ;; argument positions are type specified. Treat T specially - ;; in the usual sort of way. For efficiency don't bother to - ;; keep specialized-argument-positions sorted, rather depend - ;; on our caller to do that. - (loop for type-spec in (method-specializers method) - and pos from 0 - unless (eq type-spec *the-class-t*) do - (pushnew pos specialized-argument-positions)) - ;; Finally merge the values for this method into the values - ;; for the exisiting methods and return them. Note that if - ;; num-of-requireds is NIL it means this is the first method - ;; and we depend on that. - (values (min (or number-of-requireds requireds) requireds) - (or restp - (and number-of-requireds (/= number-of-requireds requireds))) - specialized-argument-positions))) - -(defun make-discriminating-function-arglist (number-required-arguments restp) - (nconc (loop for i below number-required-arguments - collect (intern (format nil "Discriminating Function Arg ~D" i))) - (when restp - (list '&rest (intern "Discriminating Function &rest Arg"))))) +;;; + +(defun set-methods (gf methods) + (setf (generic-function-methods gf) nil) + (loop (when (null methods) (return gf)) + (real-add-method gf (pop methods) methods))) + +(defun real-add-method (gf method &optional skip-dfun-update-p) + (when (method-generic-function method) + (error "~@<The method ~S is already part of the generic ~ + function ~S. It can't be added to another generic ~ + function until it is removed from the first one.~@:>" + method (method-generic-function method))) + ;; + (flet (;; + ;; Return T if METHOD-A and METHOD-B have similar lambda + ;; lists, that is, when they are considered the same + ;; when redefining methods. + (similar-lambda-lists-p (method-a method-b) + (multiple-value-bind (a-nreq a-nopt a-keyp a-restp) + (analyze-lambda-list (method-lambda-list method-a)) + (multiple-value-bind (b-nreq b-nopt b-keyp b-restp) + (analyze-lambda-list (method-lambda-list method-b)) + (and (= a-nreq b-nreq) (= a-nopt b-nopt) + (eq (or a-keyp a-restp) (or b-keyp b-restp))))))) + (let* ((qualifiers (method-qualifiers method)) + (specializers (method-specializers method)) + (old (get-method gf qualifiers specializers nil))) + ;; + ;; If there is already a method like this one then we must + ;; get rid of it before proceeding. Note that we call the + ;; generic function remove-method to remove it rather than + ;; doing it in some internal way. + (when (and old (similar-lambda-lists-p old method)) + (remove-method gf old)) + ;; + ;; Add the method. + (setf (method-generic-function method) gf) + (push method (generic-function-methods gf)) + (dolist (specializer specializers) + (add-direct-method specializer method)) + ;; + ;; SET-ARG-INFO signals an error if the new method has an + ;; incongruent lambda list, but the function depends on the + ;; new method already having been added to the gf. So kluge + ;; around a bit. + (let ((remove-again-p t)) + (unwind-protect + (progn + (set-arg-info gf :new-method method) + (setq remove-again-p nil)) + (when remove-again-p + (remove-method gf method)))) + ;; + (unless skip-dfun-update-p + (update-ctors 'add-method :generic-function gf :method method) + (update-dfun gf)) + (update-accessor-pvs 'add-method gf method old) + method))) + +(defun real-remove-method (gf method) + ;; Note: Error check prohibited by ANSI spec removed. + (when (eq gf (method-generic-function method)) + (let* ((methods (generic-function-methods gf)) + (new-methods (remove method methods))) + (setf (method-generic-function method) nil) + (setf (generic-function-methods gf) new-methods) + (dolist (specializer (method-specializers method)) + (remove-direct-method specializer method)) + (set-arg-info gf) + (update-ctors 'remove-method :generic-function gf :method method) + (update-dfun gf) + (update-accessor-pvs 'remove-method gf method) + gf))) -;;; -;;; -;;; +;;;; ************************** +;;;; Generic Functions ******* +;;;; ************************** (defmethod generic-function-argument-precedence-order ((gf standard-generic-function)) @@ -531,8 +512,7 @@ &key (lambda-list nil lambda-list-p) (argument-precedence-order nil argument-precedence-order-p)) - (with-slots (arg-info) - gf + (with-slots (arg-info) gf (if lambda-list-p (if argument-precedence-order-p (set-arg-info gf @@ -546,101 +526,37 @@ (or lambda-list-p (cddr args))) (update-dfun gf)))) -;;; -;;; -;;; - -(declaim (special *lazy-dfun-compute-p*)) - -(defun set-methods (gf methods) - (setf (generic-function-methods gf) nil) - (loop (when (null methods) (return gf)) - (real-add-method gf (pop methods) methods))) - -(defun real-add-method (generic-function method &optional skip-dfun-update-p) - (if (method-generic-function method) - (error "The method ~S is already part of the generic~@ - function ~S. It can't be added to another generic~@ - function until it is removed from the first one." - method (method-generic-function method)) - - (let* ((name (generic-function-name generic-function)) - (qualifiers (method-qualifiers method)) - (specializers (method-specializers method)) - (existing (get-method generic-function qualifiers specializers nil))) - ;; - ;; If there is already a method like this one then we must - ;; get rid of it before proceeding. Note that we call the - ;; generic function remove-method to remove it rather than - ;; doing it in some internal way. - ;; - (when existing (remove-method generic-function existing)) - ;; - (setf (method-generic-function method) generic-function) - (pushnew method (generic-function-methods generic-function)) - (dolist (specializer specializers) - (add-direct-method specializer method)) - (set-arg-info generic-function :new-method method) - (unless skip-dfun-update-p - (when (member name - '(make-instance default-initargs - allocate-instance shared-initialize initialize-instance)) - (update-make-instance-function-table (type-class (car specializers)))) - (update-dfun generic-function)) - method))) - -(defun real-remove-method (generic-function method) - ;; Note: Error check prohibited by ANSI spec removed. - (when (eq generic-function (method-generic-function method)) - (let* ((name (generic-function-name generic-function)) - (specializers (method-specializers method)) - (methods (generic-function-methods generic-function)) - (new-methods (remove method methods))) - (setf (method-generic-function method) nil) - (setf (generic-function-methods generic-function) new-methods) - (dolist (specializer (method-specializers method)) - (remove-direct-method specializer method)) - (set-arg-info generic-function) - (when (member name - '(make-instance - default-initargs - allocate-instance shared-initialize initialize-instance)) - (update-make-instance-function-table (type-class (car specializers)))) - (update-dfun generic-function) - generic-function))) - -(defun compute-applicable-methods-function (generic-function arguments) +(defun compute-applicable-methods-function (gf arguments) (values (compute-applicable-methods-using-types - generic-function - (types-from-arguments generic-function arguments 'eql)))) + gf + (types-from-arguments gf arguments 'eql)))) -(defmethod compute-applicable-methods - ((generic-function generic-function) arguments) +(defmethod compute-applicable-methods ((gf generic-function) arguments) (values (compute-applicable-methods-using-types - generic-function - (types-from-arguments generic-function arguments 'eql)))) + gf + (types-from-arguments gf arguments 'eql)))) -(defmethod compute-applicable-methods-using-classes - ((generic-function generic-function) classes) +(defmethod compute-applicable-methods-using-classes ((gf generic-function) + classes) (compute-applicable-methods-using-types - generic-function - (types-from-arguments generic-function classes 'class-eq))) + gf + (types-from-arguments gf classes 'class-eq))) (defun proclaim-incompatible-superclasses (classes) - (setq classes (mapcar (lambda (class) - (if (symbolp class) - (find-class class) - class)) - classes)) - (dolist (class classes) - (dolist (other-class classes) - (unless (eq class other-class) - (pushnew other-class (class-incompatible-superclass-list class)))))) + (let ((classes (mapcar (lambda (class) + (if (symbolp class) + (find-class class) + class)) + classes))) + (dolist (class classes) + (dolist (other-class classes) + (unless (eq class other-class) + (pushnew other-class (class-incompatible-superclass-list class))))))) (defun superclasses-compatible-p (class1 class2) - (let ((cpl1 (class-precedence-list class1)) - (cpl2 (class-precedence-list class2))) + (let ((cpl1 (cpl-or-nil class1)) + (cpl2 (cpl-or-nil class2))) (dolist (sc1 cpl1 t) (dolist (ic (class-incompatible-superclass-list sc1)) (when (memq ic cpl2) @@ -697,20 +613,21 @@ t))) (lambda (&rest args) (funcall mf args nil)))) -(defun types-from-arguments (generic-function arguments &optional type-modifier) +(defun types-from-arguments (gf arguments &optional type-modifier) (multiple-value-bind (nreq applyp metatypes nkeys arg-info) - (get-generic-function-info generic-function) + (get-generic-function-info gf) (declare (ignore applyp metatypes nkeys)) - (let ((types-rev nil)) - (dotimes (i nreq) - i - (unless arguments - (error "The function ~S requires at least ~D arguments" - (generic-function-name generic-function) - nreq)) - (let ((arg (pop arguments))) - (push (if type-modifier `(,type-modifier ,arg) arg) types-rev))) - (values (nreverse types-rev) arg-info)))) + (loop repeat nreq + if arguments + if type-modifier + collect `(,type-modifier ,(pop arguments)) into types + else + collect (pop arguments) into types + else do + (error "~@<Generic function ~S requires at least ~D arguments.~@:>" + (generic-function-name gf) nreq) + finally + (return (values types arg-info))))) (defun get-wrappers-from-classes (nkeys wrappers classes metatypes) (let* ((w wrappers) (w-tail w) (mt-tail metatypes)) @@ -729,9 +646,11 @@ (let ((types (mapcar #'class-eq-type classes))) (multiple-value-bind (methods all-applicable-and-sorted-p) (compute-applicable-methods-using-types gf types) - (function-funcall (get-secondary-dispatch-function1 - gf methods types nil t all-applicable-and-sorted-p) - nil (mapcar #'class-wrapper classes))))) + (let ((generator (get-secondary-dispatch-function1 + gf methods types nil t + all-applicable-and-sorted-p))) + (make-callable gf methods generator nil + (mapcar #'class-wrapper classes)))))) (defun value-for-caching (gf classes) (let ((methods (compute-applicable-methods-using-types @@ -740,33 +659,27 @@ (method-function (car methods))) :constant-value))) -(defun default-secondary-dispatch-function (generic-function) +(defun default-secondary-dispatch-function (gf) (lambda (&rest args) - (let ((methods (compute-applicable-methods generic-function args))) + (let ((methods (compute-applicable-methods gf args))) (if methods - (let ((emf (get-effective-method-function generic-function methods))) + (let ((emf (get-effective-method-function gf methods))) (invoke-emf emf args)) - (apply #'no-applicable-method generic-function args))))) - -(defun list-eq (x y) - (loop (when (atom x) (return (eq x y))) - (when (atom y) (return nil)) - (unless (eq (car x) (car y)) (return nil)) - (setq x (cdr x) y (cdr y)))) + (apply #'no-applicable-method gf args))))) (defvar *std-cam-methods* nil) -(defun compute-applicable-methods-emf (generic-function) +(defun compute-applicable-methods-emf (gf) (if (eq *boot-state* 'complete) (let* ((cam (gdefinition 'compute-applicable-methods)) (cam-methods (compute-applicable-methods-using-types - cam (list `(eql ,generic-function) t)))) + cam (list `(eql ,gf) t)))) + (unless *std-cam-methods* + (setq *std-cam-methods* + (compute-applicable-methods-using-types + cam (list `(eql ,cam) t)))) (values (get-effective-method-function cam cam-methods) - (list-eq cam-methods - (or *std-cam-methods* - (setq *std-cam-methods* - (compute-applicable-methods-using-types - cam (list `(eql ,cam) t))))))) + (every #'eq cam-methods *std-cam-methods*))) (values #'compute-applicable-methods-function t))) (defun compute-applicable-methods-emf-std-p (gf) @@ -791,6 +704,7 @@ (map-all-generic-functions (lambda (gf) (when (or (member gf gfs-to-do) + ;; FIXME: Always returning NIL cannot be right, or? (dolist (class gf-classes-to-do nil) (member class (class-precedence-list (class-of gf))))) (update-c-a-m-gf-info gf))))) @@ -844,7 +758,7 @@ gf methods types `((,(car (or (member std-method methods) (member str-method methods) - (error "error in get-accessor-method-function"))) + (internal-error "In get-accessor-method-function."))) ,(get-optimized-std-slot-value-using-class-method-function class slotd type))) (unless (and (eq type 'writer) @@ -965,8 +879,8 @@ (mapcar (lambda (c) (cons c list)) car-all-classes)) all-class-lists)))) -(defun make-emf-cache (generic-function valuep cache classes-list new-class) - (let* ((arg-info (gf-arg-info generic-function)) +(defun make-emf-cache (gf valuep cache classes-list new-class) + (let* ((arg-info (gf-arg-info gf)) (nkeys (arg-info-nkeys arg-info)) (metatypes (arg-info-metatypes arg-info)) (wrappers (unless (eq nkeys 1) (make-list nkeys))) @@ -979,13 +893,13 @@ (when (and wrappers (eq default (probe-cache cache wrappers default))) (let ((value (cond ((eq valuep t) - (sdfun-for-caching generic-function classes)) + (sdfun-for-caching gf classes)) ((eq valuep :constant-value) - (value-for-caching generic-function classes))))) + (value-for-caching gf classes))))) (setq cache (fill-cache cache wrappers value)))))))) (if classes-list (mapc #'add-class-list classes-list) - (dolist (method (generic-function-methods generic-function)) + (dolist (method (generic-function-methods gf)) (mapc #'add-class-list (mec-all-class-lists (method-specializers method) precompute-p)))) cache))) @@ -995,7 +909,7 @@ (cond ((eq class *the-class-t*) t) ((eq class *the-class-slot-object*) - `(not (lisp:typep (lisp:class-of ,arg) 'lisp:built-in-class))) + `(not (lisp:typep (kernel::class-of ,arg) 'kernel::built-in-class))) ((eq class *the-class-std-object*) `(or (std-instance-p ,arg) (fsc-instance-p ,arg))) ((eq class *the-class-standard-object*) @@ -1036,11 +950,11 @@ (defmacro mcase (arg &rest clauses) `(scase ,arg ,@clauses)) -(defun generate-discrimination-net (generic-function methods types sorted-p) - (let* ((arg-info (gf-arg-info generic-function)) +(defun generate-discrimination-net (gf methods types sorted-p) + (let* ((arg-info (gf-arg-info gf)) (precedence (arg-info-precedence arg-info))) (generate-discrimination-net-internal - generic-function methods types + gf methods types (lambda (methods known-types) (if (or sorted-p (block one-order-p @@ -1094,7 +1008,8 @@ (class-eq (cadr type)) (class (cadr type))))) -(defun precompute-effective-methods (gf caching-p &optional classes-list-p) +#+nil +(defun precompute-effective-methods (gf caching-p) (let* ((arg-info (gf-arg-info gf)) (methods (generic-function-methods gf)) (precedence (arg-info-precedence arg-info)) @@ -1104,8 +1019,6 @@ gf methods nil (lambda (methods known-types) (when methods - (when classes-list-p - (push (mapcar #'class-from-type known-types) classes-list)) (let ((no-eql-specls-p (not (methods-contain-eql-specializer-p methods)))) (map-all-orders methods precedence @@ -1140,27 +1053,44 @@ new-type `(and ,new-type ,@so-far))))) +;;; +;;; Given a set of methods METHDOS of generic function GF and a list +;;; of the types of actual arguments TYPES, call METHODS-FUNCTION with +;;; two arguments: a list of possibly applicable methods and a list of +;;; type expressions that can be used on actual arguments for testing +;;; if a method is applicable. +;;; +;;; TEST-FUNCTION is a function to determine if a method is possibly +;;; applicable, if SPECIALIZER-APPLICABLE-USING-TYPE-P can't tell. +;;; +;;; TYPE-FUNCTION is a function to transform a method specializer's +;;; type. +;;; +;;; Or something. +;;; +;;; Rewrite this to a control flow that one can follow! +;;; (defun generate-discrimination-net-internal (gf methods types methods-function test-function type-function) (let* ((arg-info (gf-arg-info gf)) (precedence (arg-info-precedence arg-info)) (nreq (arg-info-number-required arg-info)) (metatypes (arg-info-metatypes arg-info))) - (labels ((do-column (p-tail contenders known-types) - (if p-tail - (let* ((position (car p-tail)) + (labels ((do-column (precedence contenders known-types) + (if precedence + (let* ((position (car precedence)) (known-type (or (nth position types) t))) (if (eq (nth position metatypes) t) - (do-column (cdr p-tail) contenders + (do-column (cdr precedence) contenders (cons (cons position known-type) known-types)) - (do-methods p-tail contenders + (do-methods precedence contenders known-type () known-types))) (funcall methods-function contenders (let ((k-t (make-list nreq))) (dolist (index+type known-types) (setf (nth (car index+type) k-t) (cdr index+type))) k-t)))) - (do-methods (p-tail contenders known-type winners known-types) + (do-methods (precedence contenders known-type winners known-types) ;; ;; <contenders> ;; is a (sorted) list of methods that must be discriminated @@ -1171,9 +1101,9 @@ ;; after the discrimination has been made. ;; (if (null contenders) - (do-column (cdr p-tail) winners - (cons (cons (car p-tail) known-type) known-types)) - (let* ((position (car p-tail)) + (do-column (cdr precedence) winners + (cons (cons (car precedence) known-type) known-types)) + (let* ((position (car precedence)) (method (car contenders)) (specl (nth position (method-specializers method))) (type (funcall type-function (type-from-specializer specl)))) @@ -1183,7 +1113,7 @@ (if truth-value app-p (not maybe-app-p))) (do-if (truth &optional implied) (let ((ntype (if truth type `(not ,type)))) - (do-methods p-tail + (do-methods precedence (cdr contenders) (if implied known-type @@ -1198,36 +1128,40 @@ (do-if t) (do-if nil)))))))))) (do-column precedence methods ())))) -(defun compute-secondary-dispatch-function (generic-function net &optional - method-alist wrappers) - (function-funcall (compute-secondary-dispatch-function1 generic-function net) - method-alist wrappers)) - -(defvar *eq-case-table-limit* 15) -(defvar *case-table-limit* 10) +;;; +;;; These constants are the maximum number of case clauses for which +;;; to use the :ASSOC implementation of MCASE. For larger numbers, a +;;; :HASH-TABLE is used. +;;; +(defconstant +eq-case-table-limit+ 15) +(defconstant +case-table-limit+ 10) +;;; +;;; Value is a list (EQ-P IMPL) for use as the last two parameters to +;;; MLOOKUP. EQ-P true means all case clauses in CASE-LIST can be +;;; implemented using EQ. IMPL is one of the symbols :ASSOC, :SIMPLE, +;;; :HASH-TABLE for the mcase implementation to use. +;;; (defun compute-mcase-parameters (case-list) (unless (eq t (caar (last case-list))) - (error "The key for the last case arg to mcase was not T")) - (let* ((eq-p (dolist (case case-list t) - (unless (or (eq (car case) t) - (symbolp (caar case))) - (return nil)))) + (internal-error "The key for the last case arg to mcase was not T.")) + (let* ((eq-p (loop for case in case-list + always (or (eq (car case) t) + (symbolp (caar case))))) + (limit (if eq-p +eq-case-table-limit+ +case-table-limit+)) (len (1- (length case-list))) - (type (cond ((= len 1) - :simple) - ((<= len - (if eq-p - *eq-case-table-limit* - *case-table-limit*)) - :assoc) - (t - :hash-table)))) + (type (cond ((= len 1) :simple) + ((<= len limit) :assoc) + (t :hash-table)))) (list eq-p type))) -(defmacro mlookup (key info default &optional eq-p type) - (unless (or (eq eq-p t) (null eq-p)) - (error "Invalid eq-p argument")) +;;; +;;; Value is a form for looking up KEY in INFO, returning DEFAULT if +;;; not found. EQ-P true means compare keys with EQ. TYPE is a +;;; symbol describing the type of lookup to use, one of :SIMPLE, +;;; :ASSOC, or :HASH-TABLE. +;;; +(defmacro mlookup (key info default eq-p type) (ecase type (:simple `(if (,(if eq-p 'eq 'eql) ,key (car ,info)) @@ -1240,6 +1174,10 @@ (:hash-table `(gethash ,key ,info ,default)))) +;;; +;;; The following three functions are used for the GET-FUNCTION +;;; mechanism, when used on lambdas containing discriminating nets. +;;; (defun net-test-converter (form) (if (atom form) (default-test-converter form) @@ -1260,8 +1198,7 @@ (case (car form) ((methods unordered-methods) (let ((gensym (gensym))) - (values gensym - (list gensym)))) + (values gensym (list gensym)))) (mcase (let ((mp (compute-mcase-parameters (cddr form))) (gensym (gensym)) (default (gensym))) @@ -1270,123 +1207,116 @@ (t (default-code-converter form))))) -(defun net-constant-converter (form generic-function) - (or (let ((c (methods-converter form generic-function))) - (when c (list c))) - (if (atom form) - (default-constant-converter form) - (case (car form) - (mcase - (let* ((mp (compute-mcase-parameters (cddr form))) - (list (mapcar (lambda (clause) - (let ((key (car clause)) - (meth (cadr clause))) - (cons (if (consp key) (car key) key) - (methods-converter - meth generic-function)))) - (cddr form))) - (default (car (last list)))) - (list (list* :mcase mp (nbutlast list)) - (cdr default)))) - (t - (default-constant-converter form)))))) +(defun net-constant-converter (form gf) + (flet ((methods-converter (form gf) + (case (car-safe form) + (methods + (cons '.methods. + (get-effective-method-function1 gf (cadr form)))) + (unordered-methods + (default-secondary-dispatch-function gf))))) + (or (let ((c (methods-converter form gf))) + (when c (list c))) + (if (atom form) + (default-constant-converter form) + (case (car form) + (mcase + (let* ((mp (compute-mcase-parameters (cddr form))) + (list (mapcar (lambda (clause) + (let ((key (car clause)) + (meth (cadr clause))) + (cons (if (consp key) (car key) key) + (methods-converter + meth gf)))) + (cddr form))) + (default (car (last list)))) + (list (list* :mcase mp (nbutlast list)) + (cdr default)))) + (t + (default-constant-converter form))))))) -(defun methods-converter (form generic-function) - (cond ((and (consp form) (eq (car form) 'methods)) - (cons '.methods. - (get-effective-method-function1 generic-function (cadr form)))) - ((and (consp form) (eq (car form) 'unordered-methods)) - (default-secondary-dispatch-function generic-function)))) +;;; +;;; +;;; +(defun compute-secondary-dispatch-function (gf net &optional + method-alist wrappers) + (function-funcall (compute-secondary-dispatch-function1 gf net) + method-alist wrappers)) + +(defun compute-secondary-dispatch-function1 (gf net &optional function-p) + (when (and (eq (car net) 'methods) (not function-p)) + (return-from compute-secondary-dispatch-function1 + (get-effective-method-function1 gf (cadr net)))) + ;; + (let* ((name (generic-function-name gf)) + (arg-info (gf-arg-info gf)) + (metatypes (arg-info-metatypes arg-info)) + (applyp (arg-info-applyp arg-info)) + (fmc-arg-info (cons (length metatypes) applyp)) + (arglist (if function-p + (make-dfun-lambda-list metatypes applyp) + (make-fast-method-call-lambda-list metatypes applyp)))) + (multiple-value-bind (cfunction constants) + (get-function1 `(,(if function-p + 'kernel:instance-lambda + 'lambda) + ,arglist + ,@(unless function-p + `((declare (ignore .pv-cell. + .next-method-call.)))) + (locally (declare #.*optimize-speed*) + (let ((emf ,net)) + ,(make-emf-call metatypes applyp 'emf)))) + #'net-test-converter + #'net-code-converter + (lambda (form) + (net-constant-converter form gf))) + (lambda (method-alist wrappers) + (let* ((alist (list nil)) + (alist-tail alist)) + (dolist (constant constants) + (let* ((a (or (dolist (a alist nil) + (when (eq (car a) constant) + (return a))) + (cons constant + (or (convert-table + constant method-alist wrappers) + (convert-methods + constant method-alist wrappers))))) + (new (list a))) + (setf (cdr alist-tail) new) + (setf alist-tail new))) + (let ((function (apply cfunction (mapcar #'cdr (cdr alist))))) + (if function-p + function + (make-fast-method-call + :function (set-function-name function + `(discriminator ,name)) + :arg-info fmc-arg-info)))))))) (defun convert-methods (constant method-alist wrappers) - (if (and (consp constant) - (eq (car constant) '.methods.)) + (if (eq (car-safe constant) '.methods.) (funcall (cdr constant) method-alist wrappers) constant)) (defun convert-table (constant method-alist wrappers) - (cond ((and (consp constant) - (eq (car constant) :mcase)) - (let ((alist (mapcar (lambda (k+m) - (cons (car k+m) - (convert-methods (cdr k+m) - method-alist wrappers))) - (cddr constant))) - (mp (cadr constant))) - (ecase (cadr mp) - (:simple - (car alist)) - (:assoc - alist) - (:hash-table - (let ((table (make-hash-table :test (if (car mp) 'eq 'eql)))) - (dolist (k+m alist) - (setf (gethash (car k+m) table) (cdr k+m))) - table))))))) - -(defun compute-secondary-dispatch-function1 (generic-function net - &optional function-p) - (cond - ((and (eq (car net) 'methods) (not function-p)) - (get-effective-method-function1 generic-function (cadr net))) - (t - (let* ((name (generic-function-name generic-function)) - (arg-info (gf-arg-info generic-function)) - (metatypes (arg-info-metatypes arg-info)) - (applyp (arg-info-applyp arg-info)) - (fmc-arg-info (cons (length metatypes) applyp)) - (arglist (if function-p - (make-dfun-lambda-list metatypes applyp) - (make-fast-method-call-lambda-list metatypes applyp)))) - (multiple-value-bind - (cfunction constants) - (get-function1 `(,(if function-p - 'kernel:instance-lambda - 'lambda) - ,arglist - ,@(unless function-p - `((declare (ignore .pv-cell. - .next-method-call.)))) - (locally (declare #.*optimize-speed*) - (let ((emf ,net)) - ,(make-emf-call metatypes applyp 'emf)))) - #'net-test-converter - #'net-code-converter - (lambda (form) - (net-constant-converter form generic-function))) - (lambda (method-alist wrappers) - (let* ((alist (list nil)) - (alist-tail alist)) - (dolist (constant constants) - (let* ((a (or (dolist (a alist nil) - (when (eq (car a) constant) - (return a))) - (cons constant - (or (convert-table - constant method-alist wrappers) - (convert-methods - constant method-alist wrappers))))) - (new (list a))) - (setf (cdr alist-tail) new) - (setf alist-tail new))) - (let ((function (apply cfunction (mapcar #'cdr (cdr alist))))) - (if function-p - function - (make-fast-method-call - :function (set-function-name function `(sdfun-method ,name)) - :arg-info fmc-arg-info)))))))))) - -(defvar *show-make-unordered-methods-emf-calls* nil) - -(defun make-unordered-methods-emf (generic-function methods) - (when *show-make-unordered-methods-emf-calls* - (format t "~&make-unordered-methods-emf ~s~%" - (generic-function-name generic-function))) - (lambda (&rest args) - (let* ((types (types-from-arguments generic-function args 'eql)) - (smethods (sort-applicable-methods generic-function methods types)) - (emf (get-effective-method-function generic-function smethods))) - (invoke-emf emf args)))) + (when (eq (car-safe constant) :mcase) + (let ((alist (mapcar (lambda (k+m) + (cons (car k+m) + (convert-methods (cdr k+m) + method-alist wrappers))) + (cddr constant))) + (mp (cadr constant))) + (ecase (cadr mp) + (:simple + (car alist)) + (:assoc + alist) + (:hash-table + (let ((table (make-hash-table :test (if (car mp) 'eq 'eql)))) + (dolist (k+m alist) + (setf (gethash (car k+m) table) (cdr k+m))) + table)))))) ;;; @@ -1534,15 +1464,6 @@ (declare (ignore nreq nopt keysp restp)) (values keywords allow-other-keys-p))) -(defun method-ll->generic-function-ll (ll) - (multiple-value-bind (nreq nopt keysp restp allow-other-keys-p keywords keyword-parameters) - (analyze-lambda-list ll) - (declare (ignore nreq nopt keysp restp allow-other-keys-p keywords)) - (remove-if (lambda (s) - (or (memq s keyword-parameters) - (eq s '&allow-other-keys))) - ll))) - ;;; ;;; This is based on the rules of method lambda list congruency defined in @@ -1551,8 +1472,8 @@ ;;; into account at all yet. ;;; (defmethod generic-function-pretty-arglist - ((generic-function standard-generic-function)) - (let ((methods (generic-function-methods generic-function)) + ((gf standard-generic-function)) + (let ((methods (generic-function-methods gf)) (arglist ())) (when methods (multiple-value-bind (required optional rest key allow-other-keys) diff --git a/pcl/notes.text b/pcl/notes.text deleted file mode 100644 index fef7419e7..000000000 --- a/pcl/notes.text +++ /dev/null @@ -1,280 +0,0 @@ -These notes correspond to the "August 5 92 PCL" version of PCL. - - This version of PCL is much closer than previous versions of PCL -to the metaobject protocol specified in "The Art of the Metaobject Protocol", -chapters 5 and 6, by Gregor Kiczales, Jim des Riveres, and Daniel G. Bobrow. - - -[Please read the file may-day-notes.text also. Most of that file still applies.] - -Support for structures - You can use structure-class as a metaclass to create new classes. - Classes created this way create and evaluate defstruct forms which - have generated symbols for the structure accessors and constructor. - The generated symbols are used by the primary slot-value-using-class - methods and by the primary allocate-instance method for structures. - Defmethod optimizes usages of slot-value (when no user-defined - slot-value-using-class methods exist) into direct calls of the - generated symbol accessor, which the compiler can then optimize further. - Even when there are user-defined methods on slot-value-using-class, - PCL does a variety of optimizations. - - If your implementation's version of the *-low.lisp file - contains definitions of certain structure functions (see the end of - low.lisp, cmu-low.lisp, lucid-low.lisp, and kcl-low.lisp), then - structure classes are supported for all defstructs. In this case, - structure classes are created automatically, when necessary. - -New Classes: -structure-class -structure-object -slot-class -slot-object -structure-direct-slot-definition -structure-effective-slot-definition - -Improvements to slot-access - Optimization for slot-value outsize of defmethod - Optimization for slot-value inside of defmethod, but not of a specialized parameter. - Optimizations that work even when there are :around methods - on slot-value-using-class. - -New types: - `(class ,class-object) - `(class-eq ,class-object) - -New specializer class: class-eq-specializer - Every class has a class-eq specializer which represents all - the direct instances of that class. - This is useful in *subtypep. For example, here is the way - generic-function initialization checks that the method-class is valid: - (and (classp method-class) - (*subtypep (class-eq-specializer method-class) - (find-class 'standard-method))) - If you want to define methods having class-eq specializers, - see "Initialization of method metaobjects". The default behavior of PCL - is to disallow this. - -compute-applicable-methods-using-types - -caching improvements - -no magic-generic-functions list - This simplifies some things, but complicates some other things. - I wanted to support user-defined classes which are their own metaclass. - You can now do: -(defclass y (standard-class) ()) -(defmethod validate-superclass ((c y) (sc standard-class)) t) -(defclass y (standard-class) () (:metaclass y)) - -method-function changes (see the comments for make-method-lambda, below) - -final dfuns - -------------------------- - -gfs which obey AMOP ch 6 - accessor-method-slot-definition - add-dependent - add-direct-method - add-direct-subclass - add-method - allocate-instance - compute-class-precedence-list - compute-default-initargs - compute-discriminating-function - compute-effective-slot-definition -[Note: compute-effective-slot-definition relys on - compute-effective-slot-definition-initargs and effective-slot-definition-class. - compute-effective-slot-definition-initargs is quite useful, but is not in - AMOP ch 6.] - compute-slots - direct-slot-definition-class - effective-slot-definition-class - ensure-class - ensure-class-using-class - ensure-generic-function - ensure-generic-function-using-class - eql-specializer-object - extract-lambda-list - extract-specializer-names - finalize-inheritance - find-method-combination - funcallable-standard-instance-access - {generic-function-method-class, generic-function-method-combination, - generic-function-lambda-list, generic-function-methods, generic-function-name} - intern-eql-specializer - make-instance - make-method-lambda - map-dependents - {method-function, method-generic-function, method-lambda-list, - method-specializers, method-qualifiers} - {class-default-initargs, class-direct-default-initargs, class-direct-slots, - class-direct-subclasses, class-direct-superclasses, class-finalized-p, - class-name, class-precedence-list, class-prototype, class-slots} - {slot-definition-allocation, slot-definition-initargs, slot-definition-initform, - slot-definition-initfunction, slot-definition-name, slot-definition-type} - {slot-definition-readers, slot-definition-writers} - {slot-definition-location} - remove-dependent - remove-direct-method - remove-direct-subclass - remove-method - set-funcallable-instance-function - (setf slot-value-using-class) - slot-boundp-using-class - slot-makunbound-using-class - specializer-direct-generic-functions - specializer-direct-methods - standard-instance-access - update-dependent - -gfs which DO NOT obey AMOP ch 6 - -compute-applicable-methods -compute-applicable-methods-using-classes - Handles class-eq specializers without signalling an error. - But see "Initialization of method metaobjects", below. - -compute-effective-method - Returns only one value. - -generic-function-argument-precedence-order - Not yet defined. Can get this information from the arg-info structure. - -generic-function-declarations - Not yet defined. - -reader-method-class - Not yet defined. Some bootstrapping considerations are involved, - but adding this will not be very hard. - -(setf class-name) - Currently just a writer method. Does not call reinitialize-instance or - (setf find-class). - -(setf generic-function-name) - Currently just a writer method. Does not call reinitialize-instance. - -writer-method-class - Not yet defined. Some bootstrapping considerations are involved, - but adding this will not be very hard. - ---------------------------- - -Initialization of method metaobjects - The following methods are defined: - legal-qualifiers-p (method standard-method) qualifiers - legal-lambda-list-p (method standard-method) lambda-list - legal-specializers-p (method standard-method) specializers - legal-method-function-p (method standard-method) function - legal-documentation-p (method standard-method) documentation - - legal-specializer-p (method standard-method) specializer - - You can override them if you want. - The method for legal-specializers-p calls legal-specializer-p - on each specializer. - The method for legal-specializer-p allows any kind of specializer - when the variable *allow-experimental-specializers-p* is t - (this variable is initially nil). - ---------------------------- -Optimizations on slot-value - Outside of a defmethod when define-compiler-macro is not implemented - or the slot-name is not constant, or - Inside a defmethod when the slot-name is not a constant: -(1) no optimization of slot-value, slot-value-using-class is called. - slot-value-using-class has a special dfun, though, which calls - the slot's slot-definition-reader-function. This function is - a result of get-accessor-method-function. - Outside of a defmethod when define-compiler-macro is implemented and - the slot-name is a constant, or - Inside a defmethod when the slot-name is a constant but the object is - not either (the value of a parameter specialized to a subclass of structure-object - for which no user-defined slot-value-using-class methods apply at defmethod time), - or (the value of a parameter specialized to a subclass of standard-object). -(2) PCL arranges to call an automatically created generic function - which has one method: a reader method defined on class slot-object. - Inside a defmethod when the slot-name is a constant and the object - is (the value of a parameter specialized to a subclass of structure-object - for which no user-defined slot-value-using-class methods apply). -(3) The slot-value form is converted to a call of the structure slot's - accessor function, which the compiler can then optimize further. - Inside a defmethod when the slot-name is a constant and the object - is (the value of a parameter specialized to a subclass of standard-object). -(4) The access requires two arefs, a call to (typep x 'fixnum), and a call to eq, - in the best case. If user defined slot-value-using-class methods apply - at slot-value execution time, or the slot is unbound, the unoptimized - slot-value function (1) is called. This was in May Day PCL; what is new here - is that the PV (permutation vector) is looked up at defmethod load time - rather than at run time, if the effective method is cached. - -Generic functions containing only accessor methods for which no user-defined -methods on slot-value-using-class apply and which involve only standard-classes: - A special dfun is called: one-class, two-class, one-index, or n-n. - These were all in May Day PCL. -Generic functions excluded by the above, which contain accessor methods: - In place of each accessor method's method-function, a function returned by - get-accessor-method-function is used. - -get-accessor-method-function (gf type class slotd) ; type is reader, writer, or boundp. - If there is only one applicable method, - (This method will be the system supplied one) - the function that is returned is optimized for the current state of the - class. When the class changes, it must be recomputed. - otherwise, - a secondary dispatch function for slot-value-using-class is computed - (using what is known about the types of the arguments) and converted - into an accessor function. - -get-secondary-dispatch-function (gf methods types &optional method-alist wrappers) - The types argument describes what is known about the types of the arguments. - Method-alist is used (when supplied) to do things like replace the - standard slot-value-using-class method function with a function optimized - for what is known about the arguments. - Wrappers (when supplied) means that the resulting function is guaranteed to - be called only whith those wrappers. Make-effective-method-function calls - the generic-function method-function-for-caching with method-alist and - wrappers to get a optimized method function. (PV lookup is done at the time - method-function-for-caching is called). - -compute-applicable-methods: Here I tried to stick with the MOP. - The function cache-miss-values looks at the second value of the result of - compute-applicable-methods-using-classes. If this value is null, we aren't - supposed to cache the result of camuc. So we don't. Instead we cache a - result of (default-secondary-dispatch-function gf), which in turn calls - compute-applicable-methods each time it is called. ---------------------------- - -To do: - -Problem: sometimes there is no need to call a gf's dfun: the emf that is invoked - can be cached in the caller's method closure. -1. In expand-defmethod-internal, optimize calls to generic-functions. - Add the support for this optimization. - -2. [When CMUCL improves its setf handling, remove the comment in - the file macros.lisp beginning the line ";#+cmu (pushnew :setf *features*)"] - - - --------------- -1) Generalize expand-defmethod-internal so that it can be used for non-defmethod -code. Maybe by (a) having a parameter that says whether it is being called by -defmethod, and (b) using the techniques used by the series package (shadowing -defun and some others, making the shadowed definitions call e-d-i, making it -easy for people to do the relevant package modifications) - -2) Extending generic-functions by allowing the user at defgeneric time to supply -the name of a function which will be supplied (by the system) with a definition -which will return equivalent results to those returned by the generic function, -but which will (in some cases) have less checking than the generic function. -One-class, two-class, and one-index gf dfuns will map to a result of -get-optimized-std-accessor-method-function, checking gf dfuns will map to their -function, and any other dfun will remain the same. - -3) Extending expand-defmethod-internal to optimize calls to generic-functions. -There are a variety of possibilities that need to be considered; one of them -will be to arrange to call the optimized functions produced by (2) when it -is known to be safe. diff --git a/pcl/pkg.lisp b/pcl/pkg.lisp index 82911c774..5372278ed 100644 --- a/pcl/pkg.lisp +++ b/pcl/pkg.lisp @@ -26,7 +26,7 @@ ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/pkg.lisp,v 1.22 2002/11/21 22:14:19 pmai Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/pkg.lisp,v 1.23 2003/03/22 16:15:16 gerd Exp $") ;;; ;;; CMUCL 18a: Jan-1998 -- Changing to DEFPACKAGE. @@ -42,19 +42,10 @@ "VARIABLE-DECLARATION" "MACROEXPAND-ALL")) -(defpackage "PCL" (:use :common-lisp :walker) - (:shadow "FIND-CLASS" "CLASS-NAME" "CLASS-OF" - "CLASS" "BUILT-IN-CLASS" "STRUCTURE-CLASS" - "STANDARD-CLASS") +(defpackage "PCL" + (:use :common-lisp :walker) (:import-from :kernel "FUNCALLABLE-INSTANCE-P" "SIMPLE-PROGRAM-ERROR") (:shadow "DOCUMENTATION") - - -;;; -;;; These come from the index pages of 88-002R. -;;; -;;; - (:export "ADD-METHOD" "BUILT-IN-CLASS" "CALL-METHOD" @@ -100,6 +91,12 @@ "WITH-ACCESSORS" "WITH-SLOTS" ) + + (:export "SEAL" "UNSEAL" "SEALED-ERROR") + + ;; Function names. + (:export "EFFECTIVE-METHOD" "FAST-METHOD" "SLOT-ACCESSOR" + "CLASS-PREDICATE") (:export "STANDARD-INSTANCE" "FUNCALLABLE-STANDARD-INSTANCE" @@ -142,6 +139,7 @@ "COMPUTE-APPLICABLE-METHODS-USING-CLASSES" "COMPUTE-CLASS-PRECEDENCE-LIST" "COMPUTE-DISCRIMINATING-FUNCTION" + "COMPUTE-DEFAULT-INITARGS" "COMPUTE-EFFECTIVE-METHOD" "COMPUTE-EFFECTIVE-SLOT-DEFINITION" "COMPUTE-SLOTS" @@ -151,7 +149,7 @@ "ENSURE-CLASS-USING-CLASS" "ENSURE-GENERIC-FUNCTION" "ENSURE-GENERIC-FUNCTION-USING-CLASS" - "EQL-SPECIALIZER-INSTANCE" + "EQL-SPECIALIZER-OBJECT" "EXTRACT-LAMBDA-LIST" "EXTRACT-SPECIALIZER-NAMES" "FINALIZE-INHERITANCE" @@ -192,109 +190,92 @@ "SLOT-DEFINITION-TYPE" "SLOT-MAKUNBOUND-USING-CLASS" "SLOT-VALUE-USING-CLASS" - "SPECIALIZER-DIRECT-GENERIC-FUNCTION" + "SPECIALIZER-DIRECT-GENERIC-FUNCTIONS" "SPECIALIZER-DIRECT-METHODS" "STANDARD-INSTANCE-ACCESS" "UPDATE-DEPENDENT" "VALIDATE-SUPERCLASS" - "WRITER-METHOD-CLASS" - )) + "WRITER-METHOD-CLASS")) -(defpackage "SLOT-ACCESSOR-NAME" (:use)(:nicknames "S-A-N")) - -(in-package :pcl) -(defvar *slot-accessor-name-package* - (find-package :slot-accessor-name)) - +;;; ;;; These symbol names came from "The Art of the Metaobject Protocol". ;;; - (defpackage "CLOS-MOP" (:use :pcl :common-lisp) (:nicknames "MOP") - - (:shadowing-import-from :pcl - "FIND-CLASS" "CLASS-NAME" "BUILT-IN-CLASS" "CLASS-OF") - (:export - "FIND-CLASS" "CLASS-NAME" "BUILT-IN-CLASS" "CLASS-OF") - - (:export ;; Names taken from "The Art of the Metaobject Protocol" - "ADD-DEPENDENT" - "ADD-DIRECT-METHOD" - "ADD-DIRECT-SUBCLASS" - "ADD-METHOD" - "ALLOCATE-INSTANCE" - "CLASS-DEFAULT-INITARGS" - "CLASS-DIRECT-DEFAULT-INITARGS" - "CLASS-DIRECT-SLOTS" - "CLASS-DIRECT-SUBCLASSES" - "CLASS-DIRECT-SUPERCLASSES" - "CLASS-FINALIZED-P" - "CLASS-NAME" - "CLASS-PRECEDENCE-LIST" - "CLASS-PROTOTYPE" - "CLASS-SLOTS" - "COMPUTE-APPLICABLE-METHODS" - "COMPUTE-APPLICABLE-METHODS-USING-CLASSES" - "COMPUTE-CLASS-PRECEDENCE-LIST" - "COMPUTE-DEFAULT-INITARGS" - "COMPUTE-DISCRIMINATING-FUNCTION" - "COMPUTE-EFFECTIVE-METHOD" - "COMPUTE-EFFECTIVE-SLOT-DEFINITION" - "COMPUTE-SLOTS" - "DIRECT-SLOT-DEFINITION-CLASS" - "EFFECTIVE-SLOT-DEFINITION-CLASS" - "ENSURE-CLASS" - "ENSURE-CLASS-USING-CLASS" - "ENSURE-GENERIC-FUNCTION" - "ENSURE-GENERIC-FUNCTION-USING-CLASS" - "EQL-SPECIALIZER-OBJECT" - "EXTRACT-LAMBDA-LIST" - "EXTRACT-SPECIALIZER-NAMES" - "FINALIZE-INHERITANCE" - "FIND-METHOD-COMBINATION" - "FUNCALLABLE-STANDARD-INSTANCE-ACCESS" - "GENERIC-FUNCTION-ARGUMENT-PRECEDENCE-ORDER" - "GENERIC-FUNCTION-DECLARATIONS" - "GENERIC-FUNCTION-LAMBDA-LIST" - "GENERIC-FUNCTION-METHOD-CLASS" - "GENERIC-FUNCTION-METHOD-COMBINATION" - "GENERIC-FUNCTION-METHODS" - "GENERIC-FUNCTION-NAME" - "INTERN-EQL-SPECIALIZER" - "MAKE-INSTANCE" - "MAKE-METHOD-LAMBDA" - "MAP-DEPENDENTS" - "METHOD-FUNCTION" - "METHOD-GENERIC-FUNCTION" - "METHOD-LAMBDA-LIST" - "METHOD-SPECIALIZERS" - "METHOD-QUALIFIERS" - "ACCESSOR-METHOD-SLOT-DEFINITION" - - "SLOT-DEFINITION-ALLOCATION" - "SLOT-DEFINITION-INITARGS" - "SLOT-DEFINITION-INITFORM" - "SLOT-DEFINITION-INITFUNCTION" - "SLOT-DEFINITION-NAME" - "SLOT-DEFINITION-TYPE" - "SLOT-DEFINITION-READERS" - "SLOT-DEFINITION-WRITERS" - "SLOT-DEFINITION-LOCATION" - - "READER-METHOD-CLASS" - "REMOVE-DEPENDENT" - "REMOVE-DIRECT-METHOD" - "REMOVE-DIRECT-SUBCLASS" - "REMOVE-METHOD" - "SET-FUNCALLABLE-INSTANCE-FUNCTION" - "SLOT-BOUNDP-USING-CLASS" - "SLOT-MAKUNBOUND-USING-CLASS" - "SLOT-VALUE-USING-CLASS" - "SPECIALIZER-DIRECT-GENERIC-FUNCTIONS" - "SPECIALIZER-DIRECT-METHODS" - "STANDARD-INSTANCE-ACCESS" - "UPDATE-DEPENDENT" - "VALIDATE-SUPERCLASS" - "WRITER-METHOD-CLASS" - )) + (:export "ACCESSOR-METHOD-SLOT-DEFINITION" + "ADD-DEPENDENT" + "ADD-DIRECT-METHOD" + "ADD-DIRECT-SUBCLASS" + "ADD-METHOD" + "ALLOCATE-INSTANCE" + "CLASS-DEFAULT-INITARGS" + "CLASS-DIRECT-DEFAULT-INITARGS" + "CLASS-DIRECT-SLOTS" + "CLASS-DIRECT-SUBCLASSES" + "CLASS-DIRECT-SUPERCLASSES" + "CLASS-FINALIZED-P" + "CLASS-NAME" + "CLASS-PRECEDENCE-LIST" + "CLASS-PROTOTYPE" + "CLASS-SLOTS" + "COMPUTE-APPLICABLE-METHODS" + "COMPUTE-APPLICABLE-METHODS-USING-CLASSES" + "COMPUTE-CLASS-PRECEDENCE-LIST" + "COMPUTE-DEFAULT-INITARGS" + "COMPUTE-DISCRIMINATING-FUNCTION" + "COMPUTE-EFFECTIVE-METHOD" + "COMPUTE-EFFECTIVE-SLOT-DEFINITION" + "COMPUTE-SLOTS" + "DIRECT-SLOT-DEFINITION-CLASS" + "EFFECTIVE-SLOT-DEFINITION-CLASS" + "ENSURE-CLASS" + "ENSURE-CLASS-USING-CLASS" + "ENSURE-GENERIC-FUNCTION" + "ENSURE-GENERIC-FUNCTION-USING-CLASS" + "EQL-SPECIALIZER-OBJECT" + "EXTRACT-LAMBDA-LIST" + "EXTRACT-SPECIALIZER-NAMES" + "FINALIZE-INHERITANCE" + "FIND-METHOD-COMBINATION" + "FUNCALLABLE-STANDARD-INSTANCE-ACCESS" + "GENERIC-FUNCTION-ARGUMENT-PRECEDENCE-ORDER" + "GENERIC-FUNCTION-DECLARATIONS" + "GENERIC-FUNCTION-LAMBDA-LIST" + "GENERIC-FUNCTION-METHOD-CLASS" + "GENERIC-FUNCTION-METHOD-COMBINATION" + "GENERIC-FUNCTION-METHODS" + "GENERIC-FUNCTION-NAME" + "INTERN-EQL-SPECIALIZER" + "MAKE-INSTANCE" + "MAKE-METHOD-LAMBDA" + "MAP-DEPENDENTS" + "METHOD-FUNCTION" + "METHOD-GENERIC-FUNCTION" + "METHOD-LAMBDA-LIST" + "METHOD-QUALIFIERS" + "METHOD-SPECIALIZERS" + "READER-METHOD-CLASS" + "REMOVE-DEPENDENT" + "REMOVE-DIRECT-METHOD" + "REMOVE-DIRECT-SUBCLASS" + "REMOVE-METHOD" + "SET-FUNCALLABLE-INSTANCE-FUNCTION" + "SLOT-BOUNDP-USING-CLASS" + "SLOT-DEFINITION-ALLOCATION" + "SLOT-DEFINITION-INITARGS" + "SLOT-DEFINITION-INITFORM" + "SLOT-DEFINITION-INITFUNCTION" + "SLOT-DEFINITION-LOCATION" + "SLOT-DEFINITION-NAME" + "SLOT-DEFINITION-READERS" + "SLOT-DEFINITION-TYPE" + "SLOT-DEFINITION-WRITERS" + "SLOT-MAKUNBOUND-USING-CLASS" + "SLOT-VALUE-USING-CLASS" + "SPECIALIZER-DIRECT-GENERIC-FUNCTIONS" + "SPECIALIZER-DIRECT-METHODS" + "STANDARD-INSTANCE-ACCESS" + "UPDATE-DEPENDENT" + "VALIDATE-SUPERCLASS" + "WRITER-METHOD-CLASS")) diff --git a/pcl/precom1.lisp b/pcl/precom1.lisp deleted file mode 100644 index 5977c0d80..000000000 --- a/pcl/precom1.lisp +++ /dev/null @@ -1,27 +0,0 @@ -;;;-*-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. -;;; ************************************************************************* -;;; - diff --git a/pcl/precom4.lisp b/pcl/precom4.lisp deleted file mode 100644 index fe13ee147..000000000 --- a/pcl/precom4.lisp +++ /dev/null @@ -1,32 +0,0 @@ -;;;-*-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) - -(precompile-function-generators pcl) ;this is half of a call to - ;precompile-random-code-segments - diff --git a/pcl/rt/ctor.lisp b/pcl/rt/ctor.lisp new file mode 100644 index 000000000..f990bcf1e --- /dev/null +++ b/pcl/rt/ctor.lisp @@ -0,0 +1,412 @@ +;;; Copyright (C) 2002 Gerd Moellmann <gerd.moellmann@t-online.de> +;;; All rights reserved. +;;; +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: +;;; +;;; 1. Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. +;;; 2. Redistributions in binary form must reproduce the above copyright +;;; notice, this list of conditions and the following disclaimer in the +;;; documentation and/or other materials provided with the distribution. +;;; 3. The name of the author may not be used to endorse or promote +;;; products derived from this software without specific prior written +;;; permission. +;;; +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE +;;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +;;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT +;;; OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR +;;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE +;;; USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH +;;; DAMAGE. + +#+cmu +(ext:file-comment "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/rt/ctor.lisp,v 1.2 2003/03/22 16:15:15 gerd Exp $") + +(in-package "PCL-TEST") + +(deftest plist-keys.0 + (pcl::plist-keys '()) + nil) + +(deftest plist-keys.1 + (pcl::plist-keys '(:a 1 :b 2)) + (:a :b)) + +(deftest plist-keys.2 + (multiple-value-bind (result condition) + (ignore-errors (pcl::plist-keys '(:a))) + (values result (typep condition 'condition))) + nil + t) + +(deftest make-instance->constructor-call.0 + (pcl::make-instance->constructor-call '(make-instance 'foo a x)) + nil) + +(deftest make-instance->constructor-call.1 + (pcl::make-instance->constructor-call '(make-instance foo :a x)) + nil) + +(deftest make-instance->constructor-call.2 + (pcl::make-instance->constructor-call '(make-instance 'foo x)) + nil) + +(deftest make-instance->constructor-call.4 + (pcl::make-instance->constructor-call '(make-instance 1)) + nil) + +(deftest make-instance->constructor-call.5 + (let* ((form (pcl::make-instance->constructor-call + '(make-instance 'foo))) + (call (car (last form)))) + (values (eq (first call) 'funcall) + (cddr call))) + t ()) + +(deftest make-instance->constructor-call.6 + (let* ((form (pcl::make-instance->constructor-call + '(make-instance 'foo :x 1 :y 2))) + (call (car (last form)))) + (values (eq (first call) 'funcall) + (cddr call))) + t ()) + +(deftest make-instance->constructor-call.7 + (let* ((form (pcl::make-instance->constructor-call + '(make-instance 'foo :x x :y 2))) + (call (car (last form)))) + (values (eq (first call) 'funcall) + (cddr call))) + t (x)) + +(deftest make-instance->constructor-call.8 + (let* ((form (pcl::make-instance->constructor-call + '(make-instance 'foo :x x :y y))) + (call (car (last form)))) + (values (eq (first call) 'funcall) + (cddr call))) + t (x y)) + +(deftest make-instance->constructor-call.9 + (let* ((form (pcl::make-instance->constructor-call + '(make-instance 'foo :x x :y 1))) + (call (car (last form)))) + (values (eq (first call) 'funcall) + (cddr call))) + t (x)) + +(deftest make-instance->constructor-call.10 + (let* ((form (pcl::make-instance->constructor-call + '(make-instance 'foo :x x :y 1 :z z))) + (call (car (last form)))) + (values (eq (first call) 'funcall) + (cddr call))) + t (x z)) + +(deftest make-ctor.0 + (let ((ctor (pcl::make-ctor '(pcl::ctor bar) 'bar '(:x 1 :y 2)))) + (values (pcl::ctor-function-name ctor) + (pcl::ctor-class-name ctor) + (pcl::ctor-initargs ctor))) + (pcl::ctor bar) + bar + (:x 1 :y 2)) + +(defclass foo () + ((a :initarg :a :initform 1) + (b :initarg :b :initform 2))) + +(defun call-generator (generator function-name class-name args) + (declare (ignore function-name)) + (let* ((ctor + (pcl::make-ctor (list 'pcl::ctor class-name) class-name args)) + (class (find-class class-name)) + (proto (pcl::class-prototype class)) + (ii (pcl::compute-applicable-methods + #'initialize-instance (list proto))) + (si (pcl::compute-applicable-methods + #'shared-initialize (list proto t)))) + (setf (pcl::ctor-class ctor) class) + (funcall generator ctor ii si))) + +(deftest fallback-generator.0 + (let ((fn (call-generator #'pcl::fallback-generator + 'make-foo 'foo '(:a 0 :b 1)))) + (values (second fn) + (type-of (second (third fn))) + (nthcdr 2 (third fn)))) + () + pcl::standard-class + (:a 0 :b 1)) + +(deftest fallback-generator.1 + (let ((fn (call-generator #'pcl::fallback-generator + 'make-foo 'foo '(:a 0)))) + (values (second fn) + (first (third fn)) + (type-of (second (third fn))) + (nthcdr 2 (third fn)))) + () + make-instance + pcl::standard-class + (:a 0)) + +(deftest fallback-generator.2 + (let ((fn (call-generator #'pcl::fallback-generator + 'make-foo 'foo '()))) + (values (second fn) + (type-of (second (third fn))) + (nthcdr 2 (third fn)))) + () + pcl::standard-class + ()) + +(deftest fallback-generator.3 + (let ((fn (call-generator #'pcl::fallback-generator + 'make-foo 'foo '(:a .p0.)))) + (values (second fn) + (type-of (second (third fn))) + (nthcdr 2 (third fn)))) + (.p0.) + pcl::standard-class + (:a .p0.)) + +(deftest fallback-generator.4 + (let ((fn (call-generator #'pcl::fallback-generator + 'make-foo 'foo '(:a a :b b)))) + (values (second fn) + (type-of (second (third fn))) + (nthcdr 2 (third fn)))) + (a b) + pcl::standard-class + (:a a :b b)) + +;;; These depend on the actual slot definition location computation, +;;; which may be different in my PCL than in the CVS PCL. + +(deftest compute-initarg-locations.0 + (let ((class (find-class 'foo))) + (pcl::compute-initarg-locations class '(:a :b))) + ((:a (1 . t)) (:b (0 . t)))) + +(defclass foo2 (foo) + ((c :initarg :a))) + +(deftest compute-initarg-locations.1 + (let ((class (find-class 'foo2))) + (pcl::compute-initarg-locations class '(:a :b))) + ((:a (1 . t) (2 . t)) (:b (0 . t)))) + +(defclass foo3 (foo) + ((c :initarg :a :allocation :class))) + +;;; +;;; This test must be compiled for the case that PCL::+SLOT-UNBOUND+ +;;; is a symbol macro calling PCL::MAKE-UNBOUND-MARKER, otherwise +;;; we'll get a complaint that C::%%PRIMITIVE is not defined. +;;; +(define-compiled-test compute-initarg-locations.2 + (let ((class (find-class 'foo3))) + (subst 'unbound pcl::+slot-unbound+ + (pcl::compute-initarg-locations class '(:a :b)))) + ((:a (1 . t) ((c . unbound) . t)) (:b (0 . t)))) + +(defclass foo4 () + ((a :initarg :a :initarg :both) + (b :initarg :b :initarg :both))) + +(deftest compute-initarg-locations.3 + (let ((class (find-class 'foo4))) + (pcl::compute-initarg-locations class '(:both :a :b))) + ((:both (0 . t) (1 . t)) (:a) (:b))) + +(deftest compute-initarg-locations.4 + (let ((class (find-class 'foo4))) + (pcl::compute-initarg-locations class '(:a :both))) + ((:a (1 . t)) (:both (0 . t)))) + +(deftest slot-init-forms.0 + (let ((ctor (pcl::make-ctor + (list 'pcl::ctor 'make-foo) + 'foo '(:a a :b b)))) + (setf (pcl::ctor-class ctor) (find-class 'foo)) + (pcl::slot-init-forms ctor nil)) + (progn + (setf (pcl::%svref pcl::.slots. 0) (the t b)) + (setf (pcl::%svref pcl::.slots. 1) (the t a)))) + +(deftest slot-init-forms.1 + (let ((ctor (pcl::make-ctor + (list 'pcl::ctor 'make-foo) + 'foo '(:a a)))) + (setf (pcl::ctor-class ctor) (find-class 'foo)) + (pcl::slot-init-forms ctor nil)) + (progn + (setf (pcl::%svref pcl::.slots. 0) (the t '2)) + (setf (pcl::%svref pcl::.slots. 1) (the t a)))) + +(defclass foo5 () + ((a :initarg :a :initform 0) + (b :initarg :b))) + +(deftest slot-init-forms.2 + (let ((ctor (pcl::make-ctor + (list 'pcl::ctor 'make-foo) + 'foo5 '(:a a)))) + (setf (pcl::ctor-class ctor) (find-class 'foo5)) + (pcl::slot-init-forms ctor nil)) + (progn + (setf (pcl::%svref pcl::.slots. 0) pcl::+slot-unbound+) + (setf (pcl::%svref pcl::.slots. 1) (the t a)))) + +(defclass foo5a () + ((a :initarg :a :initform 0) + (b :initarg :b :initform 0))) + +(deftest slot-init-forms.2a + (let ((ctor (pcl::make-ctor + (list 'pcl::ctor 'make-foo) + 'foo5a '()))) + (setf (pcl::ctor-class ctor) (find-class 'foo5a)) + (pcl::slot-init-forms ctor nil)) + (progn + (setf (pcl::%svref pcl::.slots. 0) (the t '0)) + (setf (pcl::%svref pcl::.slots. 1) (the t '0)))) + +(defclass foo6 () + ((a :initarg :a :initform 0 :allocation :class) + (b :initarg :b))) + +(deftest slot-init-forms.3 + (let ((ctor (pcl::make-ctor + (list 'pcl::ctor 'make-foo) + 'foo6 '(:a a)))) + (setf (pcl::ctor-class ctor) (find-class 'foo6)) + (pcl::slot-init-forms ctor nil)) + (progn + (setf (pcl::%svref pcl::.slots. 0) pcl::+slot-unbound+) + (setf (cdr '(a . 0)) (the t a)))) + +(defun foo () + (error "should never be called")) + +(defclass foo7 () + ((a :initarg :a :initform (foo)) + (b :initarg :b))) + +(deftest slot-init-forms.4 + (let* ((ctor (pcl::make-ctor + (list 'pcl::ctor 'make-foo) + 'foo7 '()))) + (setf (pcl::ctor-class ctor) (find-class 'foo7)) + (let ((form (pcl::slot-init-forms ctor nil))) + (values (second form) + (second (third form)) + (first (third (third (third form)))) + (functionp (second (third (third (third form)))))))) + (setf (pcl::%svref pcl::.slots. 0) pcl::+slot-unbound+) + (pcl::%svref pcl::.slots. 1) + funcall + t) + +(deftest slot-init-forms.5 + (let ((ctor (pcl::make-ctor + (list 'pcl::ctor 'make-foo) + 'foo '(:a '(foo))))) + (setf (pcl::ctor-class ctor) (find-class 'foo)) + (pcl::slot-init-forms ctor nil)) + (progn + (setf (pcl::%svref pcl::.slots. 0) (the t '2)) + (setf (pcl::%svref pcl::.slots. 1) (the t '(foo))))) + +(deftest slot-init-forms.6 + (let ((ctor (pcl::make-ctor + (list 'pcl::ctor 'make-foo) + 'foo '(:a 'x)))) + (setf (pcl::ctor-class ctor) (find-class 'foo)) + (pcl::slot-init-forms ctor nil)) + (progn + (setf (pcl::%svref pcl::.slots. 0) (the t '2)) + (setf (pcl::%svref pcl::.slots. 1) (the t 'x)))) + +(defmethod bar1 ((x integer)) + (* x 2)) + +#+nil +(deftest invoke-method.0 + (let ((methods (pcl::compute-applicable-methods #'bar1 (list 1)))) + (eval `(pcl::invoke-method ,(first methods) ',(list 1)))) + 2) + +#+nil +(deftest invoke-method.1 + (let ((methods (pcl::compute-applicable-methods #'bar1 (list 1))) + (args (list 2))) + (eval `(pcl::invoke-method ,(first methods) ',args))) + 4) + +#+nil +(deftest invoke-method.2 + (let ((methods (pcl::compute-applicable-methods #'bar1 (list 1)))) + (eval `(let ((.args. (list 3))) + (pcl::invoke-method ,(first methods) .args.)))) + 6) + +(defmethod bar2 ((x integer)) x) +(defmethod bar2 :around ((x integer)) x) + +(deftest around-or-nonstandard-primary-method-p.0 + (pcl::around-or-nonstandard-primary-method-p + (pcl::compute-applicable-methods #'bar2 (list 1))) + t) + +(defmethod bar3 ((x integer)) x) +(defmethod bar3 :after ((x integer)) x) + +(deftest around-or-nonstandard-primary-method-p.1 + (pcl::around-or-nonstandard-primary-method-p + (pcl::compute-applicable-methods #'bar3 (list 1))) + nil) + +(deftest optimizing-generator.0 + (let ((fn (call-generator #'pcl::optimizing-generator + 'make-foo 'foo '(:a 0 :b 1)))) + (second fn)) + ()) + +(defun construct (class-name initargs &rest args) + (let* ((form (call-generator #'pcl::optimizing-generator + 'some-function-name + class-name + initargs)) + (fn (pcl::compile-lambda form))) + (apply fn args))) + +(deftest optimizing-generator.1 + (with-slots (a b) (construct 'foo '(:a 0 :b 1)) + (values a b)) + 0 1) + +(deftest optimizing-generator.2 + (with-slots (a b) (construct 'foo '()) + (values a b)) + 1 2) + +(defclass g1 () + ((a :initform 0) + (b))) + +(deftest optimizing-generator.3 + (let ((instance (construct 'g1 '()))) + (values (slot-value instance 'a) + (slot-boundp instance 'b))) + 0 nil) + diff --git a/pcl/rt/defclass.lisp b/pcl/rt/defclass.lisp new file mode 100644 index 000000000..de199e900 --- /dev/null +++ b/pcl/rt/defclass.lisp @@ -0,0 +1,177 @@ +;;; Copyright (C) 2002 Gerd Moellmann <gerd.moellmann@t-online.de> +;;; All rights reserved. +;;; +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: +;;; +;;; 1. Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. +;;; 2. Redistributions in binary form must reproduce the above copyright +;;; notice, this list of conditions and the following disclaimer in the +;;; documentation and/or other materials provided with the distribution. +;;; 3. The name of the author may not be used to endorse or promote +;;; products derived from this software without specific prior written +;;; permission. +;;; +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE +;;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +;;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT +;;; OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR +;;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE +;;; USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH +;;; DAMAGE. + +#+cmu +(ext:file-comment "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/rt/defclass.lisp,v 1.2 2003/03/22 16:15:15 gerd Exp $") + +(in-package "PCL-TEST") + +(deftest defclass-subtypep.0 + (progn + (defclass st0 () ()) + (defclass st1 () ()) + (subtypep 'st1 'st0)) + nil t) + +(deftest defclass-subtypep.1 + (progn + (defclass st1 (st0) ()) + (subtypep 'st1 'st0)) + t t) + +(deftest defclass-subtypep.2 + (progn + (defclass st1 () ()) + (subtypep 'st1 'st0)) + nil t) + +(defvar *instance* nil) +(defvar *update-instance-result* nil) + +(defclass st2 () + ((a :initform 0 :accessor a))) + +(defclass st3 () + ((b :initform 0 :accessor b))) + +(deftest update-instance-for-redefined-class.0 + (progn + (setq *instance* (make-instance 'st3)) + t) + t) + +(defmethod update-instance-for-redefined-class :after + ((instance st3) added-slots discarded-slots property-list &rest initargs) + (setq *update-instance-result* + (list instance added-slots discarded-slots property-list initargs))) + +(deftest update-instance-for-redefined-class.1 + (progn + (defclass st3 (st2) + ((b :initform 0 :accessor b))) + (values (slot-value *instance* 'b) + (eq *instance* (first *update-instance-result*)) + (rest *update-instance-result*))) + 0 t ((a) nil nil nil)) + +(deftest update-instance-for-redefined-class.2 + (progn + (defclass st3 () + ((b :initform 0 :accessor b))) + (values (slot-value *instance* 'b) + (eq *instance* (first *update-instance-result*)) + (rest *update-instance-result*))) + 0 t (nil (a) (a 0) nil)) + +(deftest defclass-sxhash.0 + (let ((i1 (make-instance 'st2)) + (i2 (make-instance 'st2))) + (/= (sxhash i1) (sxhash i2))) + t) + +(deftest generic-function-sxhash.0 + (/= (sxhash #'allocate-instance) + (sxhash #'make-instance)) + t) + +(deftest defclass-redefinition.0 + (multiple-value-bind (r c) + (ignore-errors + (defclass rd0 () ()) + (defclass rd1 (rd0) ()) + (defclass rd2 () ()) + (defclass rd0 (rd2) ()) + (make-instance 'rd1)) + (values (not (null r)) (null c))) + t t) + +;;; This failed to compile in an old version, that's why it's here. + +(deftest defclass-inherited-class-slots.0 + (multiple-value-bind (r c) + (ignore-errors + (defclass ics0 () + ((a :allocation :class :accessor ics0-a))) + (defclass ics1 (ics0) + ()) + (make-instance 'ics1)) + (values (not (null r)) (null c))) + t t) + +(defmacro define-defclass-syntax-test (name class-body &rest options) + `(deftest ,name + (multiple-value-bind (r c) + (ignore-errors + (defclass dc0 () + ,class-body ,@options)) + (declare (ignore r)) + (typep c 'error)) + t)) + +;; CLHS: allocation should be :class or :instance +(define-defclass-syntax-test defclass.0 ((a :allocation :foo))) + +;; Reader names should be symbols. +(define-defclass-syntax-test defclass.1 ((a :reader (setf a)))) + +;;; initarg names must be symbols. +(define-defclass-syntax-test defclass.2 ((a :initarg 1))) + +;; Duplicate :default-initargs is an error. +(define-defclass-syntax-test defclass.3 () + (:default-initargs :a 1) + (:default-initargs :b 2)) + +;; Duplicate :metaclass. +(define-defclass-syntax-test defclass.4 () + (:metaclass pcl::funcallable-standard-class) + (:metaclass 1)) + +;; class option that is not implemented locally -> error +(define-defclass-syntax-test defclass.5 () + (:foo t)) + +(deftest defclass-structure-class.0 + (multiple-value-bind (r c) + (ignore-errors + (defclass dscl.0 () + (a b) + (:metaclass pcl::structure-class)) + t) + (values r (null c))) + t t) + +(deftest defclass-structure-class.1 + (multiple-value-bind (r c) + (ignore-errors + (make-instance 'dscl.0) + t) + (values r (null c))) + t t) + diff --git a/pcl/rt/defgeneric.lisp b/pcl/rt/defgeneric.lisp new file mode 100644 index 000000000..decc927a0 --- /dev/null +++ b/pcl/rt/defgeneric.lisp @@ -0,0 +1,62 @@ +;;; Copyright (C) 2002 Gerd Moellmann <gerd.moellmann@t-online.de> +;;; All rights reserved. +;;; +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: +;;; +;;; 1. Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. +;;; 2. Redistributions in binary form must reproduce the above copyright +;;; notice, this list of conditions and the following disclaimer in the +;;; documentation and/or other materials provided with the distribution. +;;; 3. The name of the author may not be used to endorse or promote +;;; products derived from this software without specific prior written +;;; permission. +;;; +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE +;;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +;;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT +;;; OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR +;;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE +;;; USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH +;;; DAMAGE. + +#+cmu +(ext:file-comment "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/rt/defgeneric.lisp,v 1.2 2003/03/22 16:15:15 gerd Exp $") + +(in-package "PCL-TEST") + +(defmacro define-gf-lambda-list-test (name lambda-list) + `(deftest ,name + (multiple-value-bind (r c) + (ignore-errors + (defgeneric g ,lambda-list)) + (values (null r) (typep c 'error))) + t t)) + +(define-gf-lambda-list-test defgeneric-lambda-list.0 (a &optional (b 1))) +(define-gf-lambda-list-test defgeneric-lambda-list.1 (a &key (b 1))) +(define-gf-lambda-list-test defgeneric-lambda-list.2 ((a gf-class))) + +;;; +;;; CMUCL died with an illegal instruction when creating an instance +;;; of the following class, due to a slot layout that was incompatible +;;; with that of funcallable instances. +;;; +(defclass gf-class (standard-generic-function) + () + (:metaclass pcl::funcallable-standard-class)) + +(deftest defgeneric-generic-function-class.0 + (progn + (defgeneric g (a b c) + (:generic-function-class gf-class)) + t) + t) + diff --git a/pcl/rt/defmethod.lisp b/pcl/rt/defmethod.lisp new file mode 100644 index 000000000..49b2494cb --- /dev/null +++ b/pcl/rt/defmethod.lisp @@ -0,0 +1,76 @@ +;;; Copyright (C) 2002 Gerd Moellmann <gerd.moellmann@t-online.de> +;;; All rights reserved. +;;; +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: +;;; +;;; 1. Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. +;;; 2. Redistributions in binary form must reproduce the above copyright +;;; notice, this list of conditions and the following disclaimer in the +;;; documentation and/or other materials provided with the distribution. +;;; 3. The name of the author may not be used to endorse or promote +;;; products derived from this software without specific prior written +;;; permission. +;;; +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE +;;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +;;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT +;;; OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR +;;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE +;;; USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH +;;; DAMAGE. + +#+cmu +(ext:file-comment "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/rt/defmethod.lisp,v 1.2 2003/03/22 16:15:15 gerd Exp $") + +(in-package "PCL-TEST") + +(defmethod dm0 (x) + x) + +(defmethod dm1 (x &rest y) + (list x y)) + +(defmethod dm2 (x &optional y) + (list x y)) + +(defmacro define-defmethod-test (name method qual lambda-list + &rest values) + `(deftest ,name + (multiple-value-bind (r c) + (ignore-errors + (defmethod ,method ,@(when qual `(,qual)) ,lambda-list + #+cmu (declare (optimize (ext:inhibit-warnings 3))) + nil)) + (values (typep r 'method) + (typep c 'error) + (length (pcl:generic-function-methods #',method)))) + ,@values)) + +(defmacro define-defmethod-test-1 (name method qual lambda-list) + `(define-defmethod-test ,name ,method ,qual ,lambda-list nil t 1)) + +(define-defmethod-test-1 defmethod.0 dm0 nil (x y)) +(define-defmethod-test-1 defmethod.1 dm0 nil (x &rest y)) +(define-defmethod-test-1 defmethod.2 dm0 nil (x &key y)) +(define-defmethod-test-1 defmethod.4 dm0 :before (x y)) +(define-defmethod-test-1 defmethod.5 dm0 :before (x &rest y)) +(define-defmethod-test-1 defmethod.6 dm0 :before (x &key y)) +(define-defmethod-test defmethod.7 dm0 nil (x) t nil 1) + +(define-defmethod-test-1 defmethod.10 dm1 nil (x y)) +(define-defmethod-test-1 defmethod.11 dm1 nil (x)) +(define-defmethod-test defmethod.12 dm1 nil (x &key y) t nil 1) +(define-defmethod-test defmethod.13 dm1 nil (x &key y z) t nil 1) +(define-defmethod-test defmethod.14 dm1 nil (x &rest y) t nil 1) + +(define-defmethod-test-1 defmethod.20 dm2 nil (x)) +(define-defmethod-test-1 defmethod.21 dm2 nil (x &optional y z)) +(define-defmethod-test-1 defmethod.22 dm2 nil (x &key y)) diff --git a/pcl/rt/find-method.lisp b/pcl/rt/find-method.lisp new file mode 100644 index 000000000..5c83e1fad --- /dev/null +++ b/pcl/rt/find-method.lisp @@ -0,0 +1,51 @@ +;;; Copyright (C) 2002 Gerd Moellmann <gerd.moellmann@t-online.de> +;;; All rights reserved. +;;; +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: +;;; +;;; 1. Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. +;;; 2. Redistributions in binary form must reproduce the above copyright +;;; notice, this list of conditions and the following disclaimer in the +;;; documentation and/or other materials provided with the distribution. +;;; 3. The name of the author may not be used to endorse or promote +;;; products derived from this software without specific prior written +;;; permission. +;;; +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE +;;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +;;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT +;;; OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR +;;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE +;;; USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH +;;; DAMAGE. + +#+cmu +(ext:file-comment "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/rt/find-method.lisp,v 1.2 2003/03/22 16:15:14 gerd Rel $") + +(in-package "PCL-TEST") + +(defmethod fm0 (x y) + (list x y)) + +(deftest find-method.0 + (multiple-value-bind (r c) + (ignore-errors + (find-method #'fm0 nil (list t))) + (values r (typep c 'error))) + nil t) + +(deftest find-method.1 + (multiple-value-bind (r c) + (ignore-errors + (find-method #'fm0 nil (list t t))) + (values (typep r 'method) (typep c 'error))) + t nil) + diff --git a/pcl/rt/inline-access.lisp b/pcl/rt/inline-access.lisp new file mode 100644 index 000000000..b29d43ff4 --- /dev/null +++ b/pcl/rt/inline-access.lisp @@ -0,0 +1,243 @@ +;;; Copyright (C) 2002 Gerd Moellmann <gerd.moellmann@t-online.de> +;;; All rights reserved. +;;; +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: +;;; +;;; 1. Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. +;;; 2. Redistributions in binary form must reproduce the above copyright +;;; notice, this list of conditions and the following disclaimer in the +;;; documentation and/or other materials provided with the distribution. +;;; 3. The name of the author may not be used to endorse or promote +;;; products derived from this software without specific prior written +;;; permission. +;;; +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE +;;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +;;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT +;;; OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR +;;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE +;;; USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH +;;; DAMAGE. + +#+cmu +(ext:file-comment "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/rt/inline-access.lisp,v 1.2 2003/03/22 16:15:14 gerd Exp $") + +(in-package "PCL-TEST") + +(defun test-walk (form test-function &optional env) + (let ((result nil)) + (flet ((walk-function (form context env) + (declare (ignore context)) + (when (and (consp form) (eq (car form) 'test)) + (push (funcall test-function env) result)) + form)) + (walker:walk-form form env #'walk-function) + (nreverse result)))) + +(defmacro define-declaration-test (name declaration test &key values) + `(deftest ,name + (test-walk '(defun dummy () ,declaration (test)) + (lambda (env) ,test)) + ,@values)) + +(define-declaration-test slot-declaration.0 + (declare (pcl:slots (slot-boundp xx))) + (pcl::slot-declaration env 'slot-boundp 'xx) + :values ((t))) + +(define-declaration-test slot-declaration.1 + (declare (pcl:slots (inline xx))) + (pcl::slot-declaration env 'inline 'xx) + :values ((t))) + +(define-declaration-test slot-declaration.2 + (declare (pcl:slots (inline (xx)))) + (pcl::slot-declaration env 'inline 'xx) + :values ((t))) + +(define-declaration-test slot-declaration.3 + (declare (pcl:slots (inline (xx a)))) + (pcl::slot-declaration env 'inline 'xx 'a) + :values ((t))) + +(define-declaration-test slot-declaration.4 + (declare (pcl:slots (inline (xx a)))) + (pcl::slot-declaration env 'inline 'xx 'b) + :values ((nil))) + +(define-declaration-test slot-declaration.5 + (declare (pcl:slots (inline (xx a) yy))) + (pcl::slot-declaration env 'inline 'yy) + :values ((t))) + +(define-declaration-test slot-declaration.6 + (declare (pcl:slots (inline (xx a) (yy a)))) + (pcl::slot-declaration env 'inline 'yy 'a) + :values ((t))) + +(define-declaration-test slot-declaration.7 + (declare (pcl:slots (inline (xx a) (yy a)))) + (pcl::slot-declaration env 'inline 'yy 'b) + :values ((nil))) + +(deftest global-slot-declaration.0 + (progn + (proclaim '(pcl:slots (slot-boundp gsd))) + (not (null (pcl::slot-declaration nil 'slot-boundp 'gsd)))) + t) + +(deftest global-slot-declaration.1 + (progn + (proclaim '(pcl:slots (inline (gsd gsd-a)))) + (not (null (pcl::slot-declaration nil 'inline 'gsd 'gsd-a)))) + t) + +(deftest auto-compile-declaration.0 + (progn + (proclaim '(pcl:auto-compile acd)) + (pcl::auto-compile-p 'acd nil nil)) + t) + +(deftest auto-compile-declaration.1 + (progn + (proclaim '(pcl:auto-compile acd)) + (pcl::auto-compile-p 'acd '(:around) '(t t))) + t) + +(deftest auto-compile-declaration.2 + (progn + (proclaim '(pcl:not-auto-compile acd)) + (proclaim '(pcl:auto-compile (acd :around (t t)))) + (values (pcl::auto-compile-p 'acd nil nil) + (pcl::auto-compile-p 'acd nil '(t t)) + (pcl::auto-compile-p 'acd '(:around) '(t t)))) + nil nil t) + +(deftest auto-compile-declaration.3 + (progn + (proclaim '(pcl:auto-compile acd)) + (proclaim '(pcl:not-auto-compile (acd :around (t t)))) + (values (pcl::auto-compile-p 'acd nil nil) + (pcl::auto-compile-p 'acd nil '(t t)) + (pcl::auto-compile-p 'acd '(:around) '(t t)))) + t t nil) + +(deftest auto-compile-declaration.4 + (progn + (proclaim '(pcl:auto-compile)) + (proclaim '(pcl:not-auto-compile acd)) + (values (pcl::auto-compile-p 'foo nil nil) + (pcl::auto-compile-p 'acd nil '(t t)) + (pcl::auto-compile-p 'acd '(:around) '(t t)))) + t nil nil) + +(deftest auto-compile-declaration.5 + (progn + (proclaim '(pcl:auto-compile (setf acd))) + (pcl::auto-compile-p '(setf acd) '(:around) '(t t))) + t) + + +(declaim (pcl:slots (inline sacc.0))) + +(defclass sacc.0 () + ((a :initform 0 :initarg :a :accessor sacc.0-a))) + +(defclass sacc.1 (sacc.0) + ((b :initform 0 :initarg :b :accessor sacc.1-b) + (a :initform 0 :initarg :a :accessor sacc.0-a))) + +(defmethod sacc.0.0 ((x sacc.0)) + (slot-value x 'a)) + +(defmethod sacc.0.1 ((x sacc.0)) + (sacc.0-a x)) + +(defmethod sacc.0.2 ((x sacc.0) nv) + (setf (slot-value x 'a) nv)) + +(defmethod sacc.0.3 ((x sacc.0) nv) + (setf (sacc.0-a x) nv)) + +(defun method-using-inline-access-p (class-name method-name qualifiers + specializers) + (let ((method (find-method (fdefinition method-name) qualifiers + specializers))) + (car (member class-name (pcl::plist-value method 'pcl::inline-access) + :test #'eq)))) + +(deftest inline-access-p.0 + (and (method-using-inline-access-p 'sacc.0 'sacc.0.0 nil '(sacc.0)) + (method-using-inline-access-p 'sacc.0 'sacc.0.1 nil '(sacc.0)) + (method-using-inline-access-p 'sacc.0 'sacc.0.2 nil '(sacc.0 t)) + (method-using-inline-access-p 'sacc.0 'sacc.0.3 nil '(sacc.0 t))) + sacc.0) + +(deftest inline-access-p.1 + (let ((methods (pcl::methods-using-inline-slot-access + (pcl::find-class 'sacc.0)))) + (length methods)) + 4) + +(deftest inline-access.0 + (sacc.0.0 (make-instance 'sacc.0)) + 0) + +(deftest inline-access.1 + (let ((instance (make-instance 'sacc.0 :a 11))) + (values (sacc.0.0 instance) + (sacc.0.1 instance))) + 11 11) + +(deftest inline-access.2 + (let ((instance (make-instance 'sacc.0 :a 11))) + (sacc.0.2 instance 10) + (slot-value instance 'a)) + 10) + +(deftest inline-access.3 + (let ((instance (make-instance 'sacc.0 :a 11))) + (sacc.0.3 instance 10) + (slot-value instance 'a)) + 10) + +(defmacro define-warning-test (name (value) &body body) + `(deftest ,name + (let (warning) + (flet ((note-warning (c) + (declare (ignore c)) + (setq warning t) + (muffle-warning))) + (handler-bind ((warning #'note-warning)) + ,@body) + warning)) + ,value)) + +(define-warning-test warn.0 (t) (warn "Test the test")) +(define-warning-test warn.1 (nil) nil) + +(define-warning-test inline-warn.0 (nil) + (defclass sacc.0 () + ((a :initform 0 :initarg :a :accessor sacc.0-a)))) + +(define-warning-test inline-warn.1 (t) + (defclass sacc.0 () + ((a :initform 0 :initarg :a :accessor sacc.0-a) + (b :initform 0)))) + +(define-warning-test inline-warn.2 (t) + (progn + (defmethod inline-warn.2.method ((x sacc.1)) + (declare (pcl::slots (inline sacc.1))) + (slot-value x 'b)) + (defclass sacc.0 () + ((a :initform 0 :initarg :a :accessor sacc.0-a))))) + diff --git a/pcl/rt/make-instance.lisp b/pcl/rt/make-instance.lisp new file mode 100644 index 000000000..e727efab4 --- /dev/null +++ b/pcl/rt/make-instance.lisp @@ -0,0 +1,391 @@ +;;; Copyright (C) 2002 Gerd Moellmann <gerd.moellmann@t-online.de> +;;; All rights reserved. +;;; +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: +;;; +;;; 1. Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. +;;; 2. Redistributions in binary form must reproduce the above copyright +;;; notice, this list of conditions and the following disclaimer in the +;;; documentation and/or other materials provided with the distribution. +;;; 3. The name of the author may not be used to endorse or promote +;;; products derived from this software without specific prior written +;;; permission. +;;; +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE +;;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +;;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT +;;; OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR +;;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE +;;; USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH +;;; DAMAGE. + +#+cmu +(ext:file-comment "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/rt/make-instance.lisp,v 1.2 2003/03/22 16:15:14 gerd Exp $") + +(in-package "PCL-TEST") + + +;;; ********************* +;;; MAKE-INSTANCE ****** +;;; ********************* + +;;; Test forms in DEFTEST are not compiled, that is, a compiler +;;; macro won't be used in them. Also, we want tests using +;;; both the optimized constructor functions, and the default. + +(defmacro define-mi-test (name form &key values opt-values) + (let ((optimized-name + (let ((*print-case* :upcase) + (*print-pretty* nil) + (*print-gensym* t)) + (intern (format nil "~S.OPT" name)))) + (optimized-values (or opt-values values))) + `(progn + (defun ,name () + (macrolet ((mi (&rest args) + `(funcall #'make-instance ,@args))) + ,form)) + (defun ,optimized-name () + (macrolet ((mi (&rest args) + `(make-instance ,@args))) + ,form)) + (deftest ,name (,name) ,@values) + (deftest ,optimized-name (,optimized-name) + ,@optimized-values)))) + + +(defclass m1 () + ((a :initarg :a :initarg :both :initform 1) + (b :initarg :b :initarg :both :initform 2))) + +(define-mi-test make-instance.0 + (with-slots (a b) (mi 'm1) + (values a b)) + :values (1 2)) + +(define-mi-test make-instance.1 + (with-slots (a b) (mi 'm1 :a 3) + (values a b)) + :values (3 2)) + +(define-mi-test make-instance.2 + (with-slots (a b) (mi 'm1 :b 3) + (values a b)) + :values (1 3)) + +(define-mi-test make-instance.3 + (with-slots (a b) (mi 'm1 :b 3 :a 4) + (values a b)) + :values (4 3)) + +(define-mi-test make-instance.4 + (with-slots (a b) (mi 'm1 :both (list nil)) + (eq a b)) + :values (t)) + +(defclass m2 (m1) + ((a :initarg :a :initform 3))) + +;;; Overriding slot in subclass -> new initform should be used. + +(define-mi-test make-instance.5 + (with-slots (a b) (mi 'm2) + (values a b)) + :values (3 2)) + +;;; :BOTH should be inherited by slot A. + +(define-mi-test make-instance.6 + (with-slots (a b) (mi 'm2 :both 11) + (values a b)) + :values (11 11)) + +(defclass m3 (m2) + ((a :allocation :class :initform nil))) + +;;; Class slot should not be overwritten when there's no initarg for it. +;;; Note that slot A overrides an instance slot A in M2 which itself +;;; overrides an instance slot in M1. + +(define-mi-test make-instance.7 + (progn + (setf (slot-value (pcl:class-prototype (pcl:find-class 'm3)) 'a) 1) + (with-slots (a b) (mi 'm3) + (values a b))) + :values (1 2)) + +;;; Class slot should be written when there is an initarg for it. + +(define-mi-test make-instance.8 + (with-slots (a) (mi 'm3 :a 11) + a) + :values (11)) + +;;; Class slot should be written when there is an initarg for it. + +(define-mi-test make-instance.9 + (with-slots (a b) (mi 'm3 :both 12) + (values a b)) + :values (12 12)) + +(define-mi-test make-instance.10 + (with-slots (a b) (mi 'm3 :both 13) + (values a b)) + :values (13 13)) + +;;; Invalid initialization arguments + +(define-mi-test make-instance.11 + (multiple-value-bind (r c) + (ignore-errors (mi 'm3 :hansi t)) + (values r (typep c 'condition))) + :values (nil t)) + +(define-mi-test make-instance.12 + (multiple-value-bind (r c) + (ignore-errors (mi 'm3 :hansi t :allow-other-keys t)) + (values (slot-value r 'b) (typep c 'condition))) + :values (2 nil)) + +;;; Default initargs + +(defclass m5 (m1) + () + (:default-initargs :a 'a :b 'b)) + +(define-mi-test make-instance.13 + (with-slots (a b) (mi 'm5) + (values a b)) + :values (a b)) + +(defclass m6 (m5) + () + (:default-initargs :a 'c)) + +(define-mi-test make-instance.14 + (with-slots (a b) (mi 'm6) + (values a b)) + :values (c b)) + +(defclass m7 (m6) + ((a :allocation :class :initform nil))) + +(define-mi-test make-instance.15 + (with-slots (a b) (mi 'm7) + (values a b)) + :values (c b)) + +;;; Lexical environment. + +(let ((x 0)) + (defclass m8 () + ((a :initform (incf x)))) + (defun reset-counter () + (setq x 0))) + +(define-mi-test make-instance.16 + (progn + (reset-counter) + (loop for i below 5 + collect (slot-value (mi 'm8) 'a))) + :values ((1 2 3 4 5))) + +(defclass m9 () + ((a :initarg :a) + (b :initarg :b) + (c :initarg :c) + (d :initarg :d))) + +(define-mi-test make-instance.17 + (let* ((x 'x) + (instance (mi 'm9 :a () :b x :c '(baz bar foo) + :d (lambda () ())))) + (with-slots (a b c) instance + (values a b c))) + :values (nil x (baz bar foo))) + +;; After and before methods. + +(defclass m10 () + ((a :initform 0 :initarg :a) + (b :initarg :b) + (c :initform 2 :initarg :c)) + (:default-initargs :c 1)) + +(defvar *result* ()) + +(defmethod initialize-instance :before ((x m10) &rest args) + (declare (ignore args)) + (push (list 'm10 :before (slot-boundp x 'a) + (slot-boundp x 'b) (slot-boundp x 'c)) + *result*)) + +(define-mi-test make-instance.18 + (progn + (setq *result* ()) + (with-slots (a b c) (mi 'm10 :b 42) + (values *result* a b c))) + :values (((m10 :before nil nil nil)) 0 42 1)) + +(defclass m11 (m10) + () + (:default-initargs :c 11)) + +(defmethod initialize-instance :before ((x m11) &rest args) + (declare (ignore args)) + (push (list 'm11 :before (slot-boundp x 'a) + (slot-boundp x 'b) + (slot-boundp x 'c)) + *result*)) + +(defmethod initialize-instance :after ((x m11) &rest args) + (declare (ignore args)) + (push (list 'm11 :after (slot-boundp x 'a) + (slot-boundp x 'b) + (slot-boundp x 'c)) + *result*)) + +(define-mi-test make-instance.19 + (progn + (setq *result* ()) + (with-slots (a b c) (mi 'm11 :b 42) + (values *result* a b c))) + :values (((m11 :after t t t) + (m10 :before nil nil nil) + (m11 :before nil nil nil)) + 0 42 11)) + +(defclass m12 (m10) + () + (:default-initargs :c 13)) + +(defmethod initialize-instance :before ((x m12) &rest args) + (declare (ignore args)) + (setf (slot-value x 'a) 77)) + +(define-mi-test make-instance.20 + (progn + (setq *result* ()) + (with-slots (a b c) (mi 'm12 :b 42) + (values *result* a b c))) + :values (((m10 :before t nil nil)) + 77 42 13)) + +(define-mi-test make-instance.21 + (progn + (setq *result* ()) + (with-slots (a b c) (mi 'm12 :b 41 :c 67) + (values *result* a b c))) + :values (((m10 :before t nil nil)) + 77 41 67)) + +;;; :ALLOW-OTHER-KEYS + +(define-mi-test make-instance.22 + (let ((obj (ignore-errors (mi 'm12 :b 41 :allow-other-keys t)))) + (when obj + (with-slots (a b c) obj + (values a b c)))) + :values (77 41 13)) + + +(define-mi-test make-instance.23 + (let ((obj (ignore-errors (mi 'm12 :b 41 :x 11 :allow-other-keys t)))) + (when obj + (with-slots (a b c) obj + (values a b c)))) + :values (77 41 13)) + +(define-mi-test make-instance.24 + (multiple-value-bind (r c) + (ignore-errors (mi 'm12 :b 41 :x 11)) + (values r (typep c 'condition))) + :values (nil t)) + +(define-mi-test make-instance.25 + (multiple-value-bind (r c) + (ignore-errors (mi 'm12 :b 41 :x 11 :allow-other-keys nil)) + (values r (typep c 'condition))) + :values (nil t)) + +;; Create a constructor, than rename the package of the class it was +;; defined for. + +(defpackage "%CTOR" + (:use "COMMON-LISP")) + +(in-package "%CTOR") + +(defclass p1 () + ((a :initform 0))) + +(defun f1 () + (make-instance 'p1)) + +(in-package "PCL-TEST") + +(define-mi-test make-instance.26 + (progn + (rename-package "%CTOR" "%CTOR2") + (let* ((f (find-symbol "F1" "%CTOR2")) + (a (find-symbol "A" "%CTOR2")) + (i (funcall f))) + (prog1 + (slot-value i a) + (rename-package "%CTOR2" "%CTOR")))) + :values (0)) + +(defclass stru.0 () + ((a :initarg :a :accessor a-accessor) + (b :initform 2 :reader b-reader)) + (:metaclass structure-class)) + +(defclass stru.1 (stru.0) + ((c :initarg :c :writer c-writer :accessor c-accessor)) + (:metaclass structure-class)) + +(define-mi-test make-instance.27 + (with-slots (a b) (mi 'stru.0) + (values a b)) + :values (nil 2)) + +(define-mi-test make-instance.28 + (with-slots (a b) (mi 'stru.0 :a 1) + (values a b)) + :values (1 2)) + +(define-mi-test make-instance.29 + (with-slots (a b c) (mi 'stru.1) + (values a b c)) + :values (nil 2 nil)) + +(define-mi-test make-instance.30 + (with-slots (a b c) (mi 'stru.1 :a 1 :c 3) + (values a b c)) + :values (1 2 3)) + +(deftest make-instance.31 + (let ((*m30* nil)) + (declare (special *m30*)) + (defclass m30 () ()) + (defclass m31 (m30) ()) + (defun f () (make-instance 'm31)) + (compile 'f) + (f) + (defmethod initialize-instance :before ((x m30) &rest args) + (declare (ignore args)) + (declare (special *m30*)) + (setq *m30* t)) + (f) + *m30*) + t) + +;; (setf find-class), class redefinitions diff --git a/pcl/rt/method-combination.lisp b/pcl/rt/method-combination.lisp new file mode 100644 index 000000000..bc5bc4c52 --- /dev/null +++ b/pcl/rt/method-combination.lisp @@ -0,0 +1,217 @@ +;;; Copyright (C) 2002 Gerd Moellmann <gerd.moellmann@t-online.de> +;;; All rights reserved. +;;; +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: +;;; +;;; 1. Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. +;;; 2. Redistributions in binary form must reproduce the above copyright +;;; notice, this list of conditions and the following disclaimer in the +;;; documentation and/or other materials provided with the distribution. +;;; 3. The name of the author may not be used to endorse or promote +;;; products derived from this software without specific prior written +;;; permission. +;;; +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE +;;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +;;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT +;;; OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR +;;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE +;;; USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH +;;; DAMAGE. + +#+cmu +(ext:file-comment "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/rt/method-combination.lisp,v 1.2 2003/03/22 16:15:14 gerd Rel $") + +(in-package "PCL-TEST") + +;;; ******************************** +;;; Method Group Specifiers ******** +;;; ******************************** + +(define-method-combination mgs0 (x) + ((primary () :required t)) + (progn + x + `(call-method ,(first primary)))) + +;;; This should simply not signal an error as it did in 18d. + +(deftest method-group-specifiers.0 + (multiple-value-bind (r c) + (ignore-errors + (defgeneric mgs0 (obj) + (:method-combination mgs0 1)) + (defmethod mgs0 (obj) + obj) + (mgs0 1)) + (values r c)) + 1 nil) + + +;;; ************************** +;;; :generic-function ******* +;;; ************************** + + +;;; ******************* +;;; :arguments ******* +;;; ******************* + +(defvar *result* nil) + +(defvar *mca0-value* + (define-method-combination mca0 () + ((methods *)) + (:arguments x y &optional opt) + (:generic-function gf) + `(progn + (setq *result* (list (pcl:generic-function-name ,gf) ,x ,y ,opt)) + (call-method ,(first methods))))) + +(defgeneric mca0 (a) + (:method-combination mca0) + (:method (a) a)) + +(defgeneric mca1 (a b) + (:method-combination mca0) + (:method (a b) (list a b))) + +(defgeneric mca2 (a &optional b) + (:method-combination mca0) + (:method (a &optional b) (list a b))) + +(defgeneric mca3 (&optional b) + (:method-combination mca0) + (:method (&optional b) b)) + +(deftest method-combination.0 + *mca0-value* + mca0) + +(deftest method-combination-arguments.0 + (multiple-value-bind (r c) + (ignore-errors (mca0 1) *result*) + (values r (null c))) + (mca0 1 nil nil) t) + +(deftest method-combination-arguments.1 + (multiple-value-bind (r c) + (ignore-errors (mca1 1 2) *result*) + (values r (null c))) + (mca1 1 2 nil) t) + +(deftest method-combination-arguments.2 + (multiple-value-bind (r c) + (ignore-errors (mca2 1) *result*) + (values r (null c))) + (mca2 1 nil nil) t) + +(deftest method-combination-arguments.3 + (multiple-value-bind (r c) + (ignore-errors (mca2 1 2) *result*) + (values r (null c))) + (mca2 1 nil 2) t) + +(deftest method-combination-arguments.4 + (multiple-value-bind (r c) + (ignore-errors (mca3) *result*) + (values r (null c))) + (mca3 nil nil nil) t) + +(deftest method-combination-arguments.5 + (multiple-value-bind (r c) + (ignore-errors (mca3 1) *result*) + (values r (null c))) + (mca3 nil nil 1) t) + +(define-method-combination mca1 () + ((methods *)) + (:arguments x y &rest r) + (:generic-function gf) + `(progn + (setq *result* (list (pcl:generic-function-name ,gf) ,x ,y ,r)) + (call-method ,(first methods)))) + +(defgeneric mca1.0 (&rest b) + (:method-combination mca1) + (:method (&rest b) b)) + +(deftest method-combination-arguments.6 + (multiple-value-bind (r c) + (ignore-errors (mca1.0) *result*) + (values r (null c))) + (mca1.0 nil nil nil) t) + +(deftest method-combination-arguments.7 + (multiple-value-bind (r c) + (ignore-errors (mca1.0 1) *result*) + (values r (null c))) + (mca1.0 nil nil (1)) t) + +(define-method-combination mca2 () + ((methods *)) + (:arguments &key a b) + (:generic-function gf) + `(progn + (setq *result* (list (pcl:generic-function-name ,gf) ,a ,b)) + (call-method ,(first methods)))) + +(defgeneric mca2.0 (&key a b) + (:method-combination mca2) + (:method (&key (a 0) (b 1)) (list a b))) + +(deftest method-combination-arguments.8 + (multiple-value-bind (r c) + (ignore-errors (mca2.0) *result*) + (values r (null c))) + (mca2.0 nil nil) t) + +(deftest method-combination-arguments.9 + (multiple-value-bind (r c) + (ignore-errors (mca2.0 :a 1) *result*) + (values r (null c))) + (mca2.0 1 nil) t) + +(deftest method-combination-arguments.10 + (multiple-value-bind (r c) + (ignore-errors (mca2.0 :b 1) *result*) + (values r (null c))) + (mca2.0 nil 1) t) + +(deftest method-combination-arguments.11 + (multiple-value-bind (r c) + (ignore-errors (mca2.0 :b 1 :a 0) *result*) + (values r (null c))) + (mca2.0 0 1) t) + +(define-method-combination mca3 () + ((methods *)) + (:arguments &whole w x &key k) + (:generic-function gf) + `(progn + (setq *result* (list (pcl:generic-function-name ,gf) ,w ,x ,k)) + (call-method ,(first methods)))) + +(defgeneric mca3.0 (x &key k) + (:method-combination mca3) + (:method (x &key k) (list x k))) + +(deftest method-combination-arguments.12 + (multiple-value-bind (r c) + (ignore-errors (mca3.0 1) *result*) + (values r (null c))) + (mca3.0 (1) 1 nil) t) + +(deftest method-combination-arguments.13 + (multiple-value-bind (r c) + (ignore-errors (mca3.0 1 :k 2) *result*) + (values r (null c))) + (mca3.0 (1 :k 2) 1 2) t) diff --git a/pcl/rt/methods.lisp b/pcl/rt/methods.lisp new file mode 100644 index 000000000..99b58ccb7 --- /dev/null +++ b/pcl/rt/methods.lisp @@ -0,0 +1,48 @@ +;;; Copyright (C) 2002 Gerd Moellmann <gerd.moellmann@t-online.de> +;;; All rights reserved. +;;; +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: +;;; +;;; 1. Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. +;;; 2. Redistributions in binary form must reproduce the above copyright +;;; notice, this list of conditions and the following disclaimer in the +;;; documentation and/or other materials provided with the distribution. +;;; 3. The name of the author may not be used to endorse or promote +;;; products derived from this software without specific prior written +;;; permission. +;;; +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE +;;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +;;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT +;;; OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR +;;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE +;;; USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH +;;; DAMAGE. + +(ext:file-comment "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/rt/methods.lisp,v 1.2 2003/03/22 16:15:14 gerd Rel $") + +(in-package "PCL-TEST") + +;;; Old PCL has a bug wrt rebinding a parameter around +;;; CALL-NEXT-METHOD. + +(deftest methods.0 + (progn + (defclass mt0 () + ()) + (defmethod mt0 ((m mt0) x) + x) + (defmethod mt0 :around ((m mt0) x) + (let ((x (1+ x))) + #+cmu (declare (optimize (ext:inhibit-warnings 3))) + (call-next-method))) + (mt0 (make-instance 'mt0) 42)) + 42) diff --git a/pcl/rt/pkg.lisp b/pcl/rt/pkg.lisp new file mode 100644 index 000000000..516544a94 --- /dev/null +++ b/pcl/rt/pkg.lisp @@ -0,0 +1,53 @@ +;;; Copyright (C) 2002 Gerd Moellmann <gerd.moellmann@t-online.de> +;;; All rights reserved. +;;; +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: +;;; +;;; 1. Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. +;;; 2. Redistributions in binary form must reproduce the above copyright +;;; notice, this list of conditions and the following disclaimer in the +;;; documentation and/or other materials provided with the distribution. +;;; 3. The name of the author may not be used to endorse or promote +;;; products derived from this software without specific prior written +;;; permission. +;;; +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE +;;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +;;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT +;;; OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR +;;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE +;;; USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH +;;; DAMAGE. + +#+cmu +(ext:file-comment "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/rt/pkg.lisp,v 1.2 2003/03/22 16:15:14 gerd Exp $") + +(defpackage "PCL-TEST" + (:use "COMMON-LISP" #+cmu "PCL" #+sbcl "SB-PCL" "RT") + (:shadowing-import-from + #+cmu "PCL" #+sbcl "SB-PCL" + "FIND-CLASS" "CLASS-OF" "CLASS-NAME" "BUILT-IN-CLASS")) + +#+sbcl +(progn + (defpackage "PCL") + (loop for symbol being the symbols of "SB-PCL" + collect symbol into symbols + finally + (import symbols "PCL") + (export symbols "PCL"))) + +(in-package "PCL-TEST") + +(defmacro define-compiled-test (name form &rest values) + `(progn + (defun ,name () ,form) + (deftest ,name (,name) ,@values))) diff --git a/pcl/rt/pv.lisp b/pcl/rt/pv.lisp new file mode 100644 index 000000000..84c5830d9 --- /dev/null +++ b/pcl/rt/pv.lisp @@ -0,0 +1,136 @@ +;;; Copyright (C) 2002 Gerd Moellmann <gerd.moellmann@t-online.de> +;;; All rights reserved. +;;; +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: +;;; +;;; 1. Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. +;;; 2. Redistributions in binary form must reproduce the above copyright +;;; notice, this list of conditions and the following disclaimer in the +;;; documentation and/or other materials provided with the distribution. +;;; 3. The name of the author may not be used to endorse or promote +;;; products derived from this software without specific prior written +;;; permission. +;;; +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE +;;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +;;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT +;;; OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR +;;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE +;;; USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH +;;; DAMAGE. + +#+cmu +(ext:file-comment "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/rt/pv.lisp,v 1.2 2003/03/22 16:15:14 gerd Rel $") + +(in-package "PCL-TEST") + +;;;************************** +;;; With Optimization ****** +;;; ************************* + +#+gerds-pcl +(eval-when (:compile-toplevel :load-toplevel :execute) + (setq pcl::*optimize-gf-calls-p* t)) + +(defclass pv0 () + ((a :accessor pv0-a :initform 0))) + +(defmethod pv0.0 ((x pv0)) + 1) + +(defmethod pv0.1 ((x pv0) &rest r) + (car r)) + +(defmethod pv0.2 ((x pv0) &key k) + k) + +(defmethod pv0.3 ((x pv0) &optional o) + o) + +(defmethod pv0.4 ((x pv0) (y pv0)) + 1) + +(defmethod call-pv0 ((x pv0)) + (list (pv0.0 x) + (pv0.1 x 2) + (pv0.2 x :k 3) (pv0.2 x) + (pv0.3 x 1) (pv0.3 x) + (pv0.4 x x))) + +(deftest pv-gf-call-optimized.0 + (ignore-errors (call-pv0 (make-instance 'pv0))) + (1 2 3 nil 1 nil 1)) + +(defclass pv0.1 (pv0) ()) + +(defmethod pv0.0 ((x pv0.1)) + (call-next-method)) + +(defmethod pv0.1 ((x pv0.1) &rest r) + (declare (ignorable r)) + (call-next-method)) + +(defmethod pv0.2 ((x pv0.1) &key k) + (declare (ignorable k)) + (call-next-method)) + +(defmethod pv0.3 ((x pv0.1) &optional o) + (declare (ignorable o)) + (call-next-method)) + +(defmethod pv0.4 ((x pv0.1) (y pv0.1)) + (call-next-method)) + +(defmethod call-pv0 ((x pv0.1)) + (call-next-method)) + +(deftest pv-gf-call-optimized.1 + (ignore-errors (call-pv0 (make-instance 'pv0.1))) + (1 2 3 nil 1 nil 1)) + +(deftest pv-gf-call-optimized.2 + (ignore-errors (call-pv0 (make-instance 'pv0))) + (1 2 3 nil 1 nil 1)) + + +;;;***************************** +;;; Without Optimization ****** +;;; **************************** + +#+gerds-pcl +(eval-when (:compile-toplevel :load-toplevel :execute) + (setq pcl::*optimize-gf-calls-p* nil)) + +(defclass pv1 () + ((a :accessor pv1-a :initform 0))) + +(defmethod pv1.0 ((x pv1)) + 1) + +(defmethod pv1.1 ((x pv1) &rest r) + (car r)) + +(defmethod pv1.2 ((x pv1) &key k) + k) + +(defmethod pv1.3 ((x pv1) &optional o) + o) + +(defmethod call-pv1 ((x pv1)) + (list (pv1.0 x) + (pv1.1 x 2) + (pv1.2 x :k 3) (pv1.2 x) + (pv1.3 x 1) (pv1.3 x))) + +(deftest pv-gf-call.1 + (call-pv1 (make-instance 'pv1)) + (1 2 3 nil 1 nil)) + diff --git a/pcl/rt/reinitialize-instance.lisp b/pcl/rt/reinitialize-instance.lisp new file mode 100644 index 000000000..d432b8e98 --- /dev/null +++ b/pcl/rt/reinitialize-instance.lisp @@ -0,0 +1,89 @@ +;;; Copyright (C) 2002 Gerd Moellmann <gerd.moellmann@t-online.de> +;;; All rights reserved. +;;; +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: +;;; +;;; 1. Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. +;;; 2. Redistributions in binary form must reproduce the above copyright +;;; notice, this list of conditions and the following disclaimer in the +;;; documentation and/or other materials provided with the distribution. +;;; 3. The name of the author may not be used to endorse or promote +;;; products derived from this software without specific prior written +;;; permission. +;;; +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE +;;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +;;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT +;;; OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR +;;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE +;;; USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH +;;; DAMAGE. + +(ext:file-comment "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/rt/reinitialize-instance.lisp,v 1.2 2003/03/22 16:15:14 gerd Rel $") + +(in-package "PCL-TEST") + +(deftest reinitialize-instance.0 + (multiple-value-bind (r c) + (ignore-errors + (defclass ri0 () ((a :initarg :a))) + (reinitialize-instance (make-instance 'ri0) :a 1)) + (values (null r) (typep c 'error))) + nil nil) + +(deftest reinitialize-instance.1 + (multiple-value-bind (r c) + (ignore-errors + (defclass ri1 () ()) + (reinitialize-instance (make-instance 'ri1) :a 1)) + (values (null r) (typep c 'error))) + t t) + +(deftest reinitialize-instance.2 + (multiple-value-bind (r c) + (ignore-errors + (defclass ri2 () ()) + (defmethod shared-initialize ((x ri2) slots &rest initargs &key a) + (declare (ignore slots initargs a))) + (reinitialize-instance (make-instance 'ri2) :a 1)) + (values (null r) (typep c 'error))) + nil nil) + +(deftest reinitialize-instance.3 + (multiple-value-bind (r c) + (ignore-errors + (defclass ri3 () ()) + (defmethod reinitialize-instance :after ((x ri3) &rest initargs + &key a) + (declare (ignore initargs a))) + (reinitialize-instance (make-instance 'ri3) :a 1)) + (values (null r) (typep c 'error))) + nil nil) + +(deftest reinitialize-instance.4 + (multiple-value-bind (r c) + (ignore-errors + (defclass ri4 () ()) + (defmethod reinitialize-instance :after ((x ri4) &rest initargs + &key a &allow-other-keys) + (declare (ignore initargs a))) + (reinitialize-instance (make-instance 'ri4) :a 1 :b 2)) + (values (null r) (typep c 'error))) + nil nil) + +(deftest reinitialize-instance.5 + (multiple-value-bind (r c) + (ignore-errors + (defclass ri5 () ()) + (reinitialize-instance (make-instance 'ri4) + :a 1 :b 2 :allow-other-keys t)) + (values (null r) (typep c 'error))) + nil nil) diff --git a/pcl/rt/slot-accessors.lisp b/pcl/rt/slot-accessors.lisp new file mode 100644 index 000000000..0e78d680a --- /dev/null +++ b/pcl/rt/slot-accessors.lisp @@ -0,0 +1,131 @@ +;;; Copyright (C) 2002 Gerd Moellmann <gerd.moellmann@t-online.de> +;;; All rights reserved. +;;; +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: +;;; +;;; 1. Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. +;;; 2. Redistributions in binary form must reproduce the above copyright +;;; notice, this list of conditions and the following disclaimer in the +;;; documentation and/or other materials provided with the distribution. +;;; 3. The name of the author may not be used to endorse or promote +;;; products derived from this software without specific prior written +;;; permission. +;;; +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE +;;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +;;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT +;;; OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR +;;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE +;;; USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH +;;; DAMAGE. + +;;; What if accessors with the same name are declared for different +;;; direct slots? Should there be a warning? ACL gives none. LW +;;; gives an error. + +#+cmu +(ext:file-comment "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/rt/slot-accessors.lisp,v 1.2 2003/03/22 16:15:14 gerd Rel $") + +(in-package "PCL-TEST") + +(defclass sa0 () + ((a :accessor a-of :initarg :a))) + +(deftest slot-accessor.0 + (let ((instance (make-instance 'sa0 :a 0))) + (a-of instance)) + 0) + +(deftest slot-accessor.1 + (let ((instance (make-instance 'sa0))) + (setf (a-of instance) 1) + (a-of instance)) + 1) + +(defmethod sa0.0 ((x sa0)) + (a-of x)) + +(deftest slot-accessor.2 + (let ((instance (make-instance 'sa0))) + (setf (a-of instance) 2) + (sa0.0 instance)) + 2) + +;;; Redefining the class should update the PV table cache of +;;; method SA0.0 so that is reads the right slot. + +(deftest slot-accessor.3 + (progn + (defclass sa0 () + ((c :accessor c-of) + (a :accessor a-of :initarg :a) + (b :accessor b-of))) + (sa0.0 (make-instance 'sa0 :a 42))) + 42) + +(defclass sa1 (sa0) + ((b :accessor a-of :initarg :b))) + +(deftest slot-accessor.4 + (let ((instance (make-instance 'sa1 :b 0))) + (sa0.0 instance)) + 0) + +(defclass sa2 (sa0) + ()) + +(defmethod (setf a-of) (new-value (obj sa2)) + (setf (slot-value obj 'a) (* 2 new-value))) + +(defmethod sa2.0 ((obj sa2)) + (setf (a-of obj) 42)) + +(deftest slot-accessor.5 + (let ((instance (make-instance 'sa2))) + (sa2.0 instance)) + 84) + +(defclass sa3 () + ()) + +(defmethod (setf foo-of) (n (obj sa3)) + n) + +(defmethod sa3.0 ((obj sa3)) + (setf (foo-of obj) 11)) + +(deftest slot-accessor.6 + (let ((instance (make-instance 'sa3))) + (sa3.0 instance)) + 11) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defclass sa4 () + ((a :initform 0 :accessor sa4-a)))) + +(defmethod sa4.0 ((x sa4)) + (sa4-a x)) + +(deftest slot-accessor.7 + (sa4.0 (make-instance 'sa4)) + 0) + +(deftest slot-accessor.8 + (progn + (defun sa4-a (x) + (declare (ignore x)) + 11) + (prog1 + (sa4.0 (make-instance 'sa4)) + (fmakunbound 'sa4-a))) + 11) + + diff --git a/pcl/rt/slot-boundp.lisp b/pcl/rt/slot-boundp.lisp new file mode 100644 index 000000000..9b4b00554 --- /dev/null +++ b/pcl/rt/slot-boundp.lisp @@ -0,0 +1,75 @@ +;;; Copyright (C) 2002 Gerd Moellmann <gerd.moellmann@t-online.de> +;;; All rights reserved. +;;; +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: +;;; +;;; 1. Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. +;;; 2. Redistributions in binary form must reproduce the above copyright +;;; notice, this list of conditions and the following disclaimer in the +;;; documentation and/or other materials provided with the distribution. +;;; 3. The name of the author may not be used to endorse or promote +;;; products derived from this software without specific prior written +;;; permission. +;;; +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE +;;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +;;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT +;;; OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR +;;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE +;;; USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH +;;; DAMAGE. + +#+cmu +(ext:file-comment "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/rt/slot-boundp.lisp,v 1.2 2003/03/22 16:15:14 gerd Rel $") + +(in-package "PCL-TEST") + +(defclass sbp0 () + ((a :initarg :a :initform 0) + (b :initarg :b) + (c :allocation :class))) + +(defmethod sbp0.0 ((x sbp0) slot) + (null (slot-boundp x slot))) + +(deftest slot-boundp.0 + (null (slot-boundp (make-instance 'sbp0) 'a)) + nil) + +(define-compiled-test slot-boundp.1 + (null (slot-boundp (make-instance 'sbp0) 'a)) + nil) + +(deftest slot-boundp.2 + (null (slot-boundp (make-instance 'sbp0) 'b)) + t) + +(define-compiled-test slot-boundp.3 + (multiple-value-bind (r c) + (ignore-errors (slot-boundp (make-instance 'sbp0) 'b)) + (values (null r) c)) + t nil) + +(deftest slot-boundp.4 + (null (slot-boundp (make-instance 'sbp0) 'c)) + t) + +(define-compiled-test slot-boundp.5 + (null (slot-boundp (make-instance 'sbp0) 'c)) + t) + +(deftest slot-boundp.6 + (sbp0.0 (make-instance 'sbp0) 'b) + t) + +(deftest slot-boundp.7 + (sbp0.0 (make-instance 'sbp0 :a 2) 'a) + nil) diff --git a/pcl/rt/slot-missing.lisp b/pcl/rt/slot-missing.lisp new file mode 100644 index 000000000..dbfabe6b0 --- /dev/null +++ b/pcl/rt/slot-missing.lisp @@ -0,0 +1,100 @@ +;;; Copyright (C) 2002 Gerd Moellmann <gerd.moellmann@t-online.de> +;;; All rights reserved. +;;; +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: +;;; +;;; 1. Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. +;;; 2. Redistributions in binary form must reproduce the above copyright +;;; notice, this list of conditions and the following disclaimer in the +;;; documentation and/or other materials provided with the distribution. +;;; 3. The name of the author may not be used to endorse or promote +;;; products derived from this software without specific prior written +;;; permission. +;;; +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE +;;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +;;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT +;;; OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR +;;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE +;;; USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH +;;; DAMAGE. + +#+cmu +(ext:file-comment "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/rt/slot-missing.lisp,v 1.2 2003/03/22 16:15:14 gerd Exp $") + +(in-package "PCL-TEST") + +;;; in method (pv table optimization) +;;; in compiled defun +;;; uncompiled. + +(defmacro define-sm-test (name (instance class) access &rest values) + (let* ((*print-case* :upcase) + (*print-pretty* nil) + (*print-gensym* t) + (method-name (intern (format nil "~S.METHOD" name))) + (method-test (intern (format nil "~S.METHOD-TEST" name))) + (compiled-test (intern (format nil "~S.COMPILED" name)))) + `(progn + (defmethod ,method-name ((,instance ,class)) + ,access) + (deftest ,name + (multiple-value-bind (r c) + (let ((,instance (make-instance ',class))) + (ignore-errors ,access)) + (values r (typep c 'condition))) + ,@values) + (deftest ,method-test + (multiple-value-bind (r c) + (let ((,instance (make-instance ',class))) + (ignore-errors (,method-name ,instance))) + (values r (typep c 'condition))) + ,@values) + (define-compiled-test ,compiled-test + (multiple-value-bind (r c) + (let ((,instance (make-instance ',class))) + (ignore-errors ,access)) + (values r (typep c 'condition))) + ,@values)))) + +(defclass sm0 () ()) + +(define-sm-test slot-missing.0 (instance sm0) + (slot-value instance 'a) + nil t) + +(define-sm-test slot-missing.1 (instance sm0) + (setf (slot-value instance 'a) 1) + nil t) + +(define-sm-test slot-missing.2 (instance sm0) + (slot-boundp instance 'a) + nil t) + +(defclass sm1 () ()) + +(defvar *sm-result* nil) + +(defmethod slot-missing (class (obj sm1) slot-name operation + &optional new-value) + (setq *sm-result* (list slot-name operation new-value))) + +(define-sm-test slot-missing.3 (instance sm1) + (slot-value instance 'a) + (a slot-value nil) nil) + +(define-sm-test slot-missing.4 (instance sm1) + (setf (slot-value instance 'a) 1) + (a setf 1) nil) + +(define-sm-test slot-missing.5 (instance sm1) + (slot-boundp instance 'a) + (a slot-boundp nil) nil) diff --git a/pcl/rt/slot-type.lisp b/pcl/rt/slot-type.lisp new file mode 100644 index 000000000..369daae05 --- /dev/null +++ b/pcl/rt/slot-type.lisp @@ -0,0 +1,76 @@ +;;; Copyright (C) 2002 Gerd Moellmann <gerd.moellmann@t-online.de> +;;; All rights reserved. +;;; +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: +;;; +;;; 1. Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. +;;; 2. Redistributions in binary form must reproduce the above copyright +;;; notice, this list of conditions and the following disclaimer in the +;;; documentation and/or other materials provided with the distribution. +;;; 3. The name of the author may not be used to endorse or promote +;;; products derived from this software without specific prior written +;;; permission. +;;; +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE +;;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +;;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT +;;; OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR +;;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE +;;; USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH +;;; DAMAGE. + +(ext:file-comment "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/rt/slot-type.lisp,v 1.2 2003/03/22 16:15:14 gerd Exp $") + +(in-package "PCL-TEST") + +#+gerds-pcl +(eval-when (:compile-toplevel :load-toplevel :execute) + (setq pcl::*use-slot-types-p* t)) + +;;; Check that we check slot types, at least sometimes. + +(defclass stype () + ((a :type fixnum :initform 0 :initarg :a))) + +(defmethod stype.0 ((obj stype)) + (slot-value obj 'a)) + +(defmethod stype.1 ((obj stype) value) + (setf (slot-value obj 'a) value)) + +(deftest slot-type.0 + (multiple-value-bind (r c) + (ignore-errors + (stype.0 (make-instance 'stype :a 1))) + (values r (null c))) + 1 t) + +(deftest slot-type.1 + (multiple-value-bind (r c) + (ignore-errors + (stype.0 (make-instance 'stype :a 1.0))) + (values r (typep c 'error))) + nil t) + +(deftest slot-type.2 + (multiple-value-bind (r c) + (ignore-errors + (stype.1 (make-instance 'stype) 1)) + (values r (typep c 'error))) + 1 nil) + +(deftest slot-type.3 + (multiple-value-bind (r c) + (ignore-errors + (stype.1 (make-instance 'stype) 1.0)) + (values r (typep c 'error))) + nil t) + diff --git a/pcl/rt/slot-value.lisp b/pcl/rt/slot-value.lisp new file mode 100644 index 000000000..10c540946 --- /dev/null +++ b/pcl/rt/slot-value.lisp @@ -0,0 +1,60 @@ +;;; Copyright (C) 2002 Gerd Moellmann <gerd.moellmann@t-online.de> +;;; All rights reserved. +;;; +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: +;;; +;;; 1. Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. +;;; 2. Redistributions in binary form must reproduce the above copyright +;;; notice, this list of conditions and the following disclaimer in the +;;; documentation and/or other materials provided with the distribution. +;;; 3. The name of the author may not be used to endorse or promote +;;; products derived from this software without specific prior written +;;; permission. +;;; +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE +;;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +;;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT +;;; OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR +;;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE +;;; USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH +;;; DAMAGE. + +#+cmu +(ext:file-comment "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/rt/slot-value.lisp,v 1.2 2003/03/22 16:15:14 gerd Rel $") + +(in-package "PCL-TEST") + +(defclass sv0 () + ((a :allocation :class :initarg :a :initform 0))) + +(defun sv0.0 () + (let* ((x (random 10)) + (obj (make-instance 'sv0 :a x))) + (eql x (slot-value obj (identity 'a))))) + +;;; In previous versions of PCL (18d for example), the above +;;; slot-value fails when the class is redefined. + +(deftest slot-value.0 + (sv0.0) + t) + +(deftest slot-value.1 + (progn + (defclass sv0 () + ((a :allocation :class :initarg :a :initform 0))) + t) + t) + +(deftest slot-value.2 + (sv0.0) + t) + diff --git a/pcl/rt/system.lisp b/pcl/rt/system.lisp new file mode 100644 index 000000000..9e8017d5c --- /dev/null +++ b/pcl/rt/system.lisp @@ -0,0 +1,91 @@ +;;; Copyright (C) 2002 Gerd Moellmann <gerd.moellmann@t-online.de> +;;; All rights reserved. +;;; +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: +;;; +;;; 1. Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. +;;; 2. Redistributions in binary form must reproduce the above copyright +;;; notice, this list of conditions and the following disclaimer in the +;;; documentation and/or other materials provided with the distribution. +;;; 3. The name of the author may not be used to endorse or promote +;;; products derived from this software without specific prior written +;;; permission. +;;; +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE +;;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +;;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT +;;; OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR +;;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE +;;; USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH +;;; DAMAGE. + +#+cmu +(ext:file-comment "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/rt/system.lisp,v 1.2 2003/03/22 16:15:14 gerd Exp $") + +(setf (logical-pathname-translations "pcl-test") + `(("*.*.*" "/home/gerd/cmucl/src/pcl/rt/*.*.*"))) + +(mk:defsystem :pcl-test + :initially-do (progn ) + :source-pathname "pcl-test:" + :binary-pathname "pcl-test:" + :components + ((:file "pkg" + :source-extension "lisp") + #+gerds-pcl + (:file "ctor" + :source-extension "lisp" + :depends-on ("pkg")) + (:file "defclass" + :source-extension "lisp" + :depends-on ("pkg")) + (:file "make-instance" + :source-extension "lisp" + :depends-on ("pkg" #+gerds-pcl "ctor")) + (:file "reinitialize-instance" + :source-extension "lisp" + :depends-on ("pkg" "make-instance")) + (:file "slot-value" + :source-extension "lisp" + :depends-on ("pkg" "make-instance")) + (:file "slot-boundp" + :source-extension "lisp" + :depends-on ("pkg" "make-instance")) + (:file "slot-missing" + :source-extension "lisp" + :depends-on ("pkg" "make-instance")) + (:file "slot-accessors" + :source-extension "lisp" + :depends-on ("pkg" "make-instance")) + (:file "slot-type" + :source-extension "lisp" + :depends-on ("pkg" "slot-value")) + (:file "inline-access" + :source-extension "lisp" + :depends-on ("pkg" "slot-type")) + (:file "method-combination" + :source-extension "lisp" + :depends-on ("pkg")) + (:file "pv" + :source-extension "lisp" + :depends-on ("pkg")) + (:file "defgeneric" + :source-extension "lisp" + :depends-on ("pkg")) + (:file "defmethod" + :source-extension "lisp" + :depends-on ("pkg")) + (:file "find-method" + :source-extension "lisp" + :depends-on ("pkg")) + (:file "methods" + :source-extension "lisp" + :depends-on ("pkg")))) diff --git a/pcl/seal.lisp b/pcl/seal.lisp new file mode 100644 index 000000000..c52a2b68f --- /dev/null +++ b/pcl/seal.lisp @@ -0,0 +1,133 @@ +;;; Copyright (C) 2003 Gerd Moellmann <gerd.moellmann@t-online.de> +;;; All rights reserved. +;;; +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: +;;; +;;; 1. Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. +;;; 2. Redistributions in binary form must reproduce the above copyright +;;; notice, this list of conditions and the following disclaimer in the +;;; documentation and/or other materials provided with the distribution. +;;; 3. The name of the author may not be used to endorse or promote +;;; products derived from this software without specific prior written +;;; permission. +;;; +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE +;;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +;;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT +;;; OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR +;;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE +;;; USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH +;;; DAMAGE. + +(ext:file-comment "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/seal.lisp,v 1.2 2003/03/22 16:15:15 gerd Exp $") + +(in-package "PCL") + +(define-condition sealed-error (simple-program-error) + () + (:report (lambda (condition stream) + (format stream + (format nil "~~@<Sealing error: ~?~~@:>" + (simple-condition-format-control condition) + (simple-condition-format-arguments condition)))))) + +(defun sealed-error (format-control &rest args) + (error 'sealed-error :format-control format-control + :format-arguments args)) + +(defgeneric check-seal (object action seal)) +(defgeneric applicable-seal-p (seal action)) +(defgeneric make-seal (type name action spec)) +(defgeneric seal-quality->type (quality)) + + +;;; ***************************************** +;;; Adding, Removing, Checking Seals ******* +;;; ***************************************** + +(defmacro seal (name &rest specifiers) + `(progn + (eval-when (:load-toplevel :execute) + (%seal ',name ',specifiers 'load)) + (eval-when (:compile-toplevel) + (%seal ',name ',specifiers 'compile)))) + +(defun %seal (name specifiers time) + (loop for spec in specifiers + as quality = (if (consp spec) (car spec) spec) + as type = (seal-quality->type quality) + as seal = (make-seal type name quality spec) do + (ecase time + (compile + (push seal (seal-info-seals (seal-info-or-make name)))) + (load + (let ((object (ecase type + (class (find-class name)) + (generic-function (gdefinition name))))) + (push seal (plist-value object 'seals))))))) + +(defun unseal (object) + (let ((name nil)) + (when (symbolp object) + (setq name object) + (let ((class (find-class object nil))) + (when class + (setf (plist-value object 'seals) nil)))) + (when (generic-function-name-p object) + (setq name object) + (setf (plist-value (gdefinition object) 'seals) nil)) + (typecase object + (class (setq name (class-name object))) + (generic-function (setq name (generic-function-name object)))) + (when name + (let ((info (seal-info name))) + (when info + (setf (seal-info-seals info) nil)))))) + +(defun check-seals (object action) + (let ((seals (if (or (symbolp object) (consp object)) + (let ((info (seal-info object))) + (when info + (seal-info-seals info))) + (plist-value object 'seals)))) + (dolist (seal seals) + (when (applicable-seal-p seal action) + (check-seal seal object action))))) + + +;;; *********************** +;;; Built-in Seals ******* +;;; *********************** + +(defvar *seal-quality->type* + '((:subclasses . class) + (:methods . generic-function))) + +(defvar *seal-quality->actions* + '((:subclasses . (add-direct-subclass remove-direct-subclass + expand-defclass)))) + +(defmethod seal-quality->type (quality) + (or (cdr (assq quality *seal-quality->type*)) + (error "~@<Invalid sealing specifier ~s.~@:>" quality))) + +(defmethod make-seal (type name quality spec) + (declare (ignore type name spec)) + (make-instance 'seal :quality quality)) + +(defmethod applicable-seal-p ((seal seal) action) + (memq action (cdr (assq (seal-quality seal) *seal-quality->actions*)))) + +(defmethod check-seal ((seal seal) object action) + (declare (ignore action)) + (sealed-error "~s is sealed wrt ~a" object (seal-quality seal))) + +;;; end of seal.lisp diff --git a/pcl/slots-boot.lisp b/pcl/slots-boot.lisp index fc530aa85..a5ef1a727 100644 --- a/pcl/slots-boot.lisp +++ b/pcl/slots-boot.lisp @@ -26,33 +26,93 @@ ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/slots-boot.lisp,v 1.16 2002/11/28 16:18:19 pmai Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/slots-boot.lisp,v 1.17 2003/03/22 16:15:15 gerd Exp $") ;;; (in-package :pcl) -(defmacro asv-funcall (sym slot-name type &rest args) - (declare (ignore type)) - `(if (fboundp ',sym) - (,sym ,@args) - (no-slot ',sym ',slot-name))) - -(defun no-slot (sym slot-name) - (error "No class has a slot named ~S (~s has no function binding)." - slot-name sym)) +;;; +;;; Called via LOAD-TIME-VALUE to make sure that the slot accessor +;;; function with name GF-NAME is a generic function, and has a +;;; method that will call SLOT-MISSING if appropriate. +;;; +;;; TYPE is the type of the accessor method, one of the symbols +;;; READER, WRITER, or BOUNDP. SLOT-NAME is the name of the slot +;;; accessed. +;;; +(defun ensure-accessor (type gf-name slot-name) + (labels ((slot-missing-fn (slot-name type) + (let* ((method-type (ecase type + (slot-value 'reader-method) + (setf 'writer-method) + (slot-boundp 'boundp-method))) + (initargs + (ecase type + (slot-value + (make-method-function + (lambda (obj) + (slot-missing (class-of obj) obj slot-name + 'slot-value)))) + (slot-boundp + (make-method-function + (lambda (obj) + (slot-missing (class-of obj) obj slot-name + 'slot-boundp)))) + (setf + (make-method-function + (lambda (val obj) + (declare (ignore val)) + (slot-missing (class-of obj) obj slot-name + 'setf)))))) + (initargs (copy-tree initargs))) + (setf (getf (getf initargs :plist) :slot-name-lists) + (list (list nil slot-name))) + (setf (getf (getf initargs :plist) :pv-table-symbol) + (gensym)) + (list* :method-spec (list method-type 'slot-object slot-name) + initargs))) + (add-slot-missing-method (gf slot-name type) + (multiple-value-bind (class lambda-list specializers) + (ecase type + (slot-value + (values 'standard-reader-method + '(object) + (list *the-class-slot-object*))) + (slot-boundp + (values 'standard-boundp-method + '(object) + (list *the-class-slot-object*))) + (setf + (values 'standard-writer-method + '(new-value object) + (list *the-class-t* *the-class-slot-object*)))) + (add-method gf (make-a-method class + () + lambda-list + specializers + (slot-missing-fn slot-name type) + "generated slot-missing method" + slot-name))))) + (unless (fboundp gf-name) + (let ((gf (ensure-generic-function gf-name))) + (ecase type + (reader (add-slot-missing-method gf slot-name 'slot-value)) + (boundp (add-slot-missing-method gf slot-name 'slot-boundp)) + (writer (add-slot-missing-method gf slot-name 'setf))) + (setf (plist-value gf 'slot-missing-method) t)) + t))) (defmacro accessor-slot-value (object slot-name) - (unless (constantp slot-name) - (error "~s requires its slot-name argument to be a constant" - 'accessor-slot-value)) + (assert (constantp slot-name)) (let* ((slot-name (eval slot-name)) - (sym (slot-reader-symbol slot-name))) - `(asv-funcall ,sym ,slot-name reader ,object))) + (reader-name (slot-reader-name slot-name))) + `(let ((.ignore. (load-time-value (ensure-accessor 'reader ',reader-name + ',slot-name)))) + (declare (ignore .ignore.)) + (funcall #',reader-name ,object)))) (defmacro accessor-set-slot-value (object slot-name new-value &environment env) - (unless (constantp slot-name) - (error "~s requires its slot-name argument to be a constant" - 'accessor-set-slot-value)) + (assert (constantp slot-name)) (setq object (macroexpand object env)) (setq slot-name (macroexpand slot-name env)) (let* ((slot-name (eval slot-name)) @@ -60,23 +120,23 @@ (let ((object-var (gensym))) (prog1 `((,object-var ,object)) (setq object object-var))))) - (sym (slot-writer-symbol slot-name)) - (form `(asv-funcall ,sym ,slot-name writer ,new-value ,object))) + (writer-name (slot-writer-name slot-name)) + (form `(let ((.ignore. (load-time-value + (ensure-accessor 'writer ',writer-name ',slot-name)))) + (declare (ignore .ignore.)) + (funcall #',writer-name ,new-value ,object)))) (if bindings `(let ,bindings ,form) form))) -(defconstant *optimize-slot-boundp* nil) - (defmacro accessor-slot-boundp (object slot-name) - (unless (constantp slot-name) - (error "~s requires its slot-name argument to be a constant" - 'accessor-slot-boundp)) + (assert (constantp slot-name)) (let* ((slot-name (eval slot-name)) - (sym (slot-boundp-symbol slot-name))) - (if (not *optimize-slot-boundp*) - `(slot-boundp-normal ,object ',slot-name) - `(asv-funcall ,sym ,slot-name boundp ,object)))) + (boundp-name (slot-boundp-name slot-name))) + `(let ((.ignore. (load-time-value + (ensure-accessor 'boundp ',boundp-name ',slot-name)))) + (declare (ignore .ignore.)) + (funcall #',boundp-name ,object)))) (defun make-structure-slot-boundp-function (slotd) (declare (ignore slotd)) @@ -96,7 +156,7 @@ #+nil (format t "* Warning: ~s ~s~% ~s~%" name slotd class) nil) - (t (error "~S is not a standard-class" class)))) + (t (error "~@<~S is not a standard-class.~@:>" class)))) (slot-name (slot-definition-name slotd)) (index (slot-definition-location slotd)) (function (ecase name @@ -114,13 +174,13 @@ (fixnum (if fsc-p (lambda (instance) (check-obsolete-instance instance) - (let ((value (%instance-ref (fsc-instance-slots instance) index))) + (let ((value (%slot-ref (fsc-instance-slots instance) index))) (if (eq value +slot-unbound+) (slot-unbound (class-of instance) instance slot-name) value))) (lambda (instance) (check-obsolete-instance instance) - (let ((value (%instance-ref (std-instance-slots instance) index))) + (let ((value (%slot-ref (std-instance-slots instance) index))) (if (eq value +slot-unbound+) (slot-unbound (class-of instance) instance slot-name) value))))) @@ -139,10 +199,10 @@ (fixnum (if fsc-p (lambda (nv instance) (check-obsolete-instance instance) - (setf (%instance-ref (fsc-instance-slots instance) index) nv)) + (setf (%slot-ref (fsc-instance-slots instance) index) nv)) (lambda (nv instance) (check-obsolete-instance instance) - (setf (%instance-ref (std-instance-slots instance) index) nv)))) + (setf (%slot-ref (std-instance-slots instance) index) nv)))) (cons (lambda (nv instance) (check-obsolete-instance instance) (setf (cdr index) nv)))) @@ -155,13 +215,11 @@ (fixnum (if fsc-p (lambda (instance) (check-obsolete-instance instance) - (not (eq (%instance-ref (fsc-instance-slots instance) - index) + (not (eq (%slot-ref (fsc-instance-slots instance) index) +slot-unbound+))) (lambda (instance) (check-obsolete-instance instance) - (not (eq (%instance-ref (std-instance-slots instance) - index) + (not (eq (%slot-ref (std-instance-slots instance) index) +slot-unbound+))))) (cons (lambda (instance) (check-obsolete-instance instance) @@ -195,7 +253,7 @@ (boundp (make-optimized-structure-slot-boundp-using-class-method-function))) (let* ((fsc-p (cond ((standard-class-p class) nil) ((funcallable-standard-class-p class) t) - (t (error "~S is not a standard-class" class)))) + (t (error "~@<~S is not a standard-class.~@:>" class)))) (slot-name (slot-definition-name slotd)) (index (slot-definition-location slotd)) (function @@ -217,14 +275,14 @@ (lambda (class instance slotd) (declare (ignore slotd)) (check-obsolete-instance instance) - (let ((value (%instance-ref (fsc-instance-slots instance) index))) + (let ((value (%slot-ref (fsc-instance-slots instance) index))) (if (eq value +slot-unbound+) (slot-unbound class instance slot-name) value))) (lambda (class instance slotd) (declare (ignore slotd)) (check-obsolete-instance instance) - (let ((value (%instance-ref (std-instance-slots instance) index))) + (let ((value (%slot-ref (std-instance-slots instance) index))) (if (eq value +slot-unbound+) (slot-unbound class instance slot-name) value))))) @@ -245,11 +303,11 @@ (lambda (nv class instance slotd) (declare (ignore class slotd)) (check-obsolete-instance instance) - (setf (%instance-ref (fsc-instance-slots instance) index) nv)) + (setf (%slot-ref (fsc-instance-slots instance) index) nv)) (lambda (nv class instance slotd) (declare (ignore class slotd)) (check-obsolete-instance instance) - (setf (%instance-ref (std-instance-slots instance) index) nv)))) + (setf (%slot-ref (std-instance-slots instance) index) nv)))) (cons (lambda (nv class instance slotd) (declare (ignore class slotd)) (check-obsolete-instance instance) @@ -264,14 +322,12 @@ (lambda (class instance slotd) (declare (ignore class slotd)) (check-obsolete-instance instance) - (not (eq (%instance-ref (fsc-instance-slots instance) - index) + (not (eq (%slot-ref (fsc-instance-slots instance) index) +slot-unbound+))) (lambda (class instance slotd) (declare (ignore class slotd)) (check-obsolete-instance instance) - (not (eq (%instance-ref (std-instance-slots instance) - index) + (not (eq (%slot-ref (std-instance-slots instance) index) +slot-unbound+))))) (cons (lambda (class instance slotd) (declare (ignore class slotd)) @@ -299,7 +355,7 @@ (assq slot-name (wrapper-class-slots wrapper))))) (typecase index (fixnum - (let ((value (%instance-ref (get-slots instance) index))) + (let ((value (%slot-ref (get-slots instance) index))) (if (eq value +slot-unbound+) (slot-unbound (class-of instance) instance slot-name) value))) @@ -309,7 +365,8 @@ (slot-unbound (class-of instance) instance slot-name) value))) (t - (error "The wrapper for class ~S does not have the slot ~S" + (error "~@<The wrapper for class ~S does not have ~ + the slot ~S.~@:>" class slot-name)))) (slot-value instance slot-name))))))) @@ -321,9 +378,9 @@ (lambda (instance) (pv-binding1 (.pv. .calls. (symbol-value pv-table-symbol) - (instance) (instance-slots)) - (instance-read-internal - .pv. instance-slots 1 + (instance) (.slots.)) + (pv-slot-value + class-name slot-name .slots. 0 t nil (slot-value instance slot-name)))))))) (setf (getf (getf initargs :plist) :slot-name-lists) (list (list nil slot-name))) @@ -338,9 +395,9 @@ (lambda (nv instance) (pv-binding1 (.pv. .calls. (symbol-value pv-table-symbol) - (instance) (instance-slots)) - (instance-write-internal - .pv. instance-slots 1 nv + (instance) (.slots.)) + (pv-set-slot-value + class-name slot-name .slots. 0 nv nil (setf (slot-value instance slot-name) nv)))))))) (setf (getf (getf initargs :plist) :slot-name-lists) (list nil (list nil slot-name))) @@ -355,9 +412,9 @@ (lambda (instance) (pv-binding1 (.pv. .calls. (symbol-value pv-table-symbol) - (instance) (instance-slots)) - (instance-boundp-internal - .pv. instance-slots 1 + (instance) (.slots.)) + (pv-slot-boundp + class-name slot-name .slots. 0 (slot-boundp instance slot-name)))))))) (setf (getf (getf initargs :plist) :slot-name-lists) (list (list nil slot-name))) @@ -367,27 +424,29 @@ (defun initialize-internal-slot-gfs (slot-name &optional type) (when (or (null type) (eq type 'reader)) - (let* ((name (slot-reader-symbol slot-name)) - (gf (ensure-generic-function name))) - (unless (generic-function-methods gf) + (let* ((name (slot-reader-name slot-name)) + (gf (ensure-generic-function name)) + (methods (generic-function-methods gf))) + (when (or (null methods) + (plist-value gf 'slot-missing-method)) + (setf (plist-value gf 'slot-missing-method) nil) (add-reader-method *the-class-slot-object* gf slot-name)))) (when (or (null type) (eq type 'writer)) - (let* ((name (slot-writer-symbol slot-name)) - (gf (ensure-generic-function name))) - (unless (generic-function-methods gf) + (let* ((name (slot-writer-name slot-name)) + (gf (ensure-generic-function name)) + (methods (generic-function-methods gf))) + (when (or (null methods) + (plist-value gf 'slot-missing-method)) + (setf (plist-value gf 'slot-missing-method) nil) (add-writer-method *the-class-slot-object* gf slot-name)))) - (when (and *optimize-slot-boundp* - (or (null type) (eq type 'boundp))) - (let* ((name (slot-boundp-symbol slot-name)) - (gf (ensure-generic-function name))) - (unless (generic-function-methods gf) + (when (or (null type) (eq type 'boundp)) + (let* ((name (slot-boundp-name slot-name)) + (gf (ensure-generic-function name)) + (methods (generic-function-methods gf))) + (when (or (null methods) + (plist-value gf 'slot-missing-method)) + (setf (plist-value gf 'slot-missing-method) nil) (add-boundp-method *the-class-slot-object* gf slot-name)))) nil) -(defun initialize-internal-slot-gfs* (readers writers boundps) - (dolist (reader readers) - (initialize-internal-slot-gfs reader 'reader)) - (dolist (writer writers) - (initialize-internal-slot-gfs writer 'writer)) - (dolist (boundp boundps) - (initialize-internal-slot-gfs boundp 'boundp))) + diff --git a/pcl/slots.lisp b/pcl/slots.lisp index bdf8bbf38..acf144452 100644 --- a/pcl/slots.lisp +++ b/pcl/slots.lisp @@ -26,7 +26,7 @@ ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/slots.lisp,v 1.16 2002/11/21 22:09:13 pmai Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/slots.lisp,v 1.17 2003/03/22 16:15:15 gerd Exp $") ;;; (in-package :pcl) @@ -36,8 +36,8 @@ (define-condition unbound-slot (cell-error) ((instance :reader unbound-slot-instance :initarg :instance) (slot :reader unbound-slot-slot :initarg :slot)) - (:report (lambda(condition stream) - (format stream "The slot ~S is unbound in the object ~S" + (:report (lambda (condition stream) + (format stream "~@<The slot ~S is unbound in the object ~S.~@:>" (unbound-slot-slot condition) (unbound-slot-instance condition))))) @@ -59,71 +59,28 @@ ;;; std-class. Many of these methods call these four functions. ;;; -(defun set-wrapper (inst new) - (cond ((std-instance-p inst) - (setf (std-instance-wrapper inst) new)) - ((fsc-instance-p inst) - (setf (fsc-instance-wrapper inst) new)) - (t - (error "What kind of instance is this?")))) - (defun swap-wrappers-and-slots (i1 i2) (with-pcl-lock - (cond ((std-instance-p i1) - (let ((w1 (std-instance-wrapper i1)) - (s1 (std-instance-slots i1))) - (setf (std-instance-wrapper i1) (std-instance-wrapper i2)) - (setf (std-instance-slots i1) (std-instance-slots i2)) - (setf (std-instance-wrapper i2) w1) - (setf (std-instance-slots i2) s1))) - ((fsc-instance-p i1) - (let ((w1 (fsc-instance-wrapper i1)) - (s1 (fsc-instance-slots i1))) - (setf (fsc-instance-wrapper i1) (fsc-instance-wrapper i2)) - (setf (fsc-instance-slots i1) (fsc-instance-slots i2)) - (setf (fsc-instance-wrapper i2) w1) - (setf (fsc-instance-slots i2) s1))) - (t - (error "What kind of instance is this?"))))) - - - - - - -(defun get-class-slot-value-1 (object wrapper slot-name) - (let ((entry (assoc slot-name (wrapper-class-slots wrapper)))) - (if (null entry) - (slot-missing (wrapper-class wrapper) object slot-name 'slot-value) - (if (eq (cdr entry) +slot-unbound+) - (slot-unbound (wrapper-class wrapper) object slot-name) - (cdr entry))))) - -(defun set-class-slot-value-1 (new-value object wrapper slot-name) - (let ((entry (assoc slot-name (wrapper-class-slots wrapper)))) - (if (null entry) - (slot-missing (wrapper-class wrapper) - object - slot-name - 'setf - new-value) - (setf (cdr entry) new-value)))) - -(defmethod class-slot-value ((class std-class) slot-name) - (let ((wrapper (class-wrapper class)) - (prototype (class-prototype class))) - (get-class-slot-value-1 prototype wrapper slot-name))) - -(defmethod (setf class-slot-value) (nv (class std-class) slot-name) - (let ((wrapper (class-wrapper class)) - (prototype (class-prototype class))) - (set-class-slot-value-1 nv prototype wrapper slot-name))) + (if (std-instance-p i1) + (let ((w1 (std-instance-wrapper i1)) + (s1 (std-instance-slots i1))) + (setf (std-instance-wrapper i1) (std-instance-wrapper i2)) + (setf (std-instance-slots i1) (std-instance-slots i2)) + (setf (std-instance-wrapper i2) w1) + (setf (std-instance-slots i2) s1)) + (progn + (assert (fsc-instance-p i1)) + (let ((w1 (fsc-instance-wrapper i1)) + (s1 (fsc-instance-slots i1))) + (setf (fsc-instance-wrapper i1) (fsc-instance-wrapper i2)) + (setf (fsc-instance-slots i1) (fsc-instance-slots i2)) + (setf (fsc-instance-wrapper i2) w1) + (setf (fsc-instance-slots i2) s1)))))) - (defun find-slot-definition (class slot-name) (dolist (slot (class-slots class) nil) - (when (eql slot-name (slot-definition-name slot)) + (when (eq slot-name (slot-definition-name slot)) (return slot)))) (defun slot-value (object slot-name) @@ -153,8 +110,6 @@ `(accessor-set-slot-value ,object ,slot-name ,value) form)) -(defconstant *optimize-slot-boundp* nil) - (defun slot-boundp (object slot-name) (let* ((class (class-of object)) (slot-definition (find-slot-definition class slot-name))) @@ -162,14 +117,11 @@ (slot-missing class object slot-name 'slot-boundp) (slot-boundp-using-class class object slot-definition)))) -(setf (gdefinition 'slot-boundp-normal) #'slot-boundp) - -(define-compiler-macro slot-boundp (object-form slot-name-form) - (if (and (constantp slot-name-form) - (let ((slot-name (eval slot-name-form))) - (and (symbolp slot-name) (symbol-package slot-name)))) - `(accessor-slot-boundp ,object-form ,slot-name-form) - `(slot-boundp-normal ,object-form ,slot-name-form))) +(define-compiler-macro slot-boundp (&whole form object slot-name) + (if (and (constantp slot-name) + (interned-symbol-p (eval slot-name))) + `(accessor-slot-boundp ,object ,slot-name) + form)) (defun slot-makunbound (object slot-name) (let* ((class (class-of object)) @@ -196,10 +148,10 @@ ;;; ;;; (defun standard-instance-access (instance location) - (%instance-ref (std-instance-slots instance) location)) + (%slot-ref (std-instance-slots instance) location)) (defun funcallable-standard-instance-access (instance location) - (%instance-ref (fsc-instance-slots instance) location)) + (%slot-ref (fsc-instance-slots instance) location)) (defmethod slot-value-using-class ((class std-class) (object std-object) @@ -209,16 +161,17 @@ (value (typecase location (fixnum (cond ((std-instance-p object) - (%instance-ref (std-instance-slots object) location)) + (%slot-ref (std-instance-slots object) location)) ((fsc-instance-p object) - (%instance-ref (fsc-instance-slots object) location)) - (t (error "What kind of instance is this?")))) + (%slot-ref (fsc-instance-slots object) location)) + (t (internal-error "What kind of instance is this?")))) (cons (cdr location)) (t - (error "The slot ~s has neither :instance nor :class allocation, ~@ - so it can't be read by the default ~s method." - slotd 'slot-value-using-class))))) + (error "~@<The slot ~s has neither ~s nor ~s ~ + allocation, so it can't be read by the default ~s ~ + method.~@:>" + slotd :instance :class 'slot-value-using-class))))) (if (eq value +slot-unbound+) (slot-unbound class object (slot-definition-name slotd)) value))) @@ -232,16 +185,16 @@ (typecase location (fixnum (cond ((std-instance-p object) - (setf (%instance-ref (std-instance-slots object) location) new-value)) + (setf (%slot-ref (std-instance-slots object) location) new-value)) ((fsc-instance-p object) - (setf (%instance-ref (fsc-instance-slots object) location) new-value)) - (t (error "What kind of instance is this?")))) + (setf (%slot-ref (fsc-instance-slots object) location) new-value)) + (t (internal-error "What kind of instance is this?")))) (cons (setf (cdr location) new-value)) (t - (error "The slot ~s has neither :instance nor :class allocation, ~@ - so it can't be written by the default ~s method." - slotd '(setf slot-value-using-class)))))) + (error "~@<The slot ~s has neither ~s nor ~s allocation, ~ + so it can't be written by the default ~s method.~@:>" + slotd :instance :class '(setf slot-value-using-class)))))) (defmethod slot-boundp-using-class ((class std-class) @@ -252,16 +205,17 @@ (value (typecase location (fixnum (cond ((std-instance-p object) - (%instance-ref (std-instance-slots object) location)) + (%slot-ref (std-instance-slots object) location)) ((fsc-instance-p object) - (%instance-ref (fsc-instance-slots object) location)) - (t (error "What kind of instance is this?")))) + (%slot-ref (fsc-instance-slots object) location)) + (t (internal-error "What kind of instance is this?")))) (cons (cdr location)) (t - (error "The slot ~s has neither :instance nor :class allocation, ~@ - so it can't be read by the default ~s method." - slotd 'slot-boundp-using-class))))) + (error "~@<The slot ~s has neither ~s nor ~s ~ + allocation, so it can't be read by the default ~s ~ + method.~@:>" + slotd :instance :class 'slot-boundp-using-class))))) (not (eq value +slot-unbound+)))) (defmethod slot-makunbound-using-class @@ -273,28 +227,25 @@ (typecase location (fixnum (cond ((std-instance-p object) - (setf (%instance-ref (std-instance-slots object) location) +slot-unbound+)) + (setf (%slot-ref (std-instance-slots object) location) +slot-unbound+)) ((fsc-instance-p object) - (setf (%instance-ref (fsc-instance-slots object) location) +slot-unbound+)) - (t (error "What kind of instance is this?")))) + (setf (%slot-ref (fsc-instance-slots object) location) +slot-unbound+)) + (t (internal-error "What kind of instance is this?")))) (cons (setf (cdr location) +slot-unbound+)) (t - (error "The slot ~s has neither :instance nor :class allocation, ~@ - so it can't be written by the default ~s method." - slotd 'slot-makunbound-using-class)))) + (error "~@<The slot ~s has neither ~s nor ~s allocation, ~ + so it can't be written by the default ~s method.~@:>" + slotd :instance :class 'slot-makunbound-using-class)))) nil) (defmethod slot-value-using-class ((class structure-class) (object structure-object) (slotd structure-effective-slot-definition)) - (let* ((function (slot-definition-internal-reader-function slotd)) - (value (funcall function object))) + (let ((function (slot-definition-internal-reader-function slotd))) (declare (type function function)) - (if (eq value +slot-unbound+) - (slot-unbound class object (slot-definition-name slotd)) - value))) + (funcall function object))) (defmethod (setf slot-value-using-class) (new-value (class structure-class) @@ -314,21 +265,22 @@ ((class structure-class) (object structure-object) (slotd structure-effective-slot-definition)) - (error "Structure slots can't be unbound")) + (error "Structure slots cannot be unbound.")) (defmethod slot-missing ((class t) instance slot-name operation &optional new-value) - (error "When attempting to ~A,~%the slot ~S is missing from the object ~S." - (ecase operation - (slot-value "read the slot's value (slot-value)") - (setf (format nil - "set the slot's value to ~S (setf of slot-value)" - new-value)) - (slot-boundp "test to see if slot is bound (slot-boundp)") - (slot-makunbound "make the slot unbound (slot-makunbound)")) - slot-name - instance)) + (error + (format nil "~~@<When attempting to ~A, the slot ~S is missing ~ + from the object ~S.~~@:>" + (ecase operation + (slot-value "read the slot's value (slot-value)") + (setf (format nil "set the slot's value to ~S (setf of slot-value)" + new-value)) + (slot-boundp "test to see if slot is bound (slot-boundp)") + (slot-makunbound "make the slot unbound (slot-makunbound)")) + slot-name + instance))) (defmethod slot-unbound ((class t) instance slot-name) (error 'unbound-slot :slot slot-name :instance instance)) @@ -353,6 +305,7 @@ (let ((constructor (class-defstruct-constructor class))) (if constructor (funcall constructor) - (error "Can't allocate an instance of class ~S" (class-name class))))) + (error "~@<Can't allocate an instance of class ~S.~@:>" + (class-name class))))) diff --git a/pcl/std-class.lisp b/pcl/std-class.lisp index 175919f1c..4b6a0e193 100644 --- a/pcl/std-class.lisp +++ b/pcl/std-class.lisp @@ -26,8 +26,7 @@ ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/std-class.lisp,v 1.43 2003/02/06 15:20:12 gerd Exp $") -;;; + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/std-class.lisp,v 1.44 2003/03/22 16:15:15 gerd Exp $") (in-package :pcl) @@ -90,7 +89,8 @@ (compute-slot-accessor-info slotd type gf))) (initialize-internal-slot-gfs name))) -(defmethod compute-slot-accessor-info ((slotd effective-slot-definition) type gf) +(defmethod compute-slot-accessor-info ((slotd effective-slot-definition) + type gf) (let* ((name (slot-value slotd 'name)) (class (slot-value slotd 'class)) (old-slotd (find-slot-definition class name)) @@ -101,8 +101,11 @@ (get-optimized-std-accessor-method-function class slotd type)) (setf (slot-accessor-std-p slotd type) std-p) (setf (slot-accessor-function slotd type) function)) - (when (and old-slotd (not (eq old-std-p (slot-accessor-std-p slotd 'all)))) - (push (cons class name) *pv-table-cache-update-info*)))) + ;; + ;; Optimized accessor functions use pv tables. + (when (and old-slotd + (not (eq old-std-p (slot-accessor-std-p slotd 'all)))) + (record-pv-update-info slotd)))) (defmethod slot-definition-allocation ((slotd structure-slot-definition)) :instance) @@ -122,7 +125,7 @@ (defmethod (setf documentation) (new-value object doc-type) (declare (ignore new-value doc-type)) - (error "Can't change the documentation of ~S." object)) + (error "~@<Can't change the documentation of ~S.~@:>" object)) (defmethod documentation ((object documentation-mixin) doc-type) (declare (ignore doc-type)) @@ -190,11 +193,13 @@ ;;; here, the values are read by an automatically generated reader method. ;;; (defmethod add-direct-subclass ((class class) (subclass class)) + (check-seals class 'add-direct-subclass) (with-slots (direct-subclasses) class (pushnew subclass direct-subclasses) subclass)) (defmethod remove-direct-subclass ((class class) (subclass class)) + (check-seals class 'remove-direct-subclass) (with-slots (direct-subclasses) class (setq direct-subclasses (remove subclass direct-subclasses)) subclass)) @@ -227,6 +232,7 @@ (with-slots (direct-methods) specializer (setf (car direct-methods) (remove method (car direct-methods)) (cdr direct-methods) ())) + (remove-inline-access-method specializer method) method) (defmethod specializer-direct-methods ((specializer class)) @@ -248,8 +254,8 @@ ;;; This hash table is used to store the direct methods and direct generic ;;; functions of EQL specializers. Each value in the table is the cons. ;;; -(defvar *eql-specializer-methods* (make-hash-table :test #'eql)) -(defvar *class-eq-specializer-methods* (make-hash-table :test #'eq)) +(defvar *eql-specializer-methods* (make-hash-table :test 'eql)) +(defvar *class-eq-specializer-methods* (make-hash-table :test 'eq)) (defmethod specializer-method-table ((specializer eql-specializer)) *eql-specializer-methods*) @@ -307,6 +313,17 @@ *eql-specializer-table*) nil) +(defun map-all-classes (function &optional (root t)) + (let ((braid-p (memq *boot-state* '(braid complete))) + (root (if (symbolp root) (find-class root) root))) + (labels ((map-class (class) + (mapc #'map-class + (if braid-p + (class-direct-subclasses class) + (early-class-direct-subclasses class))) + (funcall function class))) + (map-class root)))) + (defun map-all-generic-functions (function) (let ((all-generic-functions (make-hash-table :test 'eq))) (map-specializers (lambda (specl) @@ -327,17 +344,11 @@ (defun real-load-defclass (name metaclass-name supers slots other) - (let ((res (apply #'ensure-class name :metaclass metaclass-name - :direct-superclasses supers - :direct-slots slots - :definition-source `((defclass ,name) - ,*load-pathname*) - other))) - ;; Defclass of a class with a forward-referenced superclass does not - ;; have a wrapper. RES is the incomplete PCL class. The Lisp class - ;; does not yet exist. Maybe should return NIL in that case as RES - ;; is not useful to the user? - (and (class-wrapper res)(kernel:layout-class (class-wrapper res))))) + (apply #'ensure-class name :metaclass metaclass-name + :direct-superclasses supers + :direct-slots slots + :definition-source `((defclass ,name) ,*load-pathname*) + other)) (setf (gdefinition 'load-defclass) #'real-load-defclass) @@ -347,19 +358,20 @@ (defmethod ensure-class-using-class (name (class null) &rest args &key) (multiple-value-bind (meta initargs) (ensure-class-values class args) - (inform-type-system-about-class (class-prototype meta) name);*** + (inform-type-system-about-class (class-prototype meta) name) (setf class (apply #'make-instance meta :name name initargs) (find-class name) class) - (inform-type-system-about-class class name) ;*** + (inform-type-system-about-class class name) class)) (defmethod ensure-class-using-class (name (class pcl-class) &rest args &key) (multiple-value-bind (meta initargs) (ensure-class-values class args) - (unless (eq (class-of class) meta) (change-class class meta)) + (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) ;*** + (inform-type-system-about-class class name) class)) (defmethod class-predicate-name ((class t)) @@ -370,19 +382,18 @@ (unsupplied (list 1)) (supplied-meta (getf initargs :metaclass unsupplied)) (supplied-supers (getf initargs :direct-superclasses unsupplied)) - (meta - (cond ((neq supplied-meta unsupplied) - (find-class supplied-meta)) - ((or (null class) - (forward-referenced-class-p class)) - *the-class-standard-class*) - (t - (class-of class))))) + (meta (cond ((neq supplied-meta unsupplied) + (find-class supplied-meta)) + ((or (null class) + (forward-referenced-class-p class)) + *the-class-standard-class*) + (t + (class-of class))))) (flet ((fix-super (s) (cond ((classp s) s) ((not (legal-class-name-p s)) (simple-program-error - "~S is not a class or a legal class name." s)) + "~@<~S is not a class or a legal class name.~@:>" s)) (t (or (find-class s nil) (setf (find-class s) @@ -397,17 +408,27 @@ for slot-name = (getf slot :name) if (some (lambda (s) (eq slot-name (getf s :name))) more) do (simple-program-error - "More than one direct slot with name ~S." + "~@<More than one direct slot with name ~S.~@:>" slot-name) else do (loop for (option value . more) on slot by #'cddr - when (and (member option '(:allocation :type :initform - :documentation)) - (not (eq unsupplied - (getf more option unsupplied)))) do + if (and (member option '(:allocation :type :initform + :documentation)) + (not (eq unsupplied + (getf more option unsupplied)))) do + (simple-program-error + "~@<Duplicate slot option ~S for slot ~S.~@:>" + option slot-name) + else if (and (eq option :readers) + (notevery #'symbolp value)) do (simple-program-error - "Duplicate slot option ~S for slot ~S." - option slot-name))) + "~@<Slot ~S: slot reader names must be symbols.~@:>" + slot-name) + else if (and (eq option :initargs) + (notevery #'symbolp value)) do + (simple-program-error + "~@<Slot ~S: initarg names must be symbols.~@:>" + slot-name))) ;; ;; CLHS: signal PROGRAM-ERROR, if an initialization argument name ;; appears more than once in :DEFAULT-INITARGS class option. @@ -415,33 +436,31 @@ for name = (car initarg) when (some (lambda (a) (eq (car a) name)) more) do (simple-program-error - "Duplicate initialization argument ~ - name ~S in :default-initargs of class ~A." - name class)) + "~@<Duplicate initialization argument ~ + name ~S in ~s of class ~A.~@:>" + name :default-initargs class)) + ;; + (loop for (arg value) on initargs by #'cddr + count (eq arg :metaclass) into metaclass + count (eq arg :direct-default-initargs) into default-initargs + when (or (> metaclass 1) (> default-initargs 1)) do + (simple-program-error + "~@<Class ~S: More than one ~S specified~@:>" + class (if (eq arg :direct-default-initargs) + :default-initargs arg))) + (remf initargs :metaclass) + (remf initargs :direct-superclasses) ;; - (loop (unless (remf initargs :metaclass) (return))) - (loop (unless (remf initargs :direct-superclasses) (return))) (values meta - (nconc - (when (neq supplied-supers unsupplied) - (list - :direct-superclasses - (mapcar #'fix-super supplied-supers))) - initargs))))) + (nconc (when (neq supplied-supers unsupplied) + (list :direct-superclasses + (mapcar #'fix-super supplied-supers))) + initargs))))) ;;; ;;; ;;; -#|| ; since it doesn't do anything -(defmethod shared-initialize :before ((class std-class) - slot-names - &key direct-superclasses) - (declare (ignore slot-names)) - ;; *** error checking - ) -||# - (defmethod shared-initialize :after ((class std-class) slot-names @@ -459,10 +478,10 @@ *the-class-standard-object*)))) (dolist (superclass direct-superclasses) (unless (validate-superclass class superclass) - (error "The class ~S was specified as a~% - super-class of the class ~S;~%~ - but the meta-classes ~S and~%~S are incompatible.~@ - Define a method for ~S to avoid this error." + (error "~@<The class ~S was specified as a ~ + super-class of the class ~S, ~ + but the meta-classes ~S and ~S are incompatible. ~ + Define a method for ~S to avoid this error.~@:>" superclass class (class-of superclass) (class-of class) 'validate-superclass))) (setf (slot-value class 'direct-superclasses) direct-superclasses)) @@ -539,9 +558,13 @@ (mapcar (lambda (pl) (when defstruct-p (let* ((slot-name (getf pl :name)) - (acc-name (format nil "~s structure class ~a" - name slot-name)) - (accessor (intern acc-name))) + (accessor + (symbolicate + *package* + (if (symbol-package name) + (package-name (symbol-package name)) + "") + "::" name " structure class " slot-name))) (setq pl (list* :defstruct-accessor-symbol accessor pl)))) (make-direct-slotd class pl)) @@ -549,25 +572,41 @@ (setq direct-slots (slot-value class 'direct-slots))) (when defstruct-p (let* ((include (car (slot-value class 'direct-superclasses))) - (conc-name (intern (format nil "~s structure class " name))) - (constructor (intern (format nil "~a constructor" conc-name))) + (conc-name (symbolicate *package* + (if (symbol-package name) + (package-name (symbol-package name)) + "") + "::" name " structure class ")) + ;; + ;; It's not possible to use a generalized name for the + ;; constructor function. It shouldn't matter though, I think, + ;; like for the slot names above, because this stuff is not + ;; supposed to be used by users directly. + (constructor + (symbolicate *package* conc-name " constructor")) (defstruct `(defstruct (,name ,@(when include `((:include ,(class-name include)))) (:predicate nil) (:conc-name ,conc-name) (:constructor ,constructor ())) + ;; + ;; Use a temporary unbound marker that lets + ;; SHARED-INITIALIZE recognize if a before-method + ;; has written to a slot. ,@(mapcar (lambda (slot) `(,(slot-definition-name slot) - +slot-unbound+)) + '.unbound.)) direct-slots))) (reader-names (mapcar (lambda (slotd) - (intern (format nil "~A~A reader" conc-name - (slot-definition-name slotd)))) + (list 'slot-accessor name + (slot-definition-name slotd) + 'reader)) direct-slots)) (writer-names (mapcar (lambda (slotd) - (intern (format nil "~A~A writer" conc-name - (slot-definition-name slotd)))) + (list 'slot-accessor name + (slot-definition-name slotd) + 'writer)) direct-slots)) (readers-init (mapcar (lambda (slotd reader-name) @@ -603,9 +642,9 @@ (setf (slot-value class 'class-precedence-list) (compute-class-precedence-list class)) (setf (slot-value class 'slots) (compute-slots class)) - (let ((lclass (lisp:find-class (class-name class)))) - (setf (kernel:class-pcl-class lclass) class) - (setf (slot-value class 'wrapper) (kernel:class-layout lclass))) + (let ((lclass (kernel::find-class (class-name class)))) + (setf (kernel:%class-pcl-class lclass) class) + (setf (slot-value class 'wrapper) (kernel:%class-layout lclass))) (update-pv-table-cache-info class) (setq predicate-name (if predicate-name-p (setf (slot-value class 'predicate-name) @@ -629,7 +668,7 @@ (defun remove-slot-accessors (class dslotds) (fix-slot-accessors class dslotds 'remove)) -(defun fix-slot-accessors (class dslotds add/remove) +(defun fix-slot-accessors (class dslotds add/remove) (flet ((fix (gfspec name r/w) (let ((gf (ensure-generic-function gfspec))) (case r/w @@ -641,8 +680,10 @@ (remove-writer-method class gf))))))) (dolist (dslotd dslotds) (let ((slot-name (slot-definition-name dslotd))) - (dolist (r (slot-definition-readers dslotd)) (fix r slot-name 'r)) - (dolist (w (slot-definition-writers dslotd)) (fix w slot-name 'w)))))) + (dolist (r (slot-definition-readers dslotd)) + (fix r slot-name 'r)) + (dolist (w (slot-definition-writers dslotd)) + (fix w slot-name 'w)))))) (defun add-direct-subclasses (class new) @@ -664,7 +705,7 @@ (defmethod finalize-inheritance ((class forward-referenced-class)) (simple-program-error - "Forward-referenced classes cannot be finalized: ~A" + "~@<Forward-referenced classes cannot be finalized: ~A.~@:>" class)) @@ -677,31 +718,31 @@ ;;; Called by :after shared-initialize whenever a class is initialized or ;;; reinitialized. The class may or may not be finalized. ;;; -(defun update-class (class finalizep) - ;; Comment from Gerd Moellmann: +(defun update-class (class finalizep) ;; - ;; Note that we can't simply delay the finalization when CLASS has - ;; no forward referenced superclasses because that causes bootstrap - ;; problems. - (when (and (not finalizep) - (not (class-finalized-p class)) + ;; Calling UPDATE-SLOTS below sets the class wrapper of CLASS, which + ;; makes the class finalized. When UPDATE-CLASS isn't called from + ;; FINALIZE-INHERITANCE, make sure that this finalization invokes + ;; FINALIZE-INHERITANCE as per AMOP. Note that we can't simply + ;; delay the finalization when CLASS has no forward referenced + ;; superclasses because that causes bootstrap problems. + (when (and (not (or finalizep (class-finalized-p class))) (not (class-has-a-forward-referenced-superclass-p class))) (finalize-inheritance class) (return-from update-class)) - (when (or finalizep (class-finalized-p class) + ;; + (when (or finalizep + (class-finalized-p class) (not (class-has-a-forward-referenced-superclass-p class))) (update-cpl class (compute-class-precedence-list class)) - ;; This invocation of UPDATE-SLOTS, in practice, finalizes the - ;; class. The hoops above are to ensure that FINALIZE-INHERITANCE - ;; is called at finalization, so that MOP programmers can hook - ;; into the system as described in "Class Finalization Protocol" - ;; (section 5.5.2 of AMOP). (update-slots class (compute-slots class)) (update-gfs-of-class class) (update-inits class (compute-default-initargs class)) - (update-make-instance-function-table class)) + (update-ctors 'finalize-inheritance :class class)) + ;; (unless finalizep - (dolist (sub (class-direct-subclasses class)) (update-class sub nil)))) + (dolist (sub (class-direct-subclasses class)) + (update-class sub nil)))) (defun update-cpl (class cpl) (if (class-finalized-p class) @@ -747,7 +788,7 @@ ;; ;; We cannot reuse the old wrapper easily when it ;; has class slot cells, even if these cells are - ;; equal to the ones used in the new wrapper. The + ;; EQUAL to the ones used in the new wrapper. The ;; class slot cells of OWRAPPER may be referenced ;; from caches, and if we don't change the wrapper, ;; the caches won't notice that something has @@ -775,6 +816,7 @@ wrapper nwrapper)) (unless (eq owrapper nwrapper) + (update-inline-access class) (update-pv-table-cache-info class))))) (defun compute-class-slots (eslotds) @@ -833,96 +875,102 @@ (defun make-direct-slotd (class initargs) (let ((initargs (list* :class class initargs))) - (apply #'make-instance (direct-slot-definition-class class initargs) initargs))) + (apply #'make-instance (direct-slot-definition-class class initargs) + initargs))) ;;; -;;; +;;; As specified, we must call COMPUTE-EFFECTIVE-SLOT-DEFINITION once +;;; for each different slot name we find in our superclasses. Each +;;; call receives the class and a list of the dslotds with that name. +;;; The list is in most-specific-first order. ;;; (defmethod compute-slots ((class std-class)) - ;; - ;; As specified, we must call COMPUTE-EFFECTIVE-SLOT-DEFINITION once - ;; for each different slot name we find in our superclasses. Each - ;; call receives the class and a list of the dslotds with that name. - ;; The list is in most-specific-first order. - ;; - (let ((name-dslotds-alist ())) - (dolist (c (class-precedence-list class)) - (dolist (slot (class-direct-slots c)) - (let* ((name (slot-definition-name slot)) - (entry (assq name name-dslotds-alist))) - (if entry - (push slot (cdr entry)) - (push (list name slot) name-dslotds-alist))))) - (mapcar (lambda (direct) - (compute-effective-slot-definition class - (nreverse (cdr direct)))) - name-dslotds-alist))) + (loop with names/slots = () + for c in (class-precedence-list class) do + (loop for slot in (class-direct-slots c) + as name = (slot-definition-name slot) + as entry = (assq name names/slots) do + (if entry + (push slot (cdr entry)) + (push (list name slot) names/slots))) + finally + (return + (loop for (name . slots) in names/slots collect + (compute-effective-slot-definition + class (nreverse slots)))))) + +;;; +;;; These are the specified AMOP methods. +;;; (defmethod compute-slots ((class standard-class)) (call-next-method)) - + (defmethod compute-slots :around ((class standard-class)) - (let ((eslotds (call-next-method)) - (location -1)) - (dolist (eslotd eslotds eslotds) - (setf (slot-definition-location eslotd) - (ecase (slot-definition-allocation eslotd) - (:instance - (incf location)) - (:class - (let* ((name (slot-definition-name eslotd)) - (from-class (slot-definition-allocation-class eslotd)) - (cell (assq name (class-slot-cells from-class)))) - (assert (consp cell)) - cell)))) - (initialize-internal-slot-functions eslotd)))) + (loop with slotds = (call-next-method) and location = -1 + for slot in slotds do + (setf (slot-definition-location slot) + (ecase (slot-definition-allocation slot) + (:instance + (incf location)) + (:class + (let* ((name (slot-definition-name slot)) + (from-class (slot-definition-allocation-class slot)) + (cell (assq name (class-slot-cells from-class)))) + (assert (consp cell)) + cell)))) + (initialize-internal-slot-functions slot) + finally + (return slotds))) (defmethod compute-slots ((class funcallable-standard-class)) (call-next-method)) (defmethod compute-slots :around ((class funcallable-standard-class)) - (labels ((instance-slot-names (slotds) - (let (collect) - (dolist (slotd slotds (nreverse collect)) - (when (eq (slot-definition-allocation slotd) :instance) - (push (slot-definition-name slotd) collect))))) + (labels (;; + ;; Return a list of the names of instance slots in SLOTDS. + (instance-slot-names (slotds) + (loop for e in slotds + when (eq (slot-definition-allocation e) :instance) + collect (slot-definition-name e))) + ;; ;; This sorts slots so that slots of classes later in the CPL - ;; come before slots of other classes. This is crucial for - ;; funcallable instances because it ensures that the slots of - ;; FUNCALLABLE-STANDARD-OBJECT, which includes the slots of - ;; KERNEL:FUNCALLABLE-INSTANCE, come first, which in turn - ;; makes it possible to treat FUNCALLABLE-STANDARD-OBJECT as - ;; a funcallable instance. + ;; come before slots of other classes. This is crucial for + ;; funcallable instances because it ensures that the slots of + ;; FUNCALLABLE-STANDARD-OBJECT, which includes the slots of + ;; KERNEL:FUNCALLABLE-INSTANCE, come first, which in turn + ;; makes it possible to treat FUNCALLABLE-STANDARD-OBJECT as + ;; a funcallable instance. (compute-layout (eslotds) - (let ((first ()) - (names (instance-slot-names eslotds))) - (dolist (class - (reverse (class-precedence-list class)) - (nreverse (nconc names first))) - (dolist (ss (class-slots class)) - (let ((name (slot-definition-name ss))) - (when (member name names) - (push name first) - (setq names (delete name names))))))))) + (loop with first = () + with names = (instance-slot-names eslotds) + for class in (reverse (class-precedence-list class)) do + (loop for ss in (class-slots class) + as name = (slot-definition-name ss) + when (member name names) do + (push name first) + (setq names (delete name names))) + finally (return (nreverse (nconc names first)))))) + ;; (let ((all-slotds (call-next-method)) (instance-slots ()) (class-slots ())) - (dolist (slotd all-slotds) - (ecase (slot-definition-allocation slotd) - (:instance (push slotd instance-slots)) - (:class (push slotd class-slots)))) - (let ((layout (compute-layout instance-slots))) - (dolist (slotd instance-slots) - (setf (slot-definition-location slotd) - (position (slot-definition-name slotd) layout)) - (initialize-internal-slot-functions slotd))) - (dolist (slotd class-slots) - (let ((name (slot-definition-name slotd)) - (from-class (slot-definition-allocation-class slotd))) - (setf (slot-definition-location slotd) - (assoc name (class-slot-cells from-class))) - (assert (consp (slot-definition-location slotd))) - (initialize-internal-slot-functions slotd))) + (loop for slotd in all-slotds do + (ecase (slot-definition-allocation slotd) + (:instance (push slotd instance-slots)) + (:class (push slotd class-slots)))) + (loop with layout = (compute-layout instance-slots) + for slotd in instance-slots do + (setf (slot-definition-location slotd) + (position (slot-definition-name slotd) layout)) + (initialize-internal-slot-functions slotd)) + (loop for slotd in class-slots + as name = (slot-definition-name slotd) + as from-class = (slot-definition-allocation-class slotd) do + (setf (slot-definition-location slotd) + (assoc name (class-slot-cells from-class))) + (assert (consp (slot-definition-location slotd))) + (initialize-internal-slot-functions slotd)) all-slotds))) (defmethod compute-slots ((class structure-class)) @@ -1044,16 +1092,19 @@ (defmethod remove-reader-method ((class slot-class) generic-function) (let ((method (get-method generic-function () (list class) nil))) - (when method (remove-method generic-function method)))) + (when method + (remove-method generic-function method)))) (defmethod remove-writer-method ((class slot-class) generic-function) - (let ((method - (get-method generic-function () (list *the-class-t* class) nil))) - (when method (remove-method generic-function method)))) + (let ((method (get-method generic-function () + (list *the-class-t* class) nil))) + (when method + (remove-method generic-function method)))) (defmethod remove-boundp-method ((class slot-class) generic-function) (let ((method (get-method generic-function () (list class) nil))) - (when method (remove-method generic-function method)))) + (when method + (remove-method generic-function method)))) ;;; @@ -1093,13 +1144,18 @@ (defmethod inform-type-system-about-class ((class std-class) name) ;; Maybe add skeleton lisp:standard-class to avoid undefined-function ;; compiler warnings. Not otherwise needed in this implementation. - (inform-type-system-about-std-class name)) + (inform-type-system-about-std-class name) + (set-class-translation class name)) -(defmethod inform-type-system-about-class - ((class funcallable-standard-class) name) - (declare (ignore name)) - ;; Avoid load-time warning of changing metaclass. - ) +(defmethod inform-type-system-about-class ((class funcallable-standard-class) + name) + (set-class-translation class name)) + +(defmethod inform-type-system-about-class ((class structure-class) name) + (set-class-translation class name)) + +(defmethod inform-type-system-about-class ((class condition-class) name) + (set-class-translation class name)) @@ -1139,13 +1195,6 @@ ;;; (defun force-cache-flushes (class) (let* ((owrapper (class-wrapper class))) - ;; - ;; We only need to do something if the wrapper is still valid. If the - ;; wrapper isn't valid, state will be FLUSH or OBSOLETE, and both of those - ;; will already be doing what we want. In particular, we must be - ;; sure we never change an OBSOLETE into a FLUSH since OBSOLETE - ;; means do what FLUSH does and then some. - ;; (when (or (not (invalid-wrapper-p owrapper)) (eq :invalid (kernel:layout-invalid owrapper))) (let ((nwrapper (make-wrapper (wrapper-no-of-instance-slots owrapper) @@ -1161,10 +1210,14 @@ (defun flush-cache-trap (owrapper nwrapper instance) (declare (ignore owrapper)) - (set-wrapper instance nwrapper)) + (cond ((std-instance-p instance) + (setf (std-instance-wrapper instance) nwrapper)) + ((fsc-instance-p instance) + (setf (fsc-instance-wrapper instance) nwrapper)) + (t + (internal-error "Internal error.")))) - ;;; ;;; make-instances-obsolete can be called by user code. It will cause the ;;; next access to the instance (as defined in 88-002R) to trap through the @@ -1217,6 +1270,7 @@ ;;; case, we have to return some reasonable wrapper, instead. (defvar *in-obsolete-instance-trap* nil) + (defvar *the-wrapper-of-structure-object* (class-wrapper (find-class 'structure-object))) @@ -1226,8 +1280,8 @@ (lambda (condition stream) ;; Don't try to print the structure, since it probably ;; won't work. - (format stream "Obsolete structure error in ~S:~@ - For a structure of type: ~S" + (format stream "~@<Obsolete structure error in ~S ~ + for a structure of type ~S.~@:>" (conditions::condition-function-name condition) (type-of (obsolete-structure-datum condition)))))) @@ -1261,20 +1315,20 @@ (loop for name in olayout and opos from 0 as npos = (posq name nlayout) if npos do - (setf (instance-ref nslots npos) - (instance-ref oslots opos)) + (setf (slot-ref nslots npos) + (slot-ref oslots opos)) else do (push name discarded) - (unless (eq (instance-ref oslots opos) +slot-unbound+) + (unless (eq (slot-ref oslots opos) +slot-unbound+) (setf (getf plist name) - (instance-ref oslots opos)))) + (slot-ref oslots opos)))) ;; ;; Go through all the old shared slots. ;; (loop for (name . val) in oclass-slots for npos = (posq name nlayout) if npos do - (setf (instance-ref nslots npos) val) + (setf (slot-ref nslots npos) val) else do (push name discarded) (unless (eq val +slot-unbound+) @@ -1299,15 +1353,6 @@ ;;; ;;; ;;; -(defmacro copy-instance-internal (instance) - `(progn - (let* ((class (class-of instance)) - (copy (allocate-instance class))) - (if (std-instance-p ,instance) - (setf (std-instance-slots ,instance) (std-instance-slots ,instance)) - (setf (fsc-instance-slots ,instance) (fsc-instance-slots ,instance))) - copy))) - (defun change-class-internal (instance new-class initargs) (let* ((old-class (class-of instance)) (copy (allocate-instance new-class)) @@ -1327,8 +1372,8 @@ (loop for new-slot in new-layout and new-position from 0 for old-position = (posq new-slot old-layout) when old-position do - (setf (instance-ref new-slots new-position) - (instance-ref old-slots old-position))) + (setf (slot-ref new-slots new-position) + (slot-ref old-slots old-position))) ;; ;; "The values of slots specified as shared in the class Cfrom and ;; as local in the class Cto are retained." @@ -1336,7 +1381,7 @@ (loop for (name . val) in old-class-slots for new-position = (posq name new-layout) when new-position do - (setf (instance-ref new-slots new-position) val)) + (setf (slot-ref new-slots new-position) val)) ;; Make the copy point to the old instance's storage, and make the ;; old instance point to the new storage. @@ -1359,16 +1404,16 @@ (new-class funcallable-standard-class) &rest initargs) (declare (ignore initargs)) - (error "Can't change the class of ~S to ~S~@ - because it isn't already an instance with metaclass ~S." + (error "~@<Can't change the class of ~S to ~S ~ + because it isn't already an instance with metaclass ~S.~@:>" instance new-class 'standard-class)) (defmethod change-class ((instance funcallable-standard-object) (new-class standard-class) &rest initargs) (declare (ignore initargs)) - (error "Can't change the class of ~S to ~S~@ - because it isn't already an instance with metaclass ~S." + (error "~@<Can't change the class of ~S to ~S ~ + because it isn't already an instance with metaclass ~S.~@:>" instance new-class 'funcallable-standard-class)) (defmethod change-class ((instance t) (new-class-name symbol) &rest initargs) @@ -1389,7 +1434,7 @@ (defmethod shared-initialize :before ((class built-in-class) slot-names &rest initargs) (declare (ignore slot-names initargs)) - (error "Attempt to initialize or reinitialize a built in class.")) + (error "Attempt to initialize or reinitialize a built-in class.")) (defmethod class-direct-slots ((class built-in-class)) ()) (defmethod class-slots ((class built-in-class)) ()) @@ -1397,7 +1442,8 @@ (defmethod class-default-initargs ((class built-in-class)) ()) (defmethod validate-superclass ((c class) (s built-in-class)) - (or (eq s *the-class-t*) (eq s *the-class-stream*))) + (or (eq s *the-class-t*) + (eq s *the-class-stream*))) @@ -1405,6 +1451,21 @@ ;;; ;;; +(macrolet ((frob (method) + `(defmethod ,method ((class forward-referenced-class)) + (declare (ignore class)) + ()))) + (frob class-direct-slots) + (frob class-direct-default-initargs)) + +(macrolet ((frob (method) + `(defmethod ,method ((class forward-referenced-class)) + (error "~@<~S called for forward referenced class ~S.~@:>" + ',method class)))) + (frob class-default-initargs) + (frob class-precedence-list) + (frob class-slots)) + (defmethod validate-superclass ((c slot-class) (f forward-referenced-class)) t) @@ -1425,3 +1486,23 @@ (dolist (dependent (plist-value metaobject 'dependents)) (funcall function dependent))) + +;;; +;;; Conditions +;;; +(defmethod shared-initialize :after ((class condition-class) slot-names + &key direct-superclasses) + (declare (ignore slot-names)) + (let ((kernel-class (kernel::find-class (class-name class)))) + (with-slots (wrapper class-precedence-list prototype predicate-name + (direct-supers direct-superclasses)) + class + (setf (kernel:%class-pcl-class kernel-class) class) + (setq direct-supers direct-superclasses) + (setq wrapper (kernel:%class-layout kernel-class)) + (setq class-precedence-list (compute-class-precedence-list class)) + (setq prototype (make-condition (class-name class))) + (add-direct-subclasses class direct-superclasses) + (setq predicate-name (make-class-predicate-name (class-name class))) + (make-class-predicate class predicate-name)))) + diff --git a/pcl/structure-class.lisp b/pcl/structure-class.lisp deleted file mode 100644 index c33722a5a..000000000 --- a/pcl/structure-class.lisp +++ /dev/null @@ -1,342 +0,0 @@ -;;;-*-Mode:LISP; Package:PCL; Base:10; Syntax:Common-lisp -*- -;;; -;;; ************************************************************************* -;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. -;;; All rights reserved. -;;; -;;; Use and copying of this software and preparation of derivative works -;;; based upon this software are permitted. Any distribution of this -;;; software or derivative works must comply with all applicable United -;;; States export control laws. -;;; -;;; This software is made available AS IS, and Xerox Corporation makes no -;;; warranty about the software, its performance or its conformity to any -;;; specification. -;;; -;;; Any person obtaining a copy of this software is requested to send their -;;; name and post office or electronic mail address to: -;;; CommonLoops Coordinator -;;; Xerox PARC -;;; 3333 Coyote Hill Rd. -;;; Palo Alto, CA 94304 -;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) -;;; -;;; Suggestions, comments and requests for improvements are also welcome. -;;; ************************************************************************* -;;; - -(ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/Attic/structure-class.lisp,v 1.4 2002/08/26 02:23:15 pmai Exp $") -;;; - -(in-package 'pcl) - -(defmethod initialize-internal-slot-functions :after - ((slotd structure-effective-slot-definition)) - (let ((name (slot-definition-name slotd))) - (initialize-internal-slot-reader-gfs name) - (initialize-internal-slot-writer-gfs name) - (initialize-internal-slot-boundp-gfs name))) - -(defmethod slot-definition-allocation ((slotd structure-slot-definition)) - :instance) - -(defmethod class-prototype ((class structure-class)) - (with-slots (prototype) class - (or prototype - (setq prototype (make-class-prototype class))))) - -(defmethod make-class-prototype ((class structure-class)) - (with-slots (wrapper defstruct-constructor) class - (if defstruct-constructor - (make-instance class) - (let* ((proto (%allocate-instance--class *empty-vector*))) - (shared-initialize proto T :check-initargs-legality-p NIL) - (setf (std-instance-wrapper proto) wrapper) - proto)))) - - -(defmethod make-direct-slotd ((class structure-class) - &rest initargs - &key - (name (error "Slot needs a name.")) - (conc-name (class-defstruct-conc-name class)) - (defstruct-accessor-symbol () acc-sym-p) - &allow-other-keys) - (declare (ignore defstruct-accessor-symbol)) - (declare (type symbol name) - (type simple-string conc-name)) - (let ((initargs (list* :class class :allow-other-keys T initargs))) - (unless acc-sym-p - (setf initargs - (list* :defstruct-accessor-symbol - (intern (concatenate 'simple-string conc-name (symbol-name name)) - (symbol-package (class-name class))) - initargs))) - (apply #'make-instance (direct-slot-definition-class class initargs) initargs))) - -(defun slot-definition-defstruct-slot-description (slot) - (let ((type (slot-definition-type slot))) - `(,(slot-definition-name slot) ,(slot-definition-initform slot) - ,@(unless (eq type t) `(:type ,type))))) - -(defmethod shared-initialize :after - ((class structure-class) - slot-names - &key (direct-superclasses nil direct-superclasses-p) - (direct-slots nil direct-slots-p) - direct-default-initargs - (predicate-name nil predicate-name-p)) - (declare (ignore slot-names direct-default-initargs)) - (let* ((name (class-name class)) - (from-defclass-p (slot-value class 'from-defclass-p)) - (defstruct-form (defstruct-form name)) - (conc-name - (or (if defstruct-form (defstruct-form-conc-name defstruct-form)) - (slot-value class 'defstruct-conc-name) - (format nil "~s structure class " name))) - (defstruct-predicate - (if defstruct-form (defstruct-form-predicate-name defstruct-form))) - (pred-name ;; Predicate name for class - (or (if predicate-name-p (car predicate-name)) - (if defstruct-form defstruct-predicate) - (slot-value class 'predicate-name) - (make-class-predicate-name name))) - (constructor - (or (if defstruct-form (defstruct-form-constructor defstruct-form)) - (slot-value class 'defstruct-constructor) - (if from-defclass-p - (list (intern (format nil "~aconstructor" conc-name) - (symbol-package name)) - ()))))) - (declare (type symbol name defstruct-predicate pred-name) - (type boolean from-defclass-p) - (type simple-string conc-name)) - (if direct-superclasses-p - (setf (slot-value class 'direct-superclasses) - (or direct-superclasses - (setq direct-superclasses - (if (eq name 'structure-object) - nil - (list *the-class-structure-object*))))) - (setq direct-superclasses (slot-value class 'direct-superclasses))) - (setq direct-slots - (if direct-slots-p - (setf (slot-value class 'direct-slots) - (mapcar (lambda (pl) - (apply #'make-direct-slotd class - :conc-name conc-name pl)) - direct-slots)) - (slot-value class 'direct-slots))) - (when from-defclass-p - (do-defstruct-from-defclass - class direct-superclasses direct-slots conc-name pred-name constructor)) - (compile-structure-class-internals - class direct-slots conc-name pred-name constructor) - (setf (slot-value class 'predicate-name) pred-name) - (setf (slot-value class 'defstruct-conc-name) conc-name) - (unless (extract-required-parameters (second constructor)) - (setf (slot-value class 'defstruct-constructor) (car constructor))) - (when (and defstruct-predicate (not from-defclass-p)) - (setf (symbol-function pred-name) (symbol-function defstruct-predicate))) - (unless (or from-defclass-p (slot-value class 'documentation)) - (setf (slot-value class 'documentation) - (format nil "~S structure class made from Defstruct" name))) - (setf (find-class name) class) - (update-structure-class class direct-superclasses direct-slots))) - -(defun update-structure-class (class direct-superclasses direct-slots) - (add-direct-subclasses class direct-superclasses) - (setf (slot-value class 'class-precedence-list) (compute-class-precedence-list class)) - (let* ((eslotds (compute-slots class)) - (internal-slotds (mapcar #'slot-definition-internal-slotd eslotds))) - (setf (slot-value class 'slots) eslotds) - (setf (slot-value class 'internal-slotds) internal-slotds) - (setf (slot-value class 'side-effect-internal-slotds) internal-slotds)) - (unless (slot-value class 'wrapper) - (setf (slot-value class 'finalized-p) T) - (setf (slot-value class 'wrapper) (make-wrapper class))) - (unless (slot-boundp class 'prototype) - (setf (slot-value class 'prototype) nil)) - (setf (slot-value class 'default-initargs) nil) - (add-slot-accessors class direct-slots)) - -(defmethod do-defstruct-from-defclass ((class structure-class) - direct-superclasses direct-slots - conc-name predicate constructor) - (declare (type simple-string conc-name)) - (let* ((name (class-name class)) - (original-defstruct-form - `(original-defstruct - (,name - ,@(when direct-superclasses - `((:include ,(class-name (car direct-superclasses))))) - (:print-function print-std-instance) - (:predicate ,predicate) - (:conc-name ,(intern conc-name (symbol-package name))) - (:constructor ,@constructor)) - ,@(mapcar #'slot-definition-defstruct-slot-description - direct-slots)))) - (eval original-defstruct-form) - (store-defstruct-form (cdr original-defstruct-form)))) - -(defmethod compile-structure-class-internals ((class structure-class) - direct-slots conc-name - predicate-name constructor) - (declare (type simple-string conc-name)) - (let* ((name (class-name class)) - (package (symbol-package name)) - (direct-slots-needing-internals - (if (slot-value class 'from-defclass-p) - direct-slots - (remove-if #'slot-definition-internal-reader-function - direct-slots))) - (reader-names - (mapcar (lambda (slotd) - (intern (format nil "~A~A reader" conc-name - (slot-definition-name slotd)) - package)) - direct-slots-needing-internals)) - (writer-names - (mapcar (lambda (slotd) - (intern (format nil "~A~A writer" conc-name - (slot-definition-name slotd)) - package)) - direct-slots-needing-internals)) - (defstruct-accessor-names - (mapcar #'slot-definition-defstruct-accessor-symbol - direct-slots-needing-internals)) - (readers-init - (mapcar (lambda (defstruct-accessor reader-name) - `(progn - (force-compile ',defstruct-accessor) - (defun ,reader-name (obj) - (declare (type ,name obj) #.*optimize-speed*) - (,defstruct-accessor obj)) - (force-compile ',reader-name))) - defstruct-accessor-names reader-names)) - (writers-init - (mapcar (lambda (defstruct-accessor writer-name) - `(progn - (force-compile ',defstruct-accessor) - (defun ,writer-name (nv obj) - (declare (type ,name obj) #.*optimize-speed*) - (setf (,defstruct-accessor obj) nv)) - (force-compile ',writer-name))) - defstruct-accessor-names writer-names)) - (defstruct-extras-form - `(progn - ,@(when (car constructor) - `((force-compile ',(car constructor)))) - ,@(when (fboundp predicate-name) - `((force-compile ',predicate-name))) - ,@readers-init - ,@writers-init))) - (declare (type package package)) - (eval defstruct-extras-form) - (mapc (lambda (dslotd reader-name writer-name) - (setf (slot-value dslotd 'internal-reader-function) - (gdefinition reader-name)) - (setf (slot-value dslotd 'internal-writer-function) - (gdefinition writer-name))) - direct-slots-needing-internals reader-names writer-names))) - -(defmethod reinitialize-instance :after ((class structure-class) - &rest initargs - &key) - (map-dependents class - (lambda (dependent) - (apply #'update-dependent class dependent initargs)))) - -(defmethod direct-slot-definition-class ((class structure-class) initargs) - (declare (ignore initargs)) - (find-class 'structure-direct-slot-definition)) - -(defmethod effective-slot-definition-class ((class structure-class) initargs) - (declare (ignore initargs)) - (find-class 'structure-effective-slot-definition)) - -(defmethod finalize-inheritance ((class structure-class)) - nil) ; always finalized - - -(defmethod compute-slots ((class structure-class)) - (mapcan (lambda (superclass) - (mapcar (lambda (dslotd) - (compute-effective-slot-definition - class (slot-definition-name dslotd) (list dslotd))) - (class-direct-slots superclass))) - (reverse (slot-value class 'class-precedence-list)))) - -(defmethod compute-slots :around ((class structure-class)) - (let ((eslotds (call-next-method))) - (mapc #'initialize-internal-slot-functions eslotds) - eslotds)) - -(defmethod compute-effective-slot-definition ((class structure-class) - name dslotds) - (let* ((initargs (compute-effective-slot-definition-initargs class dslotds)) - (class (effective-slot-definition-class class initargs)) - (slot-definition (apply #'make-instance class initargs)) - (internal-slotd - (make-internal-slotd - :name name - :slot-definition slot-definition - :initargs (slot-definition-initargs slot-definition) - :initfunction (slot-definition-initfunction slot-definition)))) - (setf (fast-slot-value slot-definition 'internal-slotd) internal-slotd) - slot-definition)) - -(defmethod compute-effective-slot-definition-initargs :around - ((class structure-class) direct-slotds) - (let ((slotd (car direct-slotds))) - (list* :defstruct-accessor-symbol (slot-definition-defstruct-accessor-symbol slotd) - :internal-reader-function (slot-definition-internal-reader-function slotd) - :internal-writer-function (slot-definition-internal-writer-function slotd) - (call-next-method)))) - - -(defmethod make-optimized-reader-method-function ((class structure-class) - generic-function - reader-method-prototype - slot-name) - (declare (ignore generic-function reader-method-prototype)) - (make-structure-instance-reader-method-function slot-name)) - -(defmethod make-optimized-writer-method-function ((class structure-class) - generic-function - writer-method-prototype - slot-name) - (declare (ignore generic-function writer-method-prototype)) - (make-structure-instance-writer-method-function slot-name)) - -(defmethod make-optimized-boundp-method-function ((class structure-class) - generic-function - boundp-method-prototype - slot-name) - (declare (ignore generic-function boundp-method-prototype)) - (make-structure-instance-boundp-method-function slot-name)) - - -(defun make-structure-instance-reader-method-function (slot-name) - (declare #.*optimize-speed*) - (lambda (instance) - (structure-instance-slot-value instance slot-name))) - -(defun make-structure-instance-writer-method-function (slot-name) - (declare #.*optimize-speed*) - (lambda (nv instance) - (setf (structure-instance-slot-value instance slot-name) nv))) - -(defun make-structure-instance-boundp-method-function (slot-name) - (declare #.*optimize-speed*) - (lambda (instance) - (structure-instance-slot-boundp instance slot-name))) - -(defmethod wrapper-fetcher ((class structure-class)) - 'wrapper-for-structure) - -(defmethod slots-fetcher ((class structure-class)) - NIL) - - diff --git a/pcl/user-instances.lisp b/pcl/user-instances.lisp deleted file mode 100644 index 0a3a701f9..000000000 --- a/pcl/user-instances.lisp +++ /dev/null @@ -1,688 +0,0 @@ -;;;-*-Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp; -*- - -;;; -;;; ************************************************************************* -;;; -;;; File: user-instances.lisp. -;;; -;;; by Trent E. Lange, Effective Date 06-02-92 -;;; -;;; -;;; This file contains a metaclass (User-Vector-Class) whose instances -;;; are stored as simple-vectors, saving space over PCL's standard instance -;;; representations of PCL at the cost of some class redefinition flexibiliity. -;;; -;;; Permission is granted to any individual or institution to use, copy, -;;; modify and distribute this document. -;;; -;;; Suggestions, bugs, criticism and questions to lange@cs.ucla.edu -;;; ************************************************************************* -;;; - -(ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/Attic/user-instances.lisp,v 1.6 2002/10/19 14:32:45 pmai Exp $") -;;; - -(in-package 'pcl) - -;;; This file builds on the PCL-USER-INSTANCES feature of July 92 PCL -;;; to define the USER-VECTOR-CLASS metaclass whose instances are simple -;;; vectors. The first element of the instance vector is the instance's -;;; class wrapper (providing internal PCL information about the instance's -;;; class). The remaining elements of the instance vector are the instance's -;;; slots themselves. -;;; -;;; The space overhead of user-vector-instances is only two vector cells -;;; (one for the vector, one for the wrapper). This is contrast to standard -;;; PCL instances, which have a total overhead of four cells. (Standard -;;; instances in PCL are represented as instances of structure STD-INSTANCE -;;; having two slots, one for the wrapper and one holding a simple-vector -;;; which is the instance's slots). This two-cell space savings per instance -;;; comes at the cost of losing some class redefinition flexibility, since -;;; simple-vectors cannot have their sizes changed dynamically. -;;; All current instances of user-instance-vectors therefore become -;;; permanently obsolete if the classes' instance slots change. -;;; -;;; This code requires July 92 PCL or later compiled with the -;;; PCL-USER-INSTANCES feature turned on (see PCL's low.lisp file). -;;; - -#-pcl-user-instances -(eval-when (:compile-toplevel :load-toplevel :execute) -(error "Cannot use user-instances, since PCL was compiled without - PCL-USER-INSTANCES on the *features* list (see pcl file low.lisp.)") -) - -(eval-when (:compile-toplevel :load-toplevel :execute) -(defclass user-vector-class-mixin () () - (:documentation - "Use this mixin for metaclasses whose instances are USER-INSTANCES - instantiated as simple-vectors. This saves space over the standard - instances used by standard-class, at the cost of losing the ability to - redefine the slots in a class and still have old instances updated correctly.")) - -(defclass user-vector-class (user-vector-class-mixin standard-class) () - (:documentation - "A metaclass whose instances are USER-INSTANCES instantiated as simple-vectors. - This saves space over the standard instances used by standard-class, at the - cost of losing the ability to redefine the slots in a class and still have old - instances updated correctly.")) - -(defmethod validate-superclass ((class user-vector-class-mixin) - (new-super T)) - (or (typep new-super 'user-vector-class-mixin) - (eq new-super (find-class 'standard-object)))) - -(defclass user-vector-object (standard-object) () - (:metaclass user-vector-class)) -) - -;;; -;;; -;;; Instance allocation stuff. -;;; - -(defmacro user-vector-instance-p (object) - (once-only (object) - `(the boolean - (and (simple-vector-p ,object) - (plusp (length (the simple-vector ,object))) - (wrapper-p (%svref ,object 0)))))) - -(defmacro user-vector-instance-wrapper (object) - `(%svref ,object 0)) - -(defsetf user-vector-instance-wrapper (object) (new-value) - `(setf (%svref ,object 0) ,new-value)) - -(defmacro user-vector-instance-slots (instance) - ;; The slots vector of user-vector instances is the instance itself. - instance) - -(defmacro set-user-vector-instance-slots (instance new-value) - `(progn - (warn "Attempt to set user-vector-instance-slots of ~S to ~S" - ,instance ,new-value) - ,new-value)) - -(defun user-instance-p (x) - "Is X a user instance, specifically a user-vector-instance?" - (user-vector-instance-p x)) - -(defun user-instance-slots (x) - "Return the slots of this user-vector-instance." - (user-vector-instance-slots x)) - -(defun user-instance-wrapper (x) - "Return the wrapper of this user-vector-instance." - (user-vector-instance-wrapper x)) - -(defun set-user-instance-wrapper (x new) - (setf (user-vector-instance-wrapper x) new)) - -(defmacro get-user-instance-p (x) - `(user-vector-instance-p ,x)) - -(defmacro get-user-instance-wrapper (x) - `(user-vector-instance-wrapper ,x)) - -(defmacro get-user-instance-slots (x) - `(user-vector-instance-slots ,x)) - -(eval-when (:execute :load-toplevel) - (force-compile 'user-instance-p) - (force-compile 'user-instance-slots) - (force-compile 'user-instance-wrapper) - (force-compile 'set-user-instance-wrapper)) - - -;;; -;;; Methods needed for user-vector-class-mixin. -;;; - -(defconstant *not-a-slot* (gensym "NOT-A-SLOT")) - -(defmethod allocate-instance ((class user-vector-class-mixin) &rest initargs) - (declare (ignore initargs)) - (unless (class-finalized-p class) (finalize-inheritance class)) - (let* ((class-wrapper (class-wrapper class)) - (copy-instance (wrapper-allocate-static-slot-storage-copy - class-wrapper)) - (instance (copy-simple-vector copy-instance))) - (declare (type simple-vector copy-instance instance)) - (setf (user-vector-instance-wrapper instance) class-wrapper) - instance)) - -(defmethod make-instances-obsolete ((class user-vector-class-mixin)) - "The slots of user-vector-instances are stored in the instance vector - themselves (a simple-vector), so old instances cannot be updated properly." - (setf (slot-value class 'prototype) NIL) - (warn "Obsoleting user-vector class ~A, all current instances will be invalid..." - class)) - -(defmethod compute-layout :around ((class user-vector-class-mixin) - cpl instance-eslotds) - ;; First element of user-vector-instance is actually its wrapper. - (declare (ignore cpl instance-eslotds)) - (cons *not-a-slot* (call-next-method))) - -(defmethod compute-instance-layout :around ((class user-vector-class-mixin) - instance-eslotds) - ;; First element of user-vector-instance is actually its wrapper. - (declare (ignore instance-eslotds)) - (cons *not-a-slot* (call-next-method))) - -(defmethod wrapper-fetcher ((class user-vector-class-mixin)) - 'user-vector-instance-wrapper) - -(defmethod slots-fetcher ((class user-vector-class-mixin)) - 'user-vector-instance-slots) - -(defmethod raw-instance-allocator ((class user-vector-class-mixin)) - 'allocate-user-vector-instance) - - -;;; -;;; The following functions and methods are not strictly necessary for -;;; user-vector-instances, but do speed things up a bit. -;;; - -;;; Inform PCL that it is still safe to use its standard slot-value -;;; optimizations with user-vector-class-mixin's slot-value-using-class -;;; methods: - -(pushnew - '(user-vector-class-mixin standard-object standard-effective-slot-definition) - *safe-slot-value-using-class-specializers*) - -(pushnew - '(T user-vector-class-mixin standard-object standard-effective-slot-definition) - *safe-set-slot-value-using-class-specializers*) - -(pushnew - '(user-vector-class-mixin standard-object standard-effective-slot-definition) - *safe-slot-boundp-using-class-specializers*) - -(defmethod slot-value-using-class - ((class user-vector-class-mixin) - (object standard-object) - (slotd standard-effective-slot-definition)) - (let* ((location (slot-definition-location slotd)) - (value - (typecase location - (fixnum - (%svref (user-vector-instance-slots object) location)) - (cons - (cdr location)) - (t - (error - "The slot ~s has neither :instance nor :class allocation, ~@ - so it can't be read by the default ~s method." - slotd 'slot-value-using-class))))) - (if (eq value +slot-unbound+) - (slot-unbound class object (slot-definition-name slotd)) - value))) - -(defmethod (setf slot-value-using-class) - (new-value (class user-vector-class-mixin) - (object standard-object) - (slotd standard-effective-slot-definition)) - (let ((location (slot-definition-location slotd))) - (typecase location - (fixnum - (setf (%svref (user-vector-instance-slots object) location) new-value)) - (cons - (setf (cdr location) new-value)) - (t - (error "The slot ~s has neither :instance nor :class allocation, ~@ - so it can't be written by the default ~s method." - slotd '(setf slot-value-using-class)))))) - -(defmethod slot-boundp-using-class - ((class user-vector-class-mixin) - (object standard-object) - (slotd standard-effective-slot-definition)) - (let* ((location (slot-definition-location slotd)) - (value - (typecase location - (fixnum - (%svref (user-vector-instance-slots object) location)) - (cons - (cdr location)) - (t - (error - "The slot ~s has neither :instance nor :class allocation, ~@ - so it can't be read by the default ~s method." - slotd 'slot-boundp-using-class))))) - (not (eq value +slot-unbound+)))) - - - -(defmethod make-optimized-reader-method-function - ((class user-vector-class-mixin) - generic-function - reader-method-prototype - slot-name) - (declare (ignore generic-function reader-method-prototype)) - (make-user-vector-instance-reader-method-function slot-name)) - -(defmethod make-optimized-writer-method-function - ((class user-vector-class-mixin) - generic-function - reader-method-prototype - slot-name) - (declare (ignore generic-function reader-method-prototype)) - (make-user-vector-instance-writer-method-function slot-name)) - -(defmethod make-optimized-method-function - ((class user-vector-class-mixin) - generic-function - boundp-method-prototype - slot-name) - (declare (ignore generic-function boundp-method-prototype)) - (make-user-vector-instance-boundp-method-function slot-name)) - -(defun make-user-vector-instance-reader-method-function (slot-name) - (declare #.*optimize-speed*) - (lambda (instance) - (user-instance-slot-value instance slot-name))) - -(defun make-user-vector-instance-writer-method-function (slot-name) - (declare #.*optimize-speed*) - (lambda (nv instance) - (setf (user-instance-slot-value instance slot-name) nv))) - -(defun make-user-vector-instance-boundp-method-function (slot-name) - (declare #.*optimize-speed*) - (lambda (instance) - (user-instance-slot-boundp instance slot-name))) - - -(defun make-optimized-user-reader-method-function (slot-name index) - (declare #.*optimize-speed*) - (progn slot-name) - (lambda (instance) - (let ((value (%svref (user-vector-instance-slots instance) index))) - (if (eq value +slot-unbound+) - (slot-unbound (class-of instance) instance slot-name) - value)))) - -(defun make-optimized-user-writer-method-function (index) - (declare #.*optimize-speed*) - (lambda (nv instance) - (setf (%svref (user-vector-instance-slots instance) index) nv))) - -(defun make-optimized-user-boundp-method-function (index) - (declare #.*optimize-speed*) - (lambda (instance) - (not (eq (%svref (user-vector-instance-slots instance) index) - +slot-unbound+)))) - - - -(defmacro with-user-instance-slots (slot-entries instance-form &body body) - "Optimized version of With-Slots that assumes that the instance-form - evaluates to a user-vector-instance. The result is undefined if it does not. - With-user-vector-instance-slots is faster than With-Slots because it factors - out functions common to all slot accesses on the instance. It has two - extensions to With-Slots: (1) the second value of slot-entries are - evaluated as forms rather than considered to be hard slot-names, allowing - access of variable slot-names. (2) if a :variable-instance keyword is - the first part of the body, then the instance-form is treated as a variable - form, which is always expected to return an instance of the same class. - The value of the keyword must be an instance that is the same class as - instance-form will always return." - (build-with-optimized-slots-form slot-entries instance-form body 'user-instance)) - - - -;;; -;;; Lisp and CLOS print compatability functions: -;;; -;;; This gets really ugly because most lisps don't use PRINT-OBJECT -;;; for the printed representation of their objects like they're supposed -;;; to. (And if the lisp did, it wouldn't be using PCL.). And since -;;; user-vector-instances are implemented as simple-vectors, the only -;;; way to get their printed representations to look right is to make -;;; PRINT-OBJECT object to work. -;;; We therefore have to patch the standard lisp printing functions. -;;; If all goes well, then everything is honky-dory. If it doesn't, then -;;; debugging can get pretty messy since we were screwing with the standard -;;; printing functions. Things should work, but if they don't, then calling -;;; RESTORE-LISP-PRINTERS will get things back to normal. - -(defvar *old-write* NIL) -(defvar *old-princ* NIL) -(defvar *old-prin1* NIL) -(defvar *old-print* NIL) - -;; Structure dummy-print-instance is a structure whose sole purpose -;; in life is to act as a placeholder to allow the print-object of -;; user-vector-class objects to be printed. - -(defstruct (dummy-print-instance - (:print-function print-dummy-print-instance)) - (print-object-string nil)) - -(declaim (type list *dummy-print-instance-garbage*)) -(defvar *dummy-print-instance-garbage* NIL) -(defconstant *dummy-print-instance-garbage-limit* 100) - -(defmacro pure-array-p (x &optional (test-user-vector-instance-p T)) - "Returns whether item is a 'pure' array -- i.e. not a string, and - not something holding a CLOS instance." - (once-only (x) - `(the boolean - (locally (declare (inline arrayp stringp typep)) - (and (arrayp ,x) - (not (stringp ,x)) - #-(or cmu (and lucid pcl)) - (not (typep ,x 'structure)) - ,@(when test-user-vector-instance-p - `((not (user-vector-instance-p ,x)))) - #-(or cmu (and lucid pcl)) - (not (typep ,x 'standard-object))))))) - -(defun copy-any-array (old-array &rest keys-passed &key key dimensions) - ;; Returns a copy of old-array. If :key is provided, then the - ;; elements of the new-array are the result of key applied to - ;; old-array's elements. If :dimensions is provided, and it is - ;; different than old-array's dimensions, then the new-array is created - ;; with those dimensions, and everything that can be copied from - ;; old-array is copied into it. It is an error if the rank of - ;; the array specified by dimensionss is different than that of the - ;; old-array. - (declare (type array old-array) - (type (or function null) key) - (type list dimensions keys-passed)) - (cond - ((simple-vector-p old-array) - (apply #'copy-array-contents - old-array - (make-array (the index - (if dimensions - (car dimensions) - (length (the simple-vector old-array))))) - keys-passed)) - ((vectorp old-array) - (apply #'copy-array-contents - old-array - (make-array (the index - (if dimensions - (car dimensions) - (length (the vector old-array)))) - :element-type (array-element-type old-array) - :adjustable (adjustable-array-p old-array)) - keys-passed)) - ((arrayp old-array) - (let* ((old-dimensions (array-dimensions old-array)) - (new-dimensions (or dimensions old-dimensions)) - (element-type (array-element-type old-array)) - (new-array - (make-array new-dimensions - :element-type element-type - :adjustable (adjustable-array-p old-array)))) - (declare (type list old-dimensions new-dimensions) - (type array new-array)) - (if (or (null dimensions) (equal new-dimensions old-dimensions)) - (let* ((displaced-old-array - (make-array (array-total-size old-array) - :element-type element-type - :displaced-to old-array)) - (displaced-new-array - (make-array (array-total-size new-array) - :element-type element-type - :displaced-to new-array))) - (declare (type array displaced-old-array displaced-new-array)) - (copy-array-contents displaced-old-array - displaced-new-array - :key key)) - (let ((first-dimension - (min (the index (car new-dimensions)) - (the index (car old-dimensions))))) - (declare (type index first-dimension)) - (walk-dimensions - (mapcar #'min (cdr new-dimensions) (cdr old-dimensions)) - (lambda (post-indices) - (copy-array-contents old-array new-array - :key key - :length first-dimension - :post-indices post-indices))))) - new-array)))) - -(defun copy-array-contents - (old-array new-array &key key length post-indices &allow-other-keys) - ;; Copies the contents of old-array into new-array, using key if - ;; supplied. Only the first :length items are copied (defaulting - ;; to the length of the old-array). If :post-indices are passed, then - ;; they are used as "post" indices to an aref. - (macrolet - ((do-copy (aref old new key key-type len post-indices) - (let ((atype (if (eq aref #'svref) 'simple-vector 'array))) - `(dotimes (i (the index ,len)) - (setf ,(if post-indices - `(apply #'aref (the ,atype ,new) i ,post-indices) - `(,aref (the ,atype ,new) i)) - ,(if key-type - `(funcall - (the ,key-type ,key) - ,(if post-indices - `(apply #'aref (the ,atype ,old) - i ,post-indices) - `(,aref (the ,atype ,old) i))) - (if post-indices - `(apply #'aref (the ,atype ,old) i ,post-indices) - `(,aref (the ,atype ,old) i))))))) - (expand-on-key (aref key old new len post-ind) - `(cond - ((null ,key) - (do-copy ,aref ,old ,new ,key NIL ,len ,post-ind)) - ((compiled-function-p ,key) - (do-copy ,aref ,old ,new ,key compiled-function ,len ,post-ind)) - (T - (do-copy ,aref ,old ,new ,key function ,len ,post-ind))))) - (if (simple-vector-p old-array) - (progn - (when post-indices - (error "Can't pass post-indices given to COPY-ARRAY-CONTENTS - from simple-vector")) - - (unless length - (setf length (min (length (the simple-vector old-array)) - (length (the simple-vector new-array))))) - (expand-on-key svref key old-array new-array length NIL)) - (progn - (unless length - (setf length (min (the index (car (array-dimensions old-array))) - (the index (car (array-dimensions new-array)))))) - (if post-indices - (expand-on-key #'aref key old-array new-array length post-indices) - (expand-on-key aref key old-array new-array length NIL))))) - new-array) - -(declaim (ftype (function (list function) T) walk-dimensions)) -(defun walk-dimensions (dimensions fn) - (declare (type list dimensions) - (type function fn)) - ;; Given a list of dimensions (e.g. '(3 2 8)), this function walks - ;; through every possible combination from 0 to 1- each of those - ;; dimensions, and calling fn on each of them. - (let ((compiled-p (compiled-function-p fn))) - (labels - ((doit (dims apply-dims) - (declare (type list dims apply-dims)) - (if (cdr dims) - (let ((last-dim NIL) - (dims-left NIL)) - (loop (when (null (cdr dims)) - (setf last-dim (car dims)) - (return)) - (if dims-left - (nconc dims-left (list (car dims))) - (setf dims-left (list (car dims)))) - (setf dims (cdr dims))) - (dotimes (i (the index last-dim)) - (doit dims-left (cons i apply-dims)))) - (if compiled-p - (dotimes (i (the index (car dims))) - (funcall (the compiled-function fn) (cons i apply-dims))) - (dotimes (i (the index (car dims))) - (funcall fn (cons i apply-dims))))))) - (doit dimensions NIL)))) - -(defmacro funcall-printer (applyer print-function object keys) - `(progn - (if (or (arrayp ,object) (consp ,object)) - (multiple-value-bind (converted-item garbage) - (convert-user-vector-instances-to-dummy-print-instances ,object) - (,applyer (the compiled-function ,print-function) - converted-item ,keys) - (deallocate-dummy-print-instances garbage)) - (,applyer (the compiled-function ,print-function) - ,object ,keys)) - ,object)) - -(defun print-dummy-print-instance (instance stream depth) - (declare (ignore depth)) - (let ((*print-pretty* NIL)) - (funcall (the compiled-function *old-princ*) - (dummy-print-instance-print-object-string instance) - stream))) - -(defun allocate-dummy-print-instance (print-object-string) - (if *dummy-print-instance-garbage* - (let ((instance (pop *dummy-print-instance-garbage*))) - (setf (dummy-print-instance-print-object-string instance) - print-object-string) - instance) - (make-dummy-print-instance :print-object-string print-object-string))) - -(defun dummy-print-instance-of (user-vector-instance) - (allocate-dummy-print-instance - (with-output-to-string (str) - (print-object user-vector-instance str)))) - -(defun deallocate-dummy-print-instances (dummies) - (let ((count (length *dummy-print-instance-garbage*))) - (declare (type index count)) - (dolist (dummy dummies) - (when (> count *dummy-print-instance-garbage-limit*) - (return)) - (push dummy *dummy-print-instance-garbage*) - (setf count (the index (1+ count)))))) - -(defun convert-user-vector-instances-to-dummy-print-instances (item) - (let ((print-length - (or *print-length* 1000)) - (print-level - (or *print-level* 1000)) - (dummy-print-instances-used NIL)) - (declare (fixnum print-length print-level)) - (labels - ((doit (item level length) - (declare (fixnum level length)) - (labels - ((user-vector-instance-visible-within-p (item level length) - (declare (fixnum level length)) - (cond - ((>= length print-length) NIL) - ((> level print-level) NIL) - ((= level print-level) (user-vector-instance-p item)) - (T (cond - ((user-vector-instance-p item) T) - ((consp item) - (or (user-vector-instance-visible-within-p - (car item) (the fixnum (1+ level)) 0) - (user-vector-instance-visible-within-p - (cdr item) level (the fixnum (1+ length))))) - ((and *print-array* (pure-array-p item)) - (let ((next-level (the fixnum (1+ level)))) - (declare (fixnum next-level)) - (dotimes (i (1- (length (the array item))) NIL) - (unless (< i print-length) - (return NIL)) - (if (user-vector-instance-visible-within-p - (aref item i) next-level 0) - (return T)))))))))) - ;; doit body - (cond - ((user-vector-instance-p item) - (let ((dummy (dummy-print-instance-of item))) - (push dummy dummy-print-instances-used) - dummy)) - ((consp item) - (if (user-vector-instance-visible-within-p item level length) - (cons (doit (car item) (the fixnum (1+ level)) length) - (doit (cdr item) level (the fixnum (1+ length)))) - item)) - ((and *print-array* (pure-array-p item NIL)) - (if (user-vector-instance-visible-within-p item level length) - (copy-any-array - item - :key - (lambda (item) - (if (user-vector-instance-p item) - (let ((dummy (dummy-print-instance-of item))) - (push dummy dummy-print-instances-used) - dummy) - item)) - :dimensions - (mapcar #'1+ (array-dimensions item))) - item)) - (T item))))) - - ;; convert-user-vector-instances-to-dummy-print-instances body - - (let ((converted (doit item 0 0))) - (values converted dummy-print-instances-used))))) - -(force-compile 'convert-user-vector-instances-to-dummy-print-instances) - -(unless *old-write* (setf *old-write* (symbol-function 'write))) -(defun new-write (object &rest keys-passed) - (declare (list keys-passed)) - (funcall-printer apply *old-write* object keys-passed)) -(force-compile 'write) -(setf (symbol-function 'write) (symbol-function 'new-write)) - -(unless *old-princ* (setf *old-princ* (symbol-function 'princ))) -(defun princ (object &optional stream) - (funcall-printer funcall *old-princ* object stream)) -(force-compile 'princ) - -(unless *old-prin1* (setf *old-prin1* (symbol-function 'prin1))) -(defun prin1 (object &optional stream) - (funcall-printer funcall *old-prin1* object stream)) -(force-compile 'prin1) - -(unless *old-print* (setf *old-print* (symbol-function 'print))) -(defun print (object &optional stream) - (funcall-printer funcall *old-print* object stream)) -(force-compile 'print) - -(defun new-write-to-string (object &rest keys-passed) - (declare (list keys-passed)) - (with-output-to-string (string-stream) - (apply #'write object :stream string-stream keys-passed))) -(force-compile 'write-to-string) -(setf (symbol-function 'write-to-string) - (symbol-function 'new-write-to-string)) - -(defun princ-to-string (object) - (with-output-to-string (string-stream) - (funcall-printer funcall *old-princ* object string-stream) - string-stream)) -(force-compile 'princ-to-string) - -(defun prin1-to-string (object) - (with-output-to-string (string-stream) - (funcall-printer funcall *old-prin1* object string-stream) - string-stream)) -(force-compile 'prin1-to-string) - -(defun restore-lisp-printers () - (setf (symbol-function 'write) *old-write*) - (setf (symbol-function 'princ) *old-princ*) - (setf (symbol-function 'prin1) *old-prin1*) - (setf (symbol-function 'print) *old-print*)) - diff --git a/pcl/vector.lisp b/pcl/vector.lisp index 8238fd8c7..388aa0537 100644 --- a/pcl/vector.lisp +++ b/pcl/vector.lisp @@ -26,742 +26,529 @@ ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/vector.lisp,v 1.26 2002/12/18 16:29:07 pmai Exp $") -;;; -;;; Permutation vectors. -;;; + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/vector.lisp,v 1.27 2003/03/22 16:15:15 gerd Exp $") (in-package :pcl) -(defmacro instance-slot-index (wrapper slot-name) - `(let ((pos 0)) - (declare (fixnum pos)) - (block loop - (dolist (sn (wrapper-instance-slots-layout ,wrapper)) - (when (eq ,slot-name sn) (return-from loop pos)) - (incf pos))))) - - ;;; +;;; Return the index of the slot named SLOT-NAME in the slot vector of +;;; instances whose wrapper is WRAPPER. ;;; -;;; -(defun pv-cache-limit-fn (nlines) - (default-limit-fn nlines)) +(declaim (inline instance-slot-index)) + +(defun instance-slot-index (wrapper slot-name) + (loop for name in (wrapper-instance-slots-layout wrapper) + for index of-type fixnum from 0 + when (eq slot-name name) + return index)) -(defstruct (pv-table - (:predicate pv-tablep) - (:constructor make-pv-table-internal - (slot-name-lists call-list))) + +(deftype pv-index () `(integer 0 ,most-positive-fixnum)) +(deftype param-index () `(integer 0 ,most-positive-fixnum)) + +(defstruct pv-table + ;; + ;; This cache maps N wrappers, one for each required method + ;; parameter for which PV optimization has been done, to a pair (PV + ;; . CALLS). + ;; + ;; PV is a "permutation vector" of size PV-SIZE (see below). Each + ;; slot name (and (READER <gf-name>) or (WRITER <gf-name>)) used in + ;; an pv optimization is assigned an index in this vector. For + ;; instance slots, the value of PV at that index is a fixnum, the + ;; index the slot's value an instance's slot value vector. For + ;; class slots, the PV slot contains the cons cell of the class + ;; slot. If the PV contains neither a fixnum nor a cons, the PV + ;; optimization code executes a default form. + ;; + ;; CALLS is currently not used. (cache nil :type (or cache null)) + ;; + ;; Size of permutation vectors in this table. This is 1+ the + ;; highest slot pv index (see below). (pv-size 0 :type fixnum) + ;; + ;; This list has an entry for each required parameter of the + ;; pv-table's method. List element at index K corresponds to the + ;; Kth parameter P_k. Entries for parameters for which no + ;; pv-optimization has been done are NIL. Other entries have the + ;; form (NIL SLOT-NAME SLOT-NAME ...) where each SLOT-NAME is + ;; either + ;; + ;; -- the name of a slot used in a pv-optimization involving P_k + ;; (that is, say, (SLOT-VALUE P_k SLOT-NAME) has been optimized). + ;; + ;; -- a list (READER <gf-name>) or (WRITER <gf-name>), meaning that + ;; a slot reader/writer call has been pv-optimized, say (GF-NAME P_k). + ;; GF-NAME is the name of the slot accessor generic function. + ;; + ;; A T in the car of an parameter entry means that the corresponding + ;; method parameter is used in a generic function call optimization. + ;; + ;; Each SLOT-NAME has a "pv-index" >= 0 assigned to it, which is the + ;; index in permutation vectors of this pv-table, under which the + ;; pv-value (fixnum, cons, or nil) for the slot name is found. (slot-name-lists nil :type list) - (call-list nil :type list)) + ;; + ;; Contains elements (GF-NAME i0 i1 ...), for each generic function + ;; call optimized. GF-NAME is the name of the generic function + ;; called; iN is the index of the method parameter passed as + ;; argument N to the generic function. Only method parameters used + ;; in pv-optimization are counted, that is, the indices give the + ;; index in the wrappers kept in the cache. + (call-list nil :type list) + ;; + ;; This is set to T while computing calls. The slot is needed to + ;; prevent GET-METHOD-FUNCTION from using PV-TABLE-LOOKUP to determine + ;; a pv cell when GET-METHOD-FUNCTION is actually called while computing + ;; the pv-table cache. + (computing-cache-p nil :type boolean)) (declaim (ext:freeze-type pv-table)) -(defvar *initial-pv-table* (make-pv-table-internal nil nil)) - -; help new slot-value-using-class methods affect fast iv access -(defvar *all-pv-table-list* nil) + +;;; +;;; Hash-table mapping slot name lists and call lists to canonical +;;; representations. +;;; +(defvar *calls+snls->canonical* (make-hash-table :test 'equal)) -(defun make-pv-table (&key slot-name-lists call-list) - (let ((pv-table (make-pv-table-internal slot-name-lists call-list))) - (push pv-table *all-pv-table-list*) - pv-table)) +;;; +;;; Hash-table mapping a list of calls + slot name lists to a +;;; corresponding PV-TABLE for it. +;;; +(defvar *calls+snls->pv-table* (make-hash-table :test 'equal)) -(defun make-pv-table-type-declaration (var) - `(type pv-table ,var)) +;;; +;;; Values are lists of pv-tables. Keys are slot names or (READER +;;; <gf-name>), (WRITER <gf-name>), or (CALL <gf-name>). Each +;;; pv-table is one containing the key in one of its slot name lists, +;;; or, for CALL, having <gf-name> in its call-list. +;;; +(defvar *pv-key->pv-tables* (make-hash-table :test 'equal)) -(defvar *slot-name-lists-inner* (make-hash-table :test #'equal)) -(defvar *slot-name-lists-outer* (make-hash-table :test #'equal)) +;;; +;;; Execute BODY for all slot-names, (READER <gf-name>) etc. of +;;; TABLE. Bind KEY to the key in question, INDEX to its index +;;; in permutation vectors of TABLE, PARAM-INDEX to the method +;;; parameter number of the key. +;;; +(defmacro do-pv-slots ((key param-index index table) &body body) + (let ((snl (gensym))) + `(loop with ,index of-type pv-index = 0 + for ,param-index of-type param-index from 0 + for ,snl in (pv-table-slot-name-lists ,table) do + (loop for ,key in (cdr ,snl) do + (locally ,@body) + (incf ,index))))) -;entries in this are lists of (table . pv-offset-list) -(defvar *pv-key-to-pv-table-table* (make-hash-table :test 'equal)) +;;; +;;; Execute BODY for all calls of table, binding INDEX to pv +;;; indices of the calls. +;;; +(defmacro do-pv-calls ((call index table) &body body) + `(loop for ,index of-type pv-index from 0 + for ,call in (pv-table-call-list ,table) do + (locally ,@body))) +;;; +;;; Return a PV-TABLE for the given SLOT-NAME-LISTS and CALL-LIST. +;;; If such a table already exists, return that. Otherwise make +;;; a new one. +;;; (defun intern-pv-table (&key slot-name-lists call-list) (let ((new-p nil)) - (flet ((inner (x) - (or (gethash x *slot-name-lists-inner*) - (setf (gethash x *slot-name-lists-inner*) (copy-list x)))) - (outer (x) - (or (gethash x *slot-name-lists-outer*) - (setf (gethash x *slot-name-lists-outer*) + (flet (;; + ;; Map calls or slot name list X to a canonical form. + (make-key (x) + (or (gethash x *calls+snls->canonical*) + (setf (gethash x *calls+snls->canonical*) + (copy-list x)))) + ;; + ;; Lookup pv-table for calls + slots in X. Add a new + ;; entry and create a new pv-table if not found. + (lookup (x) + (or (gethash x *calls+snls->pv-table*) + (setf (gethash x *calls+snls->pv-table*) (let ((snl (copy-list (cdr x))) (cl (car x))) (setq new-p t) (make-pv-table :slot-name-lists snl :call-list cl)))))) - (let ((pv-table (outer (mapcar #'inner (cons call-list slot-name-lists))))) + (let ((table (lookup (mapcar #'make-key + (cons call-list slot-name-lists))))) + ;; + ;; When a new pv table has been created, record which keys + ;; (slot-names, (reader <gf-name>), etc.) it uses and which + ;; permutation vectors indices these keys are associated with. (when new-p - (let ((pv-index 1)) - (dolist (slot-name-list slot-name-lists) - (dolist (slot-name (cdr slot-name-list)) - (note-pv-table-reference slot-name pv-index pv-table) - (incf pv-index))) - (dolist (gf-call call-list) - (note-pv-table-reference gf-call pv-index pv-table) - (incf pv-index)) - (setf (pv-table-pv-size pv-table) pv-index))) - pv-table)))) - -(defun note-pv-table-reference (ref pv-offset pv-table) - (let ((entry (gethash ref *pv-key-to-pv-table-table*))) - (when (listp entry) - (let ((table-entry (assq pv-table entry))) - (when (and (null table-entry) - (> (length entry) 8)) - (let ((new-table-table (make-hash-table :size 16 :test 'eq))) - (dolist (table-entry entry) - (setf (gethash (car table-entry) new-table-table) - (cdr table-entry))) - (setf (gethash ref *pv-key-to-pv-table-table*) new-table-table) - (setq entry new-table-table))) - (when (listp entry) - (if (null table-entry) - (let ((new (cons pv-table pv-offset))) - (if (consp entry) - (push new (cdr entry)) - (setf (gethash ref *pv-key-to-pv-table-table*) (list new)))) - (push pv-offset (cdr table-entry))) - (return-from note-pv-table-reference nil)))) - (let ((list (gethash pv-table entry))) - (if (consp list) - (push pv-offset (cdr list)) - (setf (gethash pv-table entry) (list pv-offset))))) - nil) - -(defun map-pv-table-references-of (ref function) - (let ((entry (gethash ref *pv-key-to-pv-table-table*))) - (if (listp entry) - (dolist (table+pv-offset-list entry) - (funcall function - (car table+pv-offset-list) (cdr table+pv-offset-list))) - (maphash function entry))) - ref) - - -(defvar *pvs* (make-hash-table :test #'equal)) - -(defun optimize-slot-value-by-class-p (class slot-name type) - (or (not (eq *boot-state* 'complete)) - (let ((slotd (find-slot-definition class slot-name))) - (and slotd - (slot-accessor-std-p slotd type))))) - -(defun compute-pv-slot (slot-name wrapper class class-slots class-slot-p-cell) - (if (symbolp slot-name) - (when (optimize-slot-value-by-class-p class slot-name 'all) - (or (instance-slot-index wrapper slot-name) - (let ((cell (assq slot-name class-slots))) - (when cell - (setf (car class-slot-p-cell) t) - cell)))) - (when (consp slot-name) - (dolist (type '(reader writer) nil) - (when (eq (car slot-name) type) - (return - (let* ((gf-name (cadr slot-name)) - (gf (gdefinition gf-name)) - (location - (when (eq *boot-state* 'complete) - (accessor-values1 gf type class)))) - (when (consp location) - (setf (car class-slot-p-cell) t)) - location))))))) - -(defun compute-pv (slot-name-lists wrappers) - (let* ((not-simple-p-cell (list nil)) - (elements - (loop with wrappers = (if (listp wrappers) wrappers (list wrappers)) - for slot-names in slot-name-lists - when slot-names - nconc (loop with wrapper = (pop wrappers) - with stdp = (typep wrapper 'wrapper) - and class = (wrapper-class* wrapper) - with class-slots - = (and stdp (wrapper-class-slots wrapper)) - for slot-name in (cdr slot-names) - collect - (when stdp - (compute-pv-slot slot-name wrapper class - class-slots - not-simple-p-cell)))))) - (if (car not-simple-p-cell) - (make-permutation-vector (cons t elements)) - (or (gethash elements *pvs*) - (setf (gethash elements *pvs*) - (make-permutation-vector (cons nil elements))))))) + (let ((last-index -1)) + (do-pv-slots (key param index table) + (setq last-index index) + (note-pv-table-reference key table)) + (setf (pv-table-pv-size table) (1+ last-index))) + (do-pv-calls (call index table) + (note-pv-table-reference `(call ,(car call)) table))) + ;; + table)))) -(defun compute-calls (call-list wrappers) - (declare (ignore call-list wrappers)) - #|| - (map 'vector - (lambda (call) - (compute-emf-from-wrappers call wrappers)) - call-list) - ||# - '#()) +;;; +;;; Record that REF is referenced from PV-TABLE. REF can be the name +;;; of a slot, (READER <gf-name>), (WRITER <gf-name>), or (CALL +;;; <gf-name>). +;;; +(defun note-pv-table-reference (ref pv-table) + (push pv-table (gethash ref *pv-key->pv-tables*))) -#|| ; Need to finish this, then write the maintenance functions. -(defun compute-emf-from-wrappers (call wrappers) - (when call - (destructuring-bind (gf-name nreq restp arg-info) call - (if (eq gf-name 'make-instance) - (error "should not get here") ; there is another mechanism for this. - (lambda (&rest args) - (if (not (eq *boot-state* 'complete)) - (apply (gdefinition gf-name) args) - (let* ((gf (gdefinition gf-name)) - (arg-info (arg-info-reader gf)) - (classes '?) - (types '?) - (emf (cache-miss-values-internal gf arg-info - wrappers classes types - 'caching))) - (update-all-pv-tables call wrappers emf) - (invoke-emf emf args)))))))) -||# +;;; +;;; Execute BODY for all pv tables using KEY. Bind TABLE to the pv +;;; table around BODY. +;;; +(defmacro do-pv-tables ((table key) &body body) + `(loop for ,table in (gethash ,key *pv-key->pv-tables*) do + (locally ,@body))) -(defun make-permutation-vector (indexes) - (make-array (length indexes) :initial-contents indexes)) + -(defun pv-table-lookup (pv-table pv-wrappers) - (let* ((slot-name-lists (pv-table-slot-name-lists pv-table)) - (call-list (pv-table-call-list pv-table)) - (cache (or (pv-table-cache pv-table) - (setf (pv-table-cache pv-table) - (get-cache (- (length slot-name-lists) - (count nil slot-name-lists)) - t - #'pv-cache-limit-fn - 2))))) - (or (probe-cache cache pv-wrappers) - (let* ((pv (compute-pv slot-name-lists pv-wrappers)) - (calls (compute-calls call-list pv-wrappers)) - (pv-cell (cons pv calls)) - (new-cache (fill-cache cache pv-wrappers pv-cell))) - (unless (eq new-cache cache) - (setf (pv-table-cache pv-table) new-cache)) - pv-cell)))) -(defun make-pv-type-declaration (var) - `(type simple-vector ,var)) +;;; +;;; Return the permutation vector value for SLOT-NAME in instances +;;; having WRAPPER layout. CLASS is the class of the instance, +;;; CLASS-SLOTS is the list of class slots of CLASS. +;;; +;;; SLOT-NAME can be a symbol or a cons. If it is a symbol, it names +;;; an instance or class slot. If it is a cons (READER gf) or (WRITER +;;; gf), this signals that a call to the slot accessor generic +;;; function gf has been PV-optimized. +;;; +;;; First value is the permutation vector value for SLOT-NAME; +;;; a fixnum for an optimized instance slot, a cons for an optimized +;;; class slot, or NIL for "not optimized". +;;; +;;; Second value is T for an optimized class slot. +;;; +(defun compute-pv-slot (key wrapper class class-slots) + (etypecase key + (symbol + (when (optimize-slot-value-by-class-p class key 'all) + (or (instance-slot-index wrapper key) + (assq key class-slots)))) + (cons + (ecase (first key) + ((reader writer) + (when (eq *boot-state* 'complete) + (let ((gf (gdefinition (second key)))) + (when (generic-function-p gf) + (accessor-values1 gf (first key) class))))) + (inline-access + nil))))) -(defvar *empty-pv* #()) +;;; +;;; Return a permutation vector for SLOT-NAME-LISTS given a list of +;;; wrappers for actual method arguments. +;;; +(defun compute-pv (snls wrappers) + (loop with wrappers = (if (listp wrappers) wrappers (list wrappers)) + for snl in snls + when snl nconc + (loop with wrapper = (pop wrappers) + with stdp = (typep wrapper 'wrapper) + with class = (wrapper-class* wrapper) + with class-slots = (and stdp (wrapper-class-slots wrapper)) + for sn in (cdr snl) collect + (when stdp + (compute-pv-slot sn wrapper class class-slots))) + into pv-values + finally + (return (make-permutation-vector pv-values)))) -(defmacro pvref (pv index) - `(svref ,pv ,index)) +(defun make-permutation-vector (contents) + (make-array (length contents) :initial-contents contents)) -(defmacro copy-pv (pv) - `(copy-seq ,pv)) +;;; +;;; Look up wrappers PV-WRAPPERS in PV-TABLE. Value is a pv cell +;;; (PV . CALLS), with PV being the permutation vector associated +;;; with the set of wrappers PV-WRAPPERS. +;;; +;;; If PV-TABLE doen't have a cache, make a new one. If PV-WRAPPERS +;;; are not in the cache, compute a permutation vector and fill the +;;; cache. +;;; +(defun pv-table-lookup (table wrappers) + (let* ((cache (pv-table-cache table)) + (pv-cell (and cache (probe-cache cache wrappers nil)))) + (unless pv-cell + (let* ((slot-name-lists (pv-table-slot-name-lists table)) + (call-list (pv-table-call-list table)) + (cache (or cache + (setf (pv-table-cache table) + (get-cache (- (length slot-name-lists) + (count nil slot-name-lists)) + t 2)))) + (pv (compute-pv slot-name-lists wrappers)) + (calls (compute-calls table call-list wrappers)) + (cell (cons pv calls)) + (new-cache (fill-cache cache wrappers cell))) + (setf (pv-table-cache table) new-cache) + (setq pv-cell cell))) + pv-cell)) -(defun make-calls-type-declaration (var) - `(type simple-vector ,var)) + +;;; *************************************** +;;; Updating PV-TABLEs for Changes ******* +;;; *************************************** -(defmacro callsref (calls index) - `(svref ,calls ,index)) +(defvar *pv-table-cache-update-info* ()) -(defvar *pv-table-cache-update-info* nil) +;;; +;;; Record that slot definition SLOTD has been changed. This pushes +;;; (CLASS . PV-KEY) onto *PV-TABLE-CACHE-UPDATE-INFO*, where CLASS is +;;; the class to which SLOTD belongs, and PV-KEY is either a slot +;;; name, a symbol, or (READER <gf-name>), or (WRITER <gf-name>). +;;; *PV-TABLE-CACHE-UPDATE-INFO* is later used by +;;; UPDATE-PV-TABLE-CACHE-INFO to do the actual updating. +;;; +(defun record-pv-update-info (slotd) + (let ((class (slot-definition-class slotd))) + (flet ((push-accessor-info (type accessors) + (loop for gf-name in accessors + as key = (if (and (consp gf-name) (eq 'setf (car gf-name))) + (list 'writer (cadr gf-name)) + (list type gf-name)) + when (gethash key *pv-key->pv-tables*) do + (push (cons class key) *pv-table-cache-update-info*)))) + (push (cons class (slot-definition-name slotd)) + *pv-table-cache-update-info*) + (push-accessor-info 'reader (slot-definition-readers slotd)) + (push-accessor-info 'writer (slot-definition-writers slotd))))) -;called by: -;(method shared-initialize :after (structure-class t)) -;update-slots +;;; +;;; Update PV-TABLE caches for class CLASS. Called by +;;; SHARED-INITIALIZE :AFTER (STRUCTURE-CLASS T)) and by UPDATE-SLOTS. +;;; (defun update-pv-table-cache-info (class) - (let ((slot-names-for-pv-table-update nil) - (new-icui nil)) - (dolist (icu *pv-table-cache-update-info*) - (if (eq (car icu) class) - (pushnew (cdr icu) slot-names-for-pv-table-update) - (push icu new-icui))) - (setq *pv-table-cache-update-info* new-icui) - (when slot-names-for-pv-table-update - (update-all-pv-table-caches class slot-names-for-pv-table-update)))) + (loop for entry in *pv-table-cache-update-info* + with keys = () + as (entry-class . key) = entry + if (eq class entry-class) do + (pushnew key keys :test #'equal) + else + collect entry into remaining-entries + finally + (when keys + (setq *pv-table-cache-update-info* remaining-entries) + (update-all-pv-table-caches class keys)))) (defun update-all-pv-table-caches (class slot-names) (let* ((cwrapper (class-wrapper class)) - (std-p (typep cwrapper 'wrapper)) - (class-slots (and std-p (wrapper-class-slots cwrapper))) - (class-slot-p-cell (list nil)) - (new-values (mapcar (lambda (slot-name) - (cons slot-name - (when std-p - (compute-pv-slot - slot-name cwrapper class - class-slots class-slot-p-cell)))) - slot-names)) - (pv-tables nil)) - (dolist (slot-name slot-names) - (map-pv-table-references-of - slot-name - (lambda (pv-table pv-offset-list) - (declare (ignore pv-offset-list)) - (pushnew pv-table pv-tables)))) - (dolist (pv-table pv-tables) - (let* ((cache (pv-table-cache pv-table)) - (slot-name-lists (pv-table-slot-name-lists pv-table)) - (pv-size (pv-table-pv-size pv-table)) - (pv-map (make-array pv-size :initial-element nil))) - (let ((map-index 1) - (param-index 0)) - (dolist (slot-name-list slot-name-lists) - (dolist (slot-name (cdr slot-name-list)) - (let ((a (assoc slot-name new-values))) - (setf (svref pv-map map-index) - (and a (cons param-index (cdr a))))) - (incf map-index)) - (incf param-index))) - (when cache - (map-cache (lambda (wrappers pv-cell) - (setf (car pv-cell) - (update-slots-in-pv wrappers (car pv-cell) - cwrapper pv-size pv-map))) - cache)))))) - -(defun update-slots-in-pv (wrappers pv cwrapper pv-size pv-map) - (if (not (if (atom wrappers) - (eq cwrapper wrappers) - (dolist (wrapper wrappers nil) - (when (eq wrapper cwrapper) - (return t))))) - pv - (let* ((old-intern-p (listp (pvref pv 0))) - (new-pv (if old-intern-p - (copy-pv pv) - pv)) - (new-intern-p t)) - (if (atom wrappers) - (dotimes (i pv-size) - (declare (fixnum i)) - (when (consp (let ((map (svref pv-map i))) - (if map - (setf (pvref new-pv i) (cdr map)) - (pvref new-pv i)))) - (setq new-intern-p nil))) - (let ((param 0)) - (dolist (wrapper wrappers) - (when (eq wrapper cwrapper) - (dotimes (i pv-size) - (declare (fixnum i)) - (when (consp (let ((map (svref pv-map i))) - (if (and map (= (car map) param)) - (setf (pvref new-pv i) (cdr map)) - (pvref new-pv i)))) - (setq new-intern-p nil)))) - (incf param)))) - (when new-intern-p - (setq new-pv (let ((list-pv (coerce pv 'list))) - (or (gethash (cdr list-pv) *pvs*) - (setf (gethash (cdr list-pv) *pvs*) - (if old-intern-p - new-pv - (make-permutation-vector list-pv))))))) - new-pv))) + ;; Note that CLASS can be structure-class here. + (class-slots (when (typep cwrapper 'wrapper) + (wrapper-class-slots cwrapper))) + (new-locations + (when (typep cwrapper 'wrapper) + (loop for sn in slot-names collect + (cons sn (compute-pv-slot sn cwrapper class class-slots))))) + (pv-tables ())) + (flet ((new-location (key) + (cdr (assoc key new-locations :test #'equal)))) + ;; + ;; Collect all PV-TABLES referencing a slot name from SLOT-NAMES + ;; in PV-TABLES. + (loop for sn in slot-names do + (do-pv-tables (table sn) + (pushnew table pv-tables))) + ;; + ;; Update all these PV-TABLEs. + (loop for table in pv-tables + as cache = (pv-table-cache table) + when cache do + (let* ((pv-size (pv-table-pv-size table)) + (pv-map (make-array pv-size :initial-element nil))) + (do-pv-slots (key param-index pv-index table) + (let ((location (new-location key))) + (setf (svref pv-map pv-index) + (and location (cons param-index location))))) + (map-cache (lambda (wrappers pv-cell) + (update-slots-in-pv wrappers (car pv-cell) + cwrapper pv-map)) + cache)))))) - -(defun maybe-expand-accessor-form (form required-parameters slots env) - (let* ((fname (car form)) - #||(len (length form))||# - (gf (gdefinition fname))) - (macrolet ((maybe-optimize-reader () - `(let ((parameter - (can-optimize-access1 (cadr form) - required-parameters env))) - (when parameter - (optimize-reader slots parameter gf-name form)))) - (maybe-optimize-writer () - `(let ((parameter - (can-optimize-access1 (caddr form) - required-parameters env))) - (when parameter - (optimize-writer slots parameter gf-name form))))) - (unless (and (consp (cadr form)) - (eq 'instance-accessor-parameter (caadr form))) - (or #|| - (cond ((and (= len 2) (symbolp fname)) - (let ((gf-name (gethash fname *gf-declared-reader-table*))) - (when gf-name - (maybe-optimize-reader)))) - ((= len 3) - (let ((gf-name (gethash fname *gf-declared-writer-table*))) - (when gf-name - (maybe-optimize-writer))))) - ||# - (when (and (eq *boot-state* 'complete) - (generic-function-p gf)) - (let ((methods (generic-function-methods gf))) - (when methods - (let* ((gf-name (generic-function-name gf)) - (arg-info (gf-arg-info gf)) - (metatypes (arg-info-metatypes arg-info)) - (nreq (length metatypes)) - (applyp (arg-info-applyp arg-info))) - (when (null applyp) - (cond ((= nreq 1) - (when (some #'standard-reader-method-p methods) - (maybe-optimize-reader))) - ((and (= nreq 2) - (consp gf-name) - (eq (car gf-name) 'setf)) - (when (some #'standard-writer-method-p methods) - (maybe-optimize-writer)))))))))))))) +;;; +;;; WRAPPERS - wrappers of a cache line. +;;; CWRAPPER - the wrapper of the class being updated. +;;; PV - the car of a PV cell, that is the permutation vector. +;;; PV-SIZE - the size of PV +;;; PV-MAP - a vector of size PV-SIZE. NIL slots means nothing to update. +;;; Otherwise (PARAM-INDEX . NEW-VALUE). +;;; +(defun update-slots-in-pv (wrappers pv cwrapper pv-map) + (if (atom wrappers) + (when (eq wrappers cwrapper) + (loop for new across pv-map and i from 0 + when new do + (setf (svref pv i) (cdr new)))) + (when (memq cwrapper wrappers) + (loop for param from 0 and wrapper in wrappers + when (eq wrapper cwrapper) do + (loop for new across pv-map and i from 0 + when (and new (= (car new) param)) do + (setf (svref pv i) (cdr new))))))) + +(declaim (inline count-gf-required-parameters)) + +(defun count-gf-required-parameters (gf) + (let ((arg-info (gf-arg-info gf))) + (length (arg-info-metatypes arg-info)))) + +(defun update-accessor-pvs (reason gf &optional method replaced-method) + (declare (ignore method replaced-method)) + (let ((nreq (count-gf-required-parameters gf))) + (when (and (<= 1 nreq 2) + (some #'standard-accessor-method-p + (generic-function-methods gf))) + (let* ((gf-name (generic-function-name gf)) + (key (if (= nreq 1) `(reader ,gf-name) `(writer ,gf-name)))) + (do-pv-tables (table key) + (when (pv-table-cache table) + (map-cache + (lambda (wrappers pv-cell) + (setf (car pv-cell) + (recompute-pv-for-key key (car pv-cell) + (pv-table-slot-name-lists table) + wrappers + (eq reason 'removed-gf)))) + (pv-table-cache table)))))))) -(defun optimize-generic-function-call (form required-parameters env slots calls) - (declare (ignore required-parameters env slots calls)) - (or (and (eq (car form) 'make-instance) - (expand-make-instance-form form)) - #|| - (maybe-expand-accessor-form form required-parameters slots env) - (let* ((fname (car form)) - (len (length form)) - (gf (and (fboundp fname) (gdefinition fname))) - (gf-name (and (fsc-instance-p gf) - (if (early-gf-p gf) - (early-gf-name gf) - (generic-function-name gf))))) - (when gf-name - (multiple-value-bind (nreq restp) - (get-generic-function-info gf) - (optimize-gf-call slots calls form nreq restp env)))) - ||# - form)) +;;; +;;; Like COMPUTE-PV, but only recomputes entries for KEY. If no +;;; pv values change, OLD-PV is returned unchanged. +;;; +(defun recompute-pv-for-key (key pv snls wrappers gf-removed-p) + (loop with pv-index = 0 + with wrappers = (if (listp wrappers) wrappers (list wrappers)) + for snl in snls + when snl do + (loop with wrapper = (pop wrappers) + with stdp = (typep wrapper 'wrapper) + and class = (wrapper-class* wrapper) + with class-slots = (when stdp (wrapper-class-slots wrapper)) + for sn in (cdr snl) + when (equal sn key) do + (setf (svref pv pv-index) + (and stdp + (not gf-removed-p) + (compute-pv-slot sn wrapper class class-slots))) + do (incf pv-index)) + finally + (return pv))) + +;;; ************************************************** +;;; Deciding Whether to Optimize Slot Access ******** +;;; ************************************************** -(defun can-optimize-access (form required-parameters env) - (let ((type (ecase (car form) - (slot-value 'reader) - (set-slot-value 'writer) - (slot-boundp 'boundp))) - (var (cadr form)) - (slot-name (eval (caddr form)))) ; known to be constant - (can-optimize-access1 var required-parameters env type slot-name))) - -(defun can-optimize-access1 (var required-parameters env &optional type slot-name) - (when (and (consp var) (eq 'the (car var))) - (setq var (caddr var))) - (when (symbolp var) - (let* ((rebound? (caddr (variable-declaration 'variable-rebinding var env))) - (parameter-or-nil (car (memq (or rebound? var) required-parameters)))) - (when parameter-or-nil - (let* ((class-name (caddr (variable-declaration - 'class parameter-or-nil env))) - (class (find-class class-name nil))) - (when (or (not (eq *boot-state* 'complete)) - (and class (not (class-finalized-p class)))) - (setq class nil)) - (when (and class-name (not (eq class-name 't))) - (when (or (null type) - (not (and class - (memq *the-class-structure-object* - (class-precedence-list class)))) - (optimize-slot-value-by-class-p class slot-name type)) - (cons parameter-or-nil (or class class-name))))))))) - -(defun optimize-slot-value (slots sparameter form) - (if sparameter - (destructuring-bind (slot-value instance-form slot-name-form) form - (declare (ignore slot-value instance-form)) - (let ((slot-name (eval slot-name-form))) - (optimize-instance-access slots :read sparameter slot-name nil))) - `(accessor-slot-value ,@(cdr form)))) - -(defun optimize-set-slot-value (slots sparameter form) - (if sparameter - (destructuring-bind - (set-slot-value instance-form slot-name-form new-value) form - (declare (ignore set-slot-value instance-form)) - (let ((slot-name (eval slot-name-form))) - (optimize-instance-access slots :write sparameter - slot-name new-value))) - `(accessor-set-slot-value ,@(cdr form)))) - -(defun optimize-slot-boundp (slots sparameter form) - (if sparameter - ;; - ;; The original PCL code, which used its own definition of - ;; DESTRUCTURING-BIND, had a fourth variable NEW-VALUE below, - ;; that was passed to OPTIMIZE-INSTANCE-ACCESS as its NEW-VALUE - ;; argument; the NEW-VALUE seems not to be used in - ;; OPTIMIZE-INSTANCE-ACCESS for the :BOUNDP case. - ;; - ;; Using CL's DESTRUCTURING-BIND, one gets an error when - ;; building PCL because FORM has 3 elements only, which seems - ;; reasonable for a SLOT-BOUNDP form. I don't see a case where - ;; this function could be called with a form having 4 elements. - (destructuring-bind (slot-boundp instance-form slot-name-form) form - (declare (ignore slot-boundp instance-form)) - (let ((slot-name (eval slot-name-form))) - (optimize-instance-access slots :boundp sparameter slot-name nil))) - `(accessor-slot-boundp ,@(cdr form)))) - -(defun optimize-reader (slots sparameter gf-name form) - (if sparameter - (optimize-accessor-call slots :read sparameter gf-name nil) - form)) - -(defun optimize-writer (slots sparameter gf-name form) - (if sparameter - (destructuring-bind (writer instance-form new-value) form - (declare (ignore writer instance-form)) - (optimize-accessor-call slots :write sparameter gf-name new-value)) - form)) -;;; -;;; The <slots> argument is an alist, the CAR of each entry is the name of -;;; a required parameter to the function. The alist is in order, so the -;;; position of an entry in the alist corresponds to the argument's position -;;; in the lambda list. -;;; -(defun optimize-instance-access (slots read/write sparameter slot-name new-value) - (let ((class (if (consp sparameter) (cdr sparameter) *the-class-t*)) - (parameter (if (consp sparameter) (car sparameter) sparameter))) - (if (and (eq *boot-state* 'complete) - (classp class) - (memq *the-class-structure-object* (class-precedence-list class))) - (let ((slotd (find-slot-definition class slot-name))) - (ecase read/write - (:read - `(,(slot-definition-defstruct-accessor-symbol slotd) ,parameter)) - (:write - `(setf (,(slot-definition-defstruct-accessor-symbol slotd) ,parameter) - ,new-value)) - (:boundp - 'T))) - (let* ((parameter-entry (assq parameter slots)) - (slot-entry (assq slot-name (cdr parameter-entry))) - (position (posq parameter-entry slots)) - (pv-offset-form (list 'pv-offset ''.PV-OFFSET.))) - (unless parameter-entry - (error "Internal error in slot optimization.")) - (unless slot-entry - (setq slot-entry (list slot-name)) - (push slot-entry (cdr parameter-entry))) - (push pv-offset-form (cdr slot-entry)) - (ecase read/write - (:read - `(instance-read ,pv-offset-form ,parameter ,position - ',slot-name ',class)) - (:write - `(let ((.new-value. ,new-value)) - (instance-write ,pv-offset-form ,parameter ,position - ',slot-name ',class .new-value.))) - (:boundp - `(instance-boundp ,pv-offset-form ,parameter ,position - ',slot-name ',class))))))) - -(defun optimize-accessor-call (slots read/write sparameter gf-name new-value) - (let* ((class (if (consp sparameter) (cdr sparameter) *the-class-t*)) - (parameter (if (consp sparameter) (car sparameter) sparameter)) - (parameter-entry (assq parameter slots)) - (name (case read/write - (:read `(reader ,gf-name)) - (:write `(writer ,gf-name)))) - (slot-entry (assoc name (cdr parameter-entry) :test #'equal)) - (position (posq parameter-entry slots)) - (pv-offset-form (list 'pv-offset ''.PV-OFFSET.))) - (unless parameter-entry - (error "Internal error in slot optimization.")) - (unless slot-entry - (setq slot-entry (list name)) - (push slot-entry (cdr parameter-entry))) - (push pv-offset-form (cdr slot-entry)) - (ecase read/write - (:read - `(instance-reader ,pv-offset-form ,parameter ,position ,gf-name ',class)) - (:write - `(let ((.new-value. ,new-value)) - (instance-writer ,pv-offset-form ,parameter ,position ,gf-name ',class - .new-value.)))))) - -(defvar *unspecific-arg* '..unspecific-arg..) - -(defun optimize-gf-call-internal (form slots env) - (when (and (consp form) - (eq (car form) 'the)) - (setq form (caddr form))) - (or (and (symbolp form) - (let* ((rebound? (caddr (variable-declaration 'variable-rebinding - form env))) - (parameter-or-nil (car (assq (or rebound? form) slots)))) - (when parameter-or-nil - (let* ((class-name (caddr (variable-declaration - 'class parameter-or-nil env)))) - (when (and class-name (not (eq class-name 't))) - (position parameter-or-nil slots :key #'car)))))) - (if (constantp form) - (let ((form (eval form))) - (if (symbolp form) - form - *unspecific-arg*)) - *unspecific-arg*))) - -(defun optimize-gf-call (slots calls gf-call-form nreq restp env) - (unless (eq (car gf-call-form) 'make-instance) ; needs more work - (let* ((args (cdr gf-call-form)) - (all-args-p (eq (car gf-call-form) 'make-instance)) - (non-required-args (nthcdr nreq args)) - (required-args (ldiff args non-required-args)) - (call-spec (list (car gf-call-form) nreq restp - (mapcar (lambda (form) - (optimize-gf-call-internal form slots env)) - (if all-args-p - args - required-args)))) - (call-entry (assoc call-spec calls :test #'equal)) - (pv-offset-form (list 'pv-offset ''.PV-OFFSET.))) - (unless (some #'integerp - (let ((spec-args (cdr call-spec))) - (if all-args-p - (ldiff spec-args (nthcdr nreq spec-args)) - spec-args))) - (return-from optimize-gf-call nil)) - (unless call-entry - (setq call-entry (list call-spec)) - (push call-entry (cdr calls))) - (push pv-offset-form (cdr call-entry)) - (if (eq (car call-spec) 'make-instance) - `(funcall (pv-ref .pv. ,pv-offset-form) ,@(cdr gf-call-form)) - `(let ((.emf. (pv-ref .pv. ,pv-offset-form))) - (invoke-effective-method-function .emf. ,restp - ,@required-args ,@(when restp `((list ,@non-required-args))))))))) - + +;;; These forms get munged by MUTATE-SLOTS. -(define-walker-template pv-offset) ; These forms get munged by mutate slots. +(define-walker-template pv-offset) (defmacro pv-offset (arg) arg) -(define-walker-template instance-accessor-parameter) -(defmacro instance-accessor-parameter (x) x) - -;; It is safe for these two functions to be wrong. -;; They just try to guess what the most likely case will be. -(defun generate-fast-class-slot-access-p (class-form slot-name-form) - (let ((class (and (constantp class-form) (eval class-form))) - (slot-name (and (constantp slot-name-form) (eval slot-name-form)))) - (and (eq *boot-state* 'complete) - (standard-class-p class) - (not (eq class *the-class-t*)) ; shouldn't happen, though. - (let ((slotd (find-slot-definition class slot-name))) - (and slotd (eq :class (slot-definition-allocation slotd))))))) - -(defun skip-fast-slot-access-p (class-form slot-name-form type) - (let ((class (and (constantp class-form) (eval class-form))) - (slot-name (and (constantp slot-name-form) (eval slot-name-form)))) - (and (eq *boot-state* 'complete) - (standard-class-p class) - (not (eq class *the-class-t*)) ; shouldn't happen, though. - (let ((slotd (find-slot-definition class slot-name))) - (and slotd (skip-optimize-slot-value-by-class-p class slot-name type)))))) - -(defun skip-optimize-slot-value-by-class-p (class slot-name type) - (let ((slotd (find-slot-definition class slot-name))) - (and slotd - (eq *boot-state* 'complete) - (not (slot-accessor-std-p slotd type))))) -(defmacro instance-read-internal (pv slots pv-offset default &optional type) - (unless (member type '(nil :instance :class :default)) - (error "Illegal type argument to ~S: ~S" 'instance-read-internal type)) - (if (eq type :default) - default - (let* ((index (gensym)) - (value index)) - `(locally (declare #.*optimize-speed*) - (let ((,index (pvref ,pv ,pv-offset))) - (setq ,value (typecase ,index - ,@(when (or (null type) (eq type :instance)) - `((fixnum (%instance-ref ,slots ,index)))) - ,@(when (or (null type) (eq type :class)) - `((cons (cdr ,index)))) - (t +slot-unbound+))) - (if (eq ,value +slot-unbound+) - ,default - ,value)))))) - -(defmacro instance-read (pv-offset parameter position slot-name class) - (if (skip-fast-slot-access-p class slot-name 'reader) - `(accessor-slot-value ,parameter ,slot-name) - `(instance-read-internal .pv. ,(slot-vector-symbol position) - ,pv-offset (accessor-slot-value ,parameter ,slot-name) - ,(if (generate-fast-class-slot-access-p class slot-name) - :class :instance)))) - -(defmacro instance-reader (pv-offset parameter position gf-name class) - (declare (ignore class)) - `(instance-read-internal .pv. ,(slot-vector-symbol position) - ,pv-offset - (,gf-name (instance-accessor-parameter ,parameter)) - :instance)) +;;; +;;; Sometimes useful for debugging. +;;; +(defmacro pvref (pv i) + `(%svref ,pv ,i)) + +(defmacro instance-read-internal (pv slot-vector pv-offset-form default + &optional type) + (assert (member type '(nil :instance :class))) + (let* ((index (gensym)) + (value (gensym))) + `(locally + (declare #.*optimize-speed*) + (let* ((,index (pvref ,pv ,pv-offset-form)) + (,value (typecase ,index + ,@(when (or (null type) (eq type :instance)) + `((fixnum + (%slot-ref ,slot-vector ,index)))) + ,@(when (or (null type) (eq type :class)) + `((cons + (cdr ,index)))) + (t +slot-unbound+)))) + (if (eq ,value +slot-unbound+) + ,default + ,value))))) (defmacro instance-write-internal (pv slots pv-offset new-value default &optional type) - (unless (member type '(nil :instance :class :default)) - (error "Illegal type argument to ~S: ~S" 'instance-write-internal type)) - (if (eq type :default) - default - (let* ((index (gensym))) - `(locally (declare #.*optimize-speed*) - (let ((,index (pvref ,pv ,pv-offset))) - (typecase ,index - ,@(when (or (null type) (eq type :instance)) - `((fixnum (setf (%instance-ref ,slots ,index) ,new-value)))) - ,@(when (or (null type) (eq type :class)) - `((cons (setf (cdr ,index) ,new-value)))) - (t ,default))))))) - -(defmacro instance-write (pv-offset parameter position slot-name class new-value) - (if (skip-fast-slot-access-p class slot-name 'writer) - `(accessor-set-slot-value ,parameter ,slot-name ,new-value) - `(instance-write-internal .pv. ,(slot-vector-symbol position) - ,pv-offset ,new-value - (accessor-set-slot-value ,parameter ,slot-name ,new-value) - ,(if (generate-fast-class-slot-access-p class slot-name) - :class :instance)))) - -(defmacro instance-writer (pv-offset parameter position gf-name class new-value) - (declare (ignore class)) - `(instance-write-internal .pv. ,(slot-vector-symbol position) - ,pv-offset ,new-value - (,gf-name (instance-accessor-parameter ,parameter) ,new-value) - :instance)) + (assert (member type '(nil :instance :class))) + (let* ((index (gensym))) + `(locally + (declare #.*optimize-speed*) + (let ((,index (pvref ,pv ,pv-offset))) + (typecase ,index + ,@(when (or (null type) (eq type :instance)) + `((fixnum (setf (%slot-ref ,slots ,index) ,new-value)))) + ,@(when (or (null type) (eq type :class)) + `((cons (setf (cdr ,index) ,new-value)))) + (t ,default)))))) (defmacro instance-boundp-internal (pv slots pv-offset default &optional type) - (unless (member type '(nil :instance :class :default)) - (error "Illegal type argument to ~S: ~S" 'instance-boundp-internal type)) - (if (eq type :default) - default - (let* ((index (gensym))) - `(locally (declare #.*optimize-speed*) - (let ((,index (pvref ,pv ,pv-offset))) - (typecase ,index - ,@(when (or (null type) (eq type :instance)) - `((fixnum (not (eq (%instance-ref ,slots ,index) +slot-unbound+))))) - ,@(when (or (null type) (eq type :class)) - `((cons (not (eq (cdr ,index) +slot-unbound+))))) - (t ,default))))))) - -(defmacro instance-boundp (pv-offset parameter position slot-name class) - (if (skip-fast-slot-access-p class slot-name 'boundp) - `(accessor-slot-boundp ,parameter ,slot-name) - `(instance-boundp-internal .pv. ,(slot-vector-symbol position) - ,pv-offset (accessor-slot-boundp ,parameter ,slot-name) - ,(if (generate-fast-class-slot-access-p class slot-name) - :class :instance)))) - + (assert (member type '(nil :instance :class))) + (let* ((index (gensym))) + `(locally + (declare #.*optimize-speed*) + (let ((,index (pvref ,pv ,pv-offset))) + (typecase ,index + ,@(when (or (null type) (eq type :instance)) + `((fixnum (not (eq (%slot-ref ,slots ,index) +slot-unbound+))))) + ,@(when (or (null type) (eq type :class)) + `((cons (not (eq (cdr ,index) +slot-unbound+))))) + (t ,default)))))) + +;;; +;;; Build ``slot name lists'' from the collected information about +;;; INSTANCE-READ and INSTANCE-WRITE optimizations. +;;; +;;; SLOTS is an alist of lists +;;; +;;; (PARAMETER-NAME ((SLOT-NAME PV-OFFSET-FORMs ...) +;;; (SLOT-NAME PV-OFFSET-FORMs ...) +;;; ...)) ;;; -;;; This magic function has quite a job to do indeed. +;;; where each PARAMETER-NAME is the name of a required parameter for +;;; which a slot access via slot-value, set-slot-value, slot-boundp +;;; has been optimized into a PV access. The SLOT-NAMES are the names +;;; of the slots for which the optimization has been performed. +;;; The PV-OFFSET-FORMs are lists (PV-OFFSET <dummy>) that are contained +;;; in calls to INSTANCE-READ and INSTANCE-WRITE. ;;; -;;; The careful reader will recall that <slots> contains all of the optimized -;;; slot access forms produced by OPTIMIZE-INSTANCE-ACCESS. Each of these is -;;; a call to either INSTANCE-READ or INSTANCE-WRITE. +;;; CALLS is currently unused, and always NIL. ;;; -;;; At the time these calls were produced, the first argument was specified as -;;; the symbol .PV-OFFSET.; what we have to do now is convert those pv-offset -;;; arguments into the actual number that is the correct offset into the pv. +;;; First value is a slot name list of the form +;;; +;;; ((NIL SLOT-NAME SLOT-NAME ...) +;;; (NIL SLOT-NAME SLOT-NAME ...) +;;; ...) +;;; +;;; Second value is nil, since generic function call optimization is +;;; currently not done, and CALLS is always NIL. +;;; +;;; From the code, it seems that CALLS was intended to be a list of +;;; lists of the form +;;; +;;; ((FN ARG1 ARG2 ...) PV-OFFSET-FORMs ...) +;;; +;;; where FN is a symbol or cons for the generic function name, and +;;; each ARG is either an integer specifying the position of a required +;;; parameter, or something else (NIL?). +;;; +;;; The first element of a slot-name list for parameter number P is set +;;; from NIL to T if that parameter appears in an optimized generic +;;; function call. ;;; -;;; But first, oh but first, we sort <slots> a bit so that for each argument -;;; we have the slots in alphabetical order. This canonicalizes the PV-TABLE's a -;;; bit and will hopefully lead to having fewer PV's floating around. Even -;;; if the gain is only modest, it costs nothing. -;;; (defun slot-name-lists-from-slots (slots calls) (multiple-value-bind (slots calls) (mutate-slots-and-calls slots calls) @@ -771,42 +558,66 @@ slots)) (call-list (mapcar #'car calls))) - (dolist (call call-list) - (dolist (arg (cdr call)) - (when (integerp arg) - (setf (car (nth arg slot-name-lists)) t)))) - (setq slot-name-lists (mapcar (lambda (r+snl) - (when (or (car r+snl) (cdr r+snl)) - r+snl)) - slot-name-lists)) - (let ((cvt (apply #'vector - (let ((i -1)) - (mapcar (lambda (r+snl) - (when r+snl (incf i))) - slot-name-lists))))) - (setq call-list (mapcar (lambda (call) - (cons (car call) - (mapcar (lambda (arg) - (if (integerp arg) - (svref cvt arg) - arg)) - (cdr call)))) - call-list))) + ;; + ;; For every parameter used by a gf optimization, mark the + ;; parameter's slot entry by setting its car to T. This is + ;; done to prevent the code below from setting an otherwise + ;; unused parameter entry in the slot name list to NIL, which + ;; would mean that that parameter would be considered as not + ;; participating in pv optimizations. + (loop for (gf-name . args) in call-list do + (loop for arg in args do + (setf (car (nth arg slot-name-lists)) t))) + ;; + ;; Replace (NIL . NIL) with NIL in the slot name lists. The NIL + ;; indicates that a parameter is not used in pv optimizations + ;; which means we don't need to retrieve its wrapper and slots + ;; etc. at the start of a method function. + (setq slot-name-lists + (loop for snl in slot-name-lists + if (or (car snl) (cdr snl)) + collect snl + else + collect nil)) + ;; + ;; Convert "absolute" parameter numbers in calls to "relative" + ;; parameter indices, excluding parameters not used for + ;; pv-optimization (the index of wrappers in the pv table + ;; cache). + (setq call-list + (loop with index-vector = + (coerce (loop with i = -1 + for snl in slot-name-lists + collect (when snl (incf i))) + 'simple-vector) + for (gf-name . args) in call-list collect + (cons gf-name + (mapcar (lambda (arg) (svref index-vector arg)) + args)))) + ;; (values slot-name-lists call-list)))) +;;; +;;; Assign actual PV indices to slots and patch these into +;;; recorded PV-OFFSET forms in SLOTS and CALLS. +;;; (defun mutate-slots-and-calls (slots calls) (let ((sorted-slots (sort-slots slots)) (sorted-calls (sort-calls (cdr calls))) - (pv-offset 0)) ; index 0 is for info + (pv-offset -1)) + ;; + ;; Patch PV indices into PV-OFFSET forms recorded in SLOTS. (dolist (parameter-entry sorted-slots) (dolist (slot-entry (cdr parameter-entry)) (incf pv-offset) - (dolist (form (cdr slot-entry)) - (setf (cadr form) pv-offset)))) - (dolist (call-entry sorted-calls) - (incf pv-offset) - (dolist (form (cdr call-entry)) - (setf (cadr form) pv-offset))) + (dolist (pv-offset-form (cdr slot-entry)) + (setf (cadr pv-offset-form) pv-offset)))) + ;; + ;; Patch PV indices into PV-OFFSET forms recorded in CALLS. + (loop for i from 0 and call in sorted-calls do + (loop for form in (cdr call) do + (setf (cadr form) i))) + ;; (values sorted-slots sorted-calls))) (defun symbol-pkg-name (sym) @@ -814,23 +625,24 @@ (if pkg (package-name pkg) ""))) (defun symbol-lessp (a b) - (if (eq (symbol-package a) - (symbol-package b)) - (string-lessp (symbol-name a) - (symbol-name b)) - (string-lessp (symbol-pkg-name a) - (symbol-pkg-name b)))) + (if (eq (symbol-package a) (symbol-package b)) + (string-lessp (symbol-name a) (symbol-name b)) + (string-lessp (symbol-pkg-name a) (symbol-pkg-name b)))) (defun symbol-or-cons-lessp (a b) (etypecase a - (symbol (etypecase b - (symbol (symbol-lessp a b)) - (cons t))) - (cons (etypecase b - (symbol nil) - (cons (if (eq (car a) (car b)) - (symbol-or-cons-lessp (cdr a) (cdr b)) - (symbol-or-cons-lessp (car a) (car b)))))))) + (symbol + (etypecase b + (symbol (symbol-lessp a b)) + (cons t))) + (integer + (< a b)) + (cons + (etypecase b + (symbol nil) + (cons (if (eq (car a) (car b)) + (symbol-or-cons-lessp (cdr a) (cdr b)) + (symbol-or-cons-lessp (car a) (car b)))))))) (defun sort-slots (slots) (mapcar (lambda (parameter-entry) @@ -845,110 +657,86 @@ ;;; -;;; This needs to work in terms of metatypes and also needs to work for -;;; automatically generated reader and writer functions. -;;; -- Automatically generated reader and writer functions use this stuff too. +;;; Giving method lambdas access to PV tables. +;;; + +;;; PV-BINDING is wrapped around a method lambda body BODY in +;;; MAKE-METHOD-LAMBDA-INTERNAL when optimizations have been performed +;;; by WALK-METHOD-LAMBDA on the method lambda that require access to +;;; PV tables. +;;; +;;; REQUIRED-PARAMETERS is a list of the names of required parameters +;;; of the method. +;;; +;;; SLOT-NAME-LISTS is a list of the form +;;; +;;; ((PARAM1 NIL SLOT-NAME SLOT-NAME ...) +;;; (PARAM2 NIL SLOT-NAME SLOT-NAME ...)) +;;; +;;; PV-TABLE-SYMBOL is an uninterned symbol whose symbol-value will be +;;; set to the methods pv-table when the method is invoked. +;;; +;;; The resulting form looks like +;;; +;;; (let* ((.pv-table. PV-TABLE-SYMBOL) +;;; (.pv-cell. (pv-table-lookup-pv-args .pv-table. PARAM0 PARAM1 ...)) +;;; (.pv. (car .pv-cell.)) +;;; (.calls. (cdr .pv-cell.))) +;;; (declare (type simple-vector .pv.)) +;;; (declare (type simple-vector .calls.)) +;;; (declare (special PV-TABLE-SYMBOL)) +;;; (declare (ignorable .pv. .calls.)) +;;; (let ((.slots0. (get-slots-or-nil PARAM0)) +;;; (.slots1. (get-slots-or-nil PARAM1)) +;;; ...) +;;; <the method function body>)) +;;; +;;; The .SLOTS*. variables are bound to the instance slot value vectors +;;; of the required parameters appearing in SLOT-NAME-LISTS. +;;; + +(defun needs-pv-p (snl) + (loop for entry in (cdr snl) + thereis (not (equal '(inline-access) entry)))) (defmacro pv-binding ((required-parameters slot-name-lists pv-table-symbol) &body body) - (loop for slot-names in slot-name-lists - and required-parameter in required-parameters - and i of-type fixnum from 0 - when slot-names - collect required-parameter into pv-parameters - and collect (slot-vector-symbol i) into slot-vars + (loop for snl in slot-name-lists + and param in required-parameters and i from 0 + when snl + collect param into params + and collect (and (cdr snl) (slot-vector-symbol i)) into slot-vars finally (return `(pv-binding1 (.pv. .calls. ,pv-table-symbol - ,pv-parameters ,slot-vars) + ,params ,slot-vars) ,@body)))) (defmacro pv-binding1 ((pv calls pv-table-symbol pv-parameters slot-vars) &body body) - `(pv-env (,pv ,calls ,pv-table-symbol ,pv-parameters) - (let (,@(mapcar (lambda (slot-var p) `(,slot-var (get-slots-or-nil ,p))) - slot-vars pv-parameters)) - ,@body))) - -;This gets used only when the default make-method-lambda is overriden. -(defmacro pv-env ((pv calls pv-table-symbol pv-parameters) - &rest forms) + (multiple-value-bind (bindings vars) + (loop for v in slot-vars and p in pv-parameters + when v + collect `(,v (get-slots-or-nil ,p)) into bindings + and collect v into vars + finally + (return (values bindings vars))) + `(pv-env (,pv ,calls ,pv-table-symbol ,pv-parameters) + (let (,@bindings) + ,@(when vars `((declare (ignorable ,@vars)))) + ,@body)))) + +(defmacro pv-env ((pv calls pv-table-symbol pv-parameters) &rest forms) `(let* ((.pv-table. ,pv-table-symbol) (.pv-cell. (pv-table-lookup-pv-args .pv-table. ,@pv-parameters)) (,pv (car .pv-cell.)) (,calls (cdr .pv-cell.))) - (declare ,(make-pv-type-declaration pv)) - (declare ,(make-calls-type-declaration calls)) + (declare (type list .pv-cell.)) ,@(when (symbolp pv-table-symbol) `((declare (special ,pv-table-symbol)))) - ,pv ,calls + (declare (ignorable ,pv ,calls)) ,@forms)) -(defvar *non-variable-declarations* - '(values method-name method-lambda-list - optimize ftype inline notinline)) - -(defvar *variable-declarations-with-argument* - '(class - type)) - -(defvar *variable-declarations-without-argument* - '(ignore ignorable special dynamic-extent - array atom base-char bignum bit bit-vector character compiled-function - complex cons double-float extended-char fixnum float function hash-table integer - keyword list long-float nil null number package pathname random-state ratio - rational readtable sequence short-float signed-byte simple-array - simple-bit-vector simple-string simple-vector single-float standard-char - stream string symbol t unsigned-byte vector)) - -(defun split-declarations (body args) - (let ((inner-decls nil) (outer-decls nil) decl) - (loop (when (null body) (return nil)) - (setq decl (car body)) - (unless (and (consp decl) - (eq (car decl) 'declare)) - (return nil)) - (dolist (form (cdr decl)) - (when (consp form) - (let ((declaration-name (car form))) - (if (member declaration-name *non-variable-declarations*) - (push `(declare ,form) outer-decls) - (let ((arg-p - (member declaration-name - *variable-declarations-with-argument*)) - (non-arg-p - (member declaration-name - *variable-declarations-without-argument*)) - (dname (list (pop form))) - (inners nil) (outers nil)) - (unless (or arg-p non-arg-p) - (warn "The declaration ~S is not understood by ~S.~@ - Please put ~S on one of the lists ~S,~%~S, or~%~S.~@ - (Assuming it is a variable declarations without argument)." - declaration-name 'split-declarations - declaration-name - '*non-variable-declarations* - '*variable-declarations-with-argument* - '*variable-declarations-without-argument*) - (push declaration-name - *variable-declarations-without-argument*)) - (when arg-p - (setq dname (append dname (list (pop form))))) - (dolist (var form) - (if (member var args) - ;; quietly remove ignore declarations on args - ;; to prevent compiler warns about ignored args - ;; being read, caused by references in the - ;; definitions of call-next-method - (unless (eq (car dname) 'ignore) - (push var outers)) - (push var inners))) - (when outers - (push `(declare (,@dname ,@outers)) outer-decls)) - (when inners - (push `(declare (,@dname ,@inners)) inner-decls))))))) - (setq body (cdr body))) - (values outer-decls inner-decls body))) - + (defun make-method-initargs-form-internal (method-lambda initargs env) (declare (ignore env)) (let (method-lambda-args lmf lmf-params) @@ -980,23 +768,21 @@ (defun make-method-initargs-form-internal1 (initargs body req-args lmf-params restp) (multiple-value-bind (outer-decls inner-decls body) - (split-declarations body req-args) + (split-declarations + body req-args (getf (cdr lmf-params) :call-next-method-p)) (let* ((rest-arg (when restp '.rest-arg.)) - (args+rest-arg (if restp - (append req-args (list rest-arg)) - req-args))) + (args+rest-arg (if restp (append req-args (list rest-arg)) req-args))) `(list* :fast-function (lambda (.pv-cell. .next-method-call. ,@args+rest-arg) - ,@outer-decls (declare (ignorable .pv-cell. .next-method-call.)) + ,@outer-decls (macrolet ((pv-env ((pv calls pv-table-symbol pv-parameters) &rest forms) (declare (ignore pv-table-symbol pv-parameters)) `(let ((,pv (car .pv-cell.)) (,calls (cdr .pv-cell.))) - (declare ,(make-pv-type-declaration pv) - ,(make-calls-type-declaration calls)) - ,pv ,calls + (declare (type list .pv-cell.)) + (declare (ignorable ,pv ,calls)) ,@forms))) (fast-lexical-method-functions (,(car lmf-params) .next-method-call. ,req-args ,rest-arg @@ -1005,10 +791,13 @@ ,@body))) ',initargs)))) -;use arrays and hash tables and the fngen stuff to make this much better. -;It doesn't really matter, though, because a function returned by this -;will get called only when the user explicitly funcalls a result of method-function. -;BUT, this is needed to make early methods work. +;;; +;;; Use arrays and hash tables and the fngen stuff to make this much +;;; better. It doesn't really matter, though, because a function +;;; returned by this will get called only when the user explicitly +;;; funcalls a result of method-function. BUT, this is needed to make +;;; early methods work. +;;; (defun method-function-from-fast-function (fmf) (declare (type function fmf)) (let* ((method-function nil) (pv-table nil) @@ -1035,74 +824,55 @@ (apply fmf pv-cell nmc (nconc args (list rest)))) (apply fmf pv-cell nmc method-args))))) (let* ((fname (method-function-get fmf :name)) - (name `(,(or (get (car fname) 'method-sym) - (setf (get (car fname) 'method-sym) - (let ((str (symbol-name (car fname)))) - (if (string= "FAST-" str :end2 5) - (intern (subseq str 5) *the-pcl-package*) - (car fname))))) - ,@(cdr fname)))) + (name (cons 'method (cdr fname)))) (set-function-name method-function name)) (setf (method-function-get method-function :fast-function) fmf) method-function)) -(defun get-method-function-pv-cell (method-function method-args &optional pv-table) +(defun get-method-function-pv-cell (method-function method-args + &optional pv-table) (let ((pv-table (or pv-table (method-function-pv-table method-function)))) (when pv-table (let ((pv-wrappers (pv-wrappers-from-all-args pv-table method-args))) (when pv-wrappers (pv-table-lookup pv-table pv-wrappers)))))) -(defun pv-table-lookup-pv-args (pv-table &rest pv-parameters) - (pv-table-lookup pv-table (pv-wrappers-from-pv-args pv-parameters))) +;;; +;;; Called to bind .PV-CELL. in a method body to the cell +;;; corresponding to the actual arguments the method. Only those +;;; arguments are considered for which PV optimizations have been +;;; performed. +;;; +;;; PV-TABLE is the PV table of the method. +;;; +;;; ARGS is a list of actual method arguments, only those +;;; pv-optimized. +;;; +(defun pv-table-lookup-pv-args (pv-table &rest args) + (pv-table-lookup pv-table (pv-wrappers-from-pv-args args))) (defun pv-wrappers-from-pv-args (&rest args) - (let* ((nkeys (length args)) - (pv-wrappers (make-list nkeys)) - w (w-t pv-wrappers)) - (dolist (arg args) - (setq w - (wrapper-of arg)) - (when (invalid-wrapper-p w) - (setq w (check-wrapper-validity arg))) - (setf (car w-t) w)) - (setq w-t (cdr w-t)) - (when (= nkeys 1) (setq pv-wrappers (car pv-wrappers))) - pv-wrappers)) + (loop for arg in args + for wrapper = (wrapper-of arg) + if (invalid-wrapper-p wrapper) + collect (check-wrapper-validity wrapper) into wrappers + else + collect wrapper into wrappers + finally (return (if (cdr wrappers) wrappers (car wrappers))))) (defun pv-wrappers-from-all-args (pv-table args) - (let ((nkeys 0) - (slot-name-lists (pv-table-slot-name-lists pv-table))) - (dolist (sn slot-name-lists) - (when sn (incf nkeys))) - (let* ((pv-wrappers (make-list nkeys)) - (pv-w-t pv-wrappers)) - (dolist (sn slot-name-lists) - (when sn - (let* ((arg (car args)) - (w (wrapper-of arg))) - (unless w ; can-optimize-access prevents this from happening. - (error "error in pv-wrappers-from-all-args")) - (setf (car pv-w-t) w) - (setq pv-w-t (cdr pv-w-t)))) - (setq args (cdr args))) - (when (= nkeys 1) (setq pv-wrappers (car pv-wrappers))) - pv-wrappers))) + (loop for snl in (pv-table-slot-name-lists pv-table) and arg in args + when snl + collect (wrapper-of arg) into wrappers + finally (return (if (cdr wrappers) wrappers (car wrappers))))) +;;; +;;; Return the subset of WRAPPERS which is used in the cache +;;; of PV-TABLE. +;;; (defun pv-wrappers-from-all-wrappers (pv-table wrappers) - (let ((nkeys 0) - (slot-name-lists (pv-table-slot-name-lists pv-table))) - (dolist (sn slot-name-lists) - (when sn (incf nkeys))) - (let* ((pv-wrappers (make-list nkeys)) - (pv-w-t pv-wrappers)) - (dolist (sn slot-name-lists) - (when sn - (let ((w (car wrappers))) - (unless w ; can-optimize-access prevents this from happening. - (error "error in pv-wrappers-from-all-wrappers")) - (setf (car pv-w-t) w) - (setq pv-w-t (cdr pv-w-t)))) - (setq wrappers (cdr wrappers))) - (when (= nkeys 1) (setq pv-wrappers (car pv-wrappers))) - pv-wrappers))) + (loop for snl in (pv-table-slot-name-lists pv-table) and w in wrappers + when snl + collect w into result + finally (return (if (cdr result) result (car result))))) + diff --git a/pcl/walk.lisp b/pcl/walk.lisp index 31ffcb19c..1f9ce8297 100644 --- a/pcl/walk.lisp +++ b/pcl/walk.lisp @@ -26,7 +26,7 @@ ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/walk.lisp,v 1.23 2002/08/27 19:01:40 pmai Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/walk.lisp,v 1.24 2003/03/22 16:15:15 gerd Exp $") ;;; ;;; A simple code walker, based IN PART on: (roll the credits) ;;; Larry Masinter's Masterscope @@ -119,13 +119,13 @@ (defun unbound-lexical-function (&rest args) (declare (ignore args)) - (error "The evaluator was called to evaluate a form in a macroexpansion~%~ - environment constructed by the PCL portable code walker. These~%~ - environments are only useful for macroexpansion, they cannot be~%~ - used for evaluation.~%~ - This error should never occur when using PCL.~%~ - This most likely source of this error is a program which tries to~%~ - to use the PCL portable code walker to build its own evaluator.")) + (error "~@<The evaluator was called to evaluate a form in a macroexpansion ~ + environment constructed by the PCL portable code walker. These ~ + environments are only useful for macroexpansion, they cannot be ~ + used for evaluation. ~ + This error should never occur when using PCL. ~ + This most likely source of this error is a program which tries to ~ + to use the PCL portable code walker to build its own evaluator.~@:>")) @@ -174,10 +174,8 @@ (let* ((env (or env (c::make-null-environment))) (tem (first macros)) ;; A symbol-macro spec suitable for macroexpand-1 - (variables - (and (eql (first tem) *key-to-walker-environment*) - (loop for item in (fourth (cadr tem)) - collect (substitute 'c::macro :macro item))))) + (variables (when (eql (first tem) *key-to-walker-environment*) + (copy-list (fourth (cadr tem)))))) (c::make-lexenv :default env :variables variables @@ -190,6 +188,7 @@ (coerce (cadr m) 'function))) macros))))) +#-gerd-flet-names (defun environment-function (env fn) (when env (let ((entry (assoc fn (c::lexenv-functions env) :test #'equal))) @@ -197,6 +196,19 @@ (c::functional-p (cdr entry)) (cdr entry))))) +#+gerd-flet-names +(defun environment-function (env fn) + (when env + (flet ((test (x y) + (or (equal x y) + (and (consp y) + (member (car y) '(flet labels)) + (equal x (cadr y)))))) + (let ((entry (assoc fn (c::lexenv-functions env) :test #'test))) + (and entry + (c::functional-p (cdr entry)) + (cdr entry)))))) + (defun environment-macro (env macro) (when env (let ((entry (assoc macro (c::lexenv-functions env) :test #'eq))) @@ -220,7 +232,7 @@ ((macrolet) (dolist (mac (cadr ,macrolet/flet/labels-form)) (push (list (car mac) - (convert-macro-to-lambda (cadr mac) + (convert-macro-to-lambda ,old-env (cadr mac) (cddr mac) (string (car mac)))) ,macros)))) @@ -228,9 +240,13 @@ (,new-env ,old-env :functions ,functions :macros ,macros) ,@body)))) -(defun convert-macro-to-lambda (llist body &optional (name "Dummy Macro")) +(defun eval-in-environment (form env) + (eval:internal-eval (macroexpand form env) t env)) + +(defun convert-macro-to-lambda (env llist body &optional (name "dummy")) (let ((gensym (make-symbol name))) - (eval `(defmacro ,gensym ,llist ,@body)) + (eval-in-environment `(defmacro ,gensym ,llist ,@body) + (c::make-macrolet-environment env)) (macro-function gensym))) @@ -294,22 +310,22 @@ (defun variable-symbol-macro-p (var env) (let ((entry (member var (env-lexical-variables env) :key #'car))) - (when (eq (cadar entry) :macro) + (when (eq (cadar entry) 'c::macro) entry))) (defvar *VARIABLE-DECLARATIONS* '(special)) -(defun VARIABLE-DECLARATION (declaration var env) +(defun variable-declaration (declaration var env) (if (not (member declaration *variable-declarations*)) - (error "~S is not a recognized variable declaration." declaration) + (error "~@<~S is not a recognized variable declaration.~@:>" declaration) (let ((id (or (variable-lexical-p var env) var))) (dolist (decl (env-declarations env)) (when (and (eq (car decl) declaration) (eq (cadr decl) id)) (return decl)))))) -(defun VARIABLE-SPECIAL-P (var env) +(defun variable-special-p (var env) (or (not (null (variable-declaration 'special var env))) (variable-globally-special-p var))) @@ -404,7 +420,7 @@ ((and (listp x) (eq (car x) 'lambda)) '(lambda repeat (eval))) (t - (error "Can't get template for ~S" x)))) + (error "~@<Can't get template for ~S.~@:>" x)))) (defun get-implementation-dependent-walker-template (x) (declare (ignore x)) @@ -603,9 +619,9 @@ (not (fboundp fn)) (special-operator-p fn)) (error - "~S is a special form, not defined in the CommonLisp.~%~ - manual This code walker doesn't know how to walk it.~%~ - Define a template for this special form and try again." + "~@<~S is a special form, not defined in the CommonLisp ~ + manual. This code walker doesn't know how to walk it. ~ + Define a template for this special form and try again.~@:>" fn)) (t ;; Otherwise, walk the form as if its just a standard @@ -623,11 +639,7 @@ (SET (walk-form-internal form :SET env)) ((LAMBDA CALL) - (cond ((or (symbolp form) - (and (listp form) - (= (length form) 2) - (eq (car form) 'setf))) - form) + (cond ((ext:valid-function-name-p form) form) (t (walk-form-internal form context env))))) (case (car template) (REPEAT @@ -679,8 +691,8 @@ ((eq form stop-form) (if (null repeat-template) (walk-template stop-form (cdr template) context env) - (error "While handling repeat: - ~%~Ran into stop while still in repeat template."))) + (error "~@<While handling repeat: ~ + Ran into stop while still in repeat template.~@:>"))) ((null repeat-template) (walk-template-handle-repeat-1 form template (car template) stop-form context env)) @@ -777,7 +789,8 @@ (defun walk-unexpected-declare (form context env) (declare (ignore context env)) - (warn "Encountered declare ~S in a place where a declare was not expected." + (warn "~@<Encountered declare ~S in a place where a ~ + declare was not expected.~@:>" form) form) @@ -811,7 +824,7 @@ (not (symbolp (caddr arg))) (note-lexical-binding (caddr arg) env)))) (t - (error "Can't understand something in the arglist ~S" arglist)))) + (error "~@<Can't understand something in the arglist ~S.~@:>" arglist)))) (defun walk-let (form context env) (walk-let/let* form context env nil)) @@ -1057,7 +1070,7 @@ :lexical-variables (append (mapcar (lambda (binding) `(,(car binding) - :macro . ,(cadr binding))) + c::macro . ,(cadr binding))) bindings) (env-lexical-variables old-env))) (relist* form 'symbol-macrolet bindings @@ -1152,15 +1165,12 @@ (arm2 (if (cddddr form) (progn - (warn "In the form:~%~S~%~ - IF only accepts three arguments, you are using ~D.~%~ + (warn "~@<In the form ~S: ~ + IF only accepts three arguments, you are using ~D. ~ It is true that some Common Lisps support this, but ~ - it is not~%~ - truly legal Common Lisp. For now, this code ~ - walker is interpreting ~%~ - the extra arguments as extra else clauses. ~ - Even if this is what~%~ - you intended, you should fix your source code." + it is not truly legal Common Lisp. For now, this code ~ + walker is interpreting the extra arguments as extra else clauses. ~ + Even if this is what you intended, you should fix your source code.~@:>" form (length (cdr form))) (cons 'progn (cdddr form))) @@ -1423,7 +1433,7 @@ (member 'a the-lexical-variables) (member 'b the-lexical-variables) (member 'x the-lexical-variables)) - (error "Walker didn't do lexical variables of a closure properly."))) + (error "~@<Walker didn't do lexical variables of a closure properly.~@:>"))) |# diff --git a/tools/pclcom.lisp b/tools/pclcom.lisp index 672fcbf48..fd9201f4c 100644 --- a/tools/pclcom.lisp +++ b/tools/pclcom.lisp @@ -3,7 +3,7 @@ ;;; ********************************************************************** ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/tools/pclcom.lisp,v 1.23 2002/12/03 01:42:27 toy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/tools/pclcom.lisp,v 1.24 2003/03/22 16:15:14 gerd Exp $") ;;; ;;; ********************************************************************** ;;; @@ -25,7 +25,7 @@ ;; ;; Undefine all generic functions exported from Lisp so that bootstrapping ;; doesn't get confused. - (let ((class (find-class 'generic-function nil))) + (let ((class (kernel::find-class 'generic-function nil))) (when class (do-external-symbols (sym "LISP") (when (and (fboundp sym) @@ -36,12 +36,17 @@ (typep (fdefinition ssym) class)) (fmakunbound ssym)))))) + (let ((sym (find-symbol "%CHECK-GF-REDEFINITION" "PCL"))) + (when sym + (setq lisp::*setf-fdefinition-hook* + (delete (symbol-function sym) lisp::*setf-fdefinition-hook*)))) + ;; Undefine all PCL classes, and clear CLASS-PCL-CLASS slots. - (let ((wot (find-symbol "*FIND-CLASS*" "PCL"))) + (let ((wot (kernel::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))) + (let ((class (kernel::find-class name nil))) (cond ((not class)) ((typep class 'kernel::std-class) (setf (kernel:class-cell-class @@ -49,17 +54,14 @@ nil) (setf (info type kind name) nil)) (t - (setf (kernel:class-pcl-class class) nil))))))) + (setf (kernel:%class-pcl-class class) nil))))))) ;; Rename the PCL package to OLD-PCL, then restoring pcl::class and ;; pcl::..slot-unbound.. back to the PCL package as they need be ;; consistent with the symbols recognised by the compiler. - (let ((class 'pcl::class) - (slot-unbound 'pcl::..slot-unbound..)) + (let ((slot-unbound 'pcl::..slot-unbound..)) (rename-package "PCL" "OLD-PCL") (make-package "PCL") - (shadowing-import class "PCL") - (kernel:%set-symbol-package class (find-package "PCL")) (import slot-unbound "PCL") (kernel:%set-symbol-package slot-unbound (find-package "PCL")))) @@ -73,7 +75,7 @@ (setq kernel::*ansi-defstruct-options-p* nil) (setf c:*suppress-values-declaration* t) -(pushnew :setf *features*) +(setf *features* (adjoin :setf *features*)) (setf (search-list "pcl:") '("target:pcl/")) @@ -86,6 +88,7 @@ (load "pcl:defsys" :verbose t) (import 'kernel:funcallable-instance-p (find-package "PCL")) +(setq *gc-verbose* nil) (with-compiler-log-file ("target:compile-pcl.log" -- GitLab