From b26a095ed26e1e842d854bdbad0910cf0aab89b2 Mon Sep 17 00:00:00 2001 From: ram <ram> Date: Mon, 9 Nov 1992 15:22:22 +0000 Subject: [PATCH] This is September 92 PCL. --- pcl/boot.lisp | 3467 +++++++++++++++++------------------- pcl/braid.lisp | 1094 +++++------- pcl/cache.lisp | 953 +++++----- pcl/cmu-low.lisp | 404 ++++- pcl/combin.lisp | 502 +++--- pcl/construct.lisp | 131 +- pcl/cpatch.lisp | 5 - pcl/cpl.lisp | 8 +- pcl/defclass.lisp | 427 ++--- pcl/defcombin.lisp | 54 +- pcl/defs.lisp | 429 +++-- pcl/defsys.lisp | 289 ++- pcl/dfun.lisp | 1195 ++++++++++--- pcl/dlap.lisp | 190 +- pcl/env.lisp | 431 ++--- pcl/excl-low.lisp | 51 +- pcl/fin.lisp | 102 +- pcl/fixup.lisp | 1 - pcl/fngen.lisp | 66 +- pcl/fsc.lisp | 49 +- pcl/genera-low.lisp | 2 +- pcl/generic-functions.lisp | 866 ++++++--- pcl/ibcl-low.lisp | 5 - pcl/init.lisp | 370 ++-- pcl/iterate.lisp | 20 +- pcl/kcl-low.lisp | 173 +- pcl/kcl-patches.lisp | 104 +- pcl/lap.lisp | 39 +- pcl/list-functions.lisp | 76 +- pcl/low.lisp | 704 +++----- pcl/lucid-low.lisp | 66 +- pcl/macros.lisp | 397 ++--- pcl/methods.lisp | 2412 ++++++------------------- pcl/notes.text | 465 ++--- pcl/pcl-env.lisp | 16 +- pcl/pkg.lisp | 39 +- pcl/plap.lisp | 112 +- pcl/quadlap.lisp | 13 +- pcl/slots.lisp | 1396 +++------------ pcl/std-class.lisp | 1322 +++++--------- pcl/sys-package.lisp | 19 +- pcl/sys-proclaim.lisp | 2112 +++++++++++----------- pcl/sysdef.lisp | 54 +- pcl/time.lisp | 68 +- pcl/vector.lisp | 1265 +++++++++---- pcl/walk.lisp | 138 +- 46 files changed, 10347 insertions(+), 11754 deletions(-) diff --git a/pcl/boot.lisp b/pcl/boot.lisp index 890ccd00e..80572e3d2 100644 --- a/pcl/boot.lisp +++ b/pcl/boot.lisp @@ -72,40 +72,19 @@ work during bootstrapping. |# (proclaim '(notinline make-a-method - add-named-method - call-make-method-lambda - call-make-closure-generator-form - call-store-method-function-p - call-store-method-optimized-function-p - call-store-closure-generator-p - call-store-optimized-method-lambda-p + add-named-method + ensure-generic-function-using-class - ensure-generic-function-using-class - - add-method - remove-method - )) + add-method + remove-method + )) (defvar *early-functions* - '((make-a-method early-make-a-method - real-make-a-method) - (add-named-method early-add-named-method - real-add-named-method) - (call-make-method-lambda early-make-method-lambda - make-method-lambda) - (call-make-closure-generator-form make-std-closure-generator-form - make-closure-generator-form) - (call-store-method-function-p early-store-method-function-p - store-method-function-p) - (call-store-method-optimized-function-p - early-store-method-optimized-function-p - store-method-optimized-function-p) - (call-store-closure-generator-p early-store-closure-generator-p - store-closure-generator-p) - (call-store-optimized-method-lambda-p - early-store-optimized-method-lambda-p - store-optimized-method-lambda-p) - )) + '((make-a-method early-make-a-method + real-make-a-method) + (add-named-method early-add-named-method + real-add-named-method) + )) ;;; ;;; For each of the early functions, arrange to have it point to its early @@ -119,16 +98,18 @@ work during bootstrapping. ;;; (eval-when (load eval) - (defun redirect-early-function-internal (to) - #'(lambda (&rest args) (apply-function (symbol-function to) args))) - - (dolist (fns *early-functions*) - (let ((name (car fns)) - (early-name (cadr fns))) - (setf (symbol-function name) - (redirect-early-function-internal early-name)))) +(defun redirect-early-function-internal (real early) + (setf (symbol-function real) + (set-function-name + #'(lambda (&rest args) (apply (symbol-function early) args)) + real))) + +(dolist (fns *early-functions*) + (let ((name (car fns)) + (early-name (cadr fns))) + (redirect-early-function-internal name early-name))) - ) +) ;;; @@ -138,28 +119,40 @@ work during bootstrapping. ;;; (defvar *generic-function-fixups* '((add-method - ((generic-function method) ;lambda-list - (standard-generic-function method) ;specializers - real-add-method)) ;method-function + ((generic-function method) ;lambda-list + (standard-generic-function method) ;specializers + real-add-method)) ;method-function (remove-method - ((generic-function method) - (standard-generic-function method) - real-remove-method)) + ((generic-function method) + (standard-generic-function method) + real-remove-method)) (get-method ((generic-function qualifiers specializers &optional (errorp t)) - (standard-generic-function t t) - real-get-method)) + (standard-generic-function t t) + real-get-method)) (ensure-generic-function-using-class + ((generic-function function-specifier + &key generic-function-class environment + &allow-other-keys) + (generic-function t) + real-ensure-gf-using-class--generic-function) ((generic-function function-specifier - &key generic-function-class environment - &allow-other-keys) - (generic-function t) - real-ensure-gf-using-class--generic-function) - ((generic-function function-specifier - &key generic-function-class environment - &allow-other-keys) - (null t) - real-ensure-gf-using-class--null)) + &key generic-function-class environment + &allow-other-keys) + (null t) + real-ensure-gf-using-class--null)) + (make-method-lambda + ((proto-generic-function proto-method lambda-expression environment) + (standard-generic-function standard-method t t) + real-make-method-lambda)) + (make-method-initargs-form + ((proto-generic-function proto-method lambda-expression lambda-list environment) + (standard-generic-function standard-method t t t) + real-make-method-initargs-form)) + (compute-effective-method + ((generic-function combin applicable-methods) + (generic-function standard-method-combination t) + standard-compute-effective-method)) )) @@ -169,100 +162,95 @@ work during bootstrapping. (defmacro defgeneric (function-specifier lambda-list &body options) (expand-defgeneric function-specifier lambda-list options)) -(defvar *defgeneric-temp* NIL) - (defun expand-defgeneric (function-specifier lambda-list options) (when (listp function-specifier) (do-standard-defsetf-1 (cadr function-specifier))) - (let ((initargs ()) - (methods ())) + (let ((initargs ())) (flet ((duplicate-option (name) - (error "The option ~S appears more than once." name))) + (error "The option ~S appears more than once." name))) ;; ;; INITARG takes this screwy new argument to get around a bad ;; interaction between lexical macros and setf in the Lucid ;; compiler. ;; (macrolet ((initarg (key &optional new) - (if new - `(setf (getf initargs ,key) ,new) - `(getf initargs ,key)))) - (dolist (option options) - (ecase (car option) - (:argument-precedence-order - (if (initarg :argument-precedence-order) - (duplicate-option :argument-precedence-order) - (initarg :argument-precedence-order `',(cdr option)))) - (declare - (initarg :declarations - (append (cdr option) (initarg :declarations)))) - (:documentation - (if (initarg :documentation) - (duplicate-option :documentation) - (initarg :documentation `',(cadr option)))) - (:method-combination - (if (initarg :method-combination) - (duplicate-option :method-combination) - (initarg :method-combination `',(cdr option)))) - (:generic-function-class - (if (initarg :generic-function-class) - (duplicate-option :generic-function-class) - (initarg :generic-function-class `',(cadr option)))) - (:method-class - (if (initarg :method-class) - (duplicate-option :method-class) - (initarg :method-class `',(cadr option)))) - (:method - (push (cdr option) methods)))) - - (let ((declarations (initarg :declarations))) - (when declarations (initarg :declarations `',declarations))))) - (let ((load-defgeneric-form - (make-top-level-form `(defgeneric ,function-specifier) - *defgeneric-times* - `(load-defgeneric ',function-specifier ',lambda-list ,@initargs)))) - (if methods - `(progn - (proclaim-defgeneric ',function-specifier ',lambda-list) - (setf *defgeneric-temp* ,load-defgeneric-form) - ,@(mapcar #'(lambda (method-descrip) - `(defmethod ,function-specifier ,@method-descrip)) - (nreverse methods)) - (prog1 *defgeneric-temp* (setf *defgeneric-temp* NIL))) - `(progn - (proclaim-defgeneric ',function-specifier ',lambda-list) - ,load-defgeneric-form))))) - + (if new + `(setf (getf initargs ,key) ,new) + `(getf initargs ,key)))) + (dolist (option options) + (ecase (car option) + (:argument-precedence-order + (if (initarg :argument-precedence-order) + (duplicate-option :argument-precedence-order) + (initarg :argument-precedence-order `',(cdr option)))) + (declare + (initarg :declarations + (append (cdr option) (initarg :declarations)))) + (:documentation + (if (initarg :documentation) + (duplicate-option :documentation) + (initarg :documentation `',(cadr option)))) + (:method-combination + (if (initarg :method-combination) + (duplicate-option :method-combination) + (initarg :method-combination `',(cdr option)))) + (:generic-function-class + (if (initarg :generic-function-class) + (duplicate-option :generic-function-class) + (initarg :generic-function-class `',(cadr option)))) + (:method-class + (if (initarg :method-class) + (duplicate-option :method-class) + (initarg :method-class `',(cadr option)))) + (:method + (error + "DEFGENERIC doesn't support the :METHOD option yet.")))) + + (let ((declarations (initarg :declarations))) + (when declarations (initarg :declarations `',declarations))))) + `(progn + (proclaim-defgeneric ',function-specifier ',lambda-list) + ,(make-top-level-form `(defgeneric ,function-specifier) + *defgeneric-times* + `(load-defgeneric ',function-specifier ',lambda-list ,@initargs))))) (defun load-defgeneric (function-specifier lambda-list &rest initargs) (when (listp function-specifier) (do-standard-defsetf-1 (cadr function-specifier))) (apply #'ensure-generic-function - function-specifier - :lambda-list lambda-list - :definition-source `((defgeneric ,function-specifier) - ,(load-truename)) - initargs)) + function-specifier + :lambda-list lambda-list + :definition-source `((defgeneric ,function-specifier) + ,(load-truename)) + initargs)) ;;; ;;; ;;; - -(declaim (ftype (function (T) (values T T T T)) parse-defmethod)) - (defmacro DEFMETHOD (&rest args &environment env) - #+(or (not :lucid) :lcl3.0) + #+(or (not :lucid) :lcl3.0) (declare (arglist name - {method-qualifier}* - specialized-lambda-list - &body body)) + {method-qualifier}* + specialized-lambda-list + &body body)) (multiple-value-bind (name qualifiers lambda-list body) (parse-defmethod args) - (let ((proto-gf - (prototype-of-generic-function name)) - (proto-method - (method-prototype-for-gf name))) - (expand-defmethod - proto-gf proto-method name qualifiers lambda-list body env)))) + (multiple-value-bind (proto-gf proto-method) + (prototypes-for-make-method-lambda name) + (expand-defmethod name proto-gf proto-method + qualifiers lambda-list body env)))) + +(defun prototypes-for-make-method-lambda (name) + (if (not (eq *boot-state* 'complete)) + (values nil nil) + (let ((gf? (and (gboundp name) + (gdefinition name)))) + (if (or (null gf?) + (not (generic-function-p gf?))) + (values (class-prototype (find-class 'standard-generic-function)) + (class-prototype (find-class 'standard-method))) + (values gf? + (class-prototype (or (generic-function-method-class gf?) + (find-class 'standard-method)))))))) ;;; ;;; takes a name which is either a generic function name or a list specifying @@ -279,1221 +267,955 @@ work during bootstrapping. ;;; (defun method-prototype-for-gf (name) (let ((gf? (and (gboundp name) - (gdefinition name)))) + (gdefinition name)))) (cond ((neq *boot-state* 'complete) nil) - ((or (null gf?) - (not (generic-function-p gf?))) ;Someone else MIGHT - ;error at load time. - (class-prototype (find-class 'standard-method))) - (t - (let ((method-class (or (generic-function-method-class gf?) - (find-class 'standard-method)))) - (unless (class-finalized-p method-class) - (finalize-inheritance method-class)) - (class-prototype method-class)))))) - -(defun prototype-of-generic-function (name) - ;; Takes a name which is either a generic function name or a list specifying - ;; a setf generic function (like: (SETF <generic-function-name>)). - ;; Returns the generic function itself, unless the generic-function has - ;; not yet been defined, in which case it returns the class-prototype - ;; of 'standard-generic-function. - ;; - ;; NOTE that during bootstrapping, this function is allowed to return NIL. - ;; - (let ((gf? (and (gboundp name) - (gdefinition name)))) - (cond ((neq *boot-state* 'complete) nil) - ((or (null gf?) (not (generic-function-p gf?))) - (let ((std-generic-function-class - (find-class 'standard-generic-function NIL))) - (if std-generic-function-class - (class-prototype std-generic-function-class)))) - (T gf?)))) + ((or (null gf?) + (not (generic-function-p gf?))) ;Someone else MIGHT + ;error at load time. + (class-prototype (find-class 'standard-method))) + (t + (class-prototype (or (generic-function-method-class gf?) + (find-class 'standard-method))))))) -(defconstant *standard-pcl-make-method-lambda-doc-string* - "Standard PCL make-method-lambda here.") - -(defun early-store-method-function-p - (generic-function method initargs) - ;; Should methods of this generic-function store their own method-function? - ;; Answer is normally T to keep stay compatible with the AMOP even - ;; though PCL actually uses the function in method-optimized-function - ;; for efficiency. However, answer can be NIL if the programmer doesn't - ;; care about method-functions, which will cut down on binary sizes - ;; significantly since it would stop methods from carrying around - ;; an extra (unused) method-function. - ;; - (declare (ignore generic-function method initargs)) - *standard-store-method-function-p*) - -(defun early-store-method-optimized-function-p - (generic-function method initargs) - ;; Should methods of this generic-function store their own - ;; method-optimized-function? - ;; Answer better be T unless a closure-generator is stored - ;; for the method instead, or if the programmer has redefined the - ;; discriminating method function dispatch code to use the - ;; documented method-functions rather than the optimized PCL - ;; method-optimized-functions, - (declare (ignore generic-function method)) - (null (memq :optimized-slot-indices initargs))) - -(defun early-store-closure-generator-p - (generic-function method initargs) - ;; Should methods of this generic-function store their own - ;; method function closure generators? - ;; Answer better be T unless a method-optimized-function is - ;; stored instead, or if the programmer has redefined the - ;; the discriminating method function dispatch code to use - ;; the documented method-functions rather than the optimized - ;; PCL method-optimized-functions. - (declare (ignore generic-function method)) - (not (null (memq :optimized-slot-indices initargs)))) - -(defun early-store-optimized-method-lambda-p - (generic-function method initargs) - ;; Should methods of this generic-function store their own - ;; their optimized-method-lambdas? - ;; Generally only stored when the method contains slot-value - ;; accesses on its parameter lists, in which case the lambda - ;; is used to compile the cached method at runtime to directly - ;; optimize those accesses. - (declare (ignore generic-function method)) - (and *compile-slot-access-method-functions-at-runtime-p* - (not (null (memq :optimized-slot-indices initargs))))) - - -;#-Genera -(defun expand-defmethod - (proto-generic-function proto-method name qualifiers lambda-list - body env) - (when (listp name) (do-standard-defsetf-1 (cadr name))) - (multiple-value-bind (method-lambda optimized-method-lambda closure-generator - initargs specializers doc) - (expand-defmethod-internal proto-generic-function proto-method - name qualifiers lambda-list body env) - (make-top-level-form `(defmethod ,name ,@qualifiers ,specializers) - *defmethod-times* - `(progn - (proclaim-defgeneric ',name ',lambda-list) - (load-defmethod - ',(if proto-method - (class-name (class-of proto-method)) - 'standard-method) - ',name - ',qualifiers - (list ,@(mapcar #'(lambda (specializer) - (if (consp specializer) - ``(,',(car specializer) ,,(cadr specializer)) - `',specializer)) - specializers)) - ',(extract-lambda-list lambda-list) - ',doc - ,(if method-lambda `(function ,method-lambda)) - ,(if optimized-method-lambda `(function ,optimized-method-lambda)) - ,closure-generator - ',initargs))))) - -#|| -#+Genera -(defun expand-defmethod (proto-method name qualifiers lambda-list body env) + +(defun expand-defmethod (name proto-gf proto-method qualifiers lambda-list body env) (when (listp name) (do-standard-defsetf-1 (cadr name))) - (multiple-value-bind (fn-form specializers doc plist) - (expand-defmethod-internal name qualifiers lambda-list body env) - (let ((fn-args (cadadr fn-form)) - (fn-body (cddadr fn-form)) - (method-name `(method ,name ,@qualifiers ,specializers))) - `(progn - (proclaim '(function ,name)) - (defun ,method-name ,fn-args - ,@fn-body) - (load-defmethod - ',(if proto-method - (class-name (class-of proto-method)) - 'standard-method) - ',name - ',qualifiers - (list ,@(mapcar #'(lambda (specializer) - (if (consp specializer) - ``(,',(car specializer) ,,(cadr specializer)) - `',specializer)) - specializers)) - ',(extract-lambda-list lambda-list) - ',doc - ',(getf plist :isl-cache-symbol) ;Paper over a bug in KCL by - ;passing the cache-symbol - ;here in addition to in the - ;plist. - ',plist - #',method-name))))) -||# - -(defvar *expand-defmethod-internal-real-body* NIL) - -(defun expand-defmethod-internal - (proto-generic-function proto-method generic-function-name - qualifiers specialized-lambda-list body env) - (declare (ignore qualifiers)) - (declare (values fn-form optimized-fn-form closure-generator-form - initargs specializers doc)) - (when (listp generic-function-name) - (do-standard-defsetf-1 (cadr generic-function-name))) + (let ((*make-instance-function-keys* nil)) + (declare (special *make-instance-function-keys*)) + (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))) + `(progn + (proclaim-defgeneric ',name ',lambda-list) + ,@(when *make-instance-function-keys* + `((get-make-instance-functions ',*make-instance-function-keys*))) + ,(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) + (let (fn fn-lambda) + (if (and (interned-symbol-p (if (consp name) + (and (eq (car name) 'setf) (cadr name)) + name)) + (every #'interned-symbol-p qualifiers) + (every #'(lambda (s) + (if (consp s) + (and (eq (car s) 'eql) + (constantp (cadr s)) + (let ((sv (eval (cadr s)))) + (or (interned-symbol-p sv) + (integerp sv) + (standard-char-p sv)))) + (interned-symbol-p s))) + specializers) + (consp initargs-form) + (eq (car initargs-form) 'list*) + (memq (cadr initargs-form) '(:function :fast-function)) + (consp (setq fn (caddr initargs-form))) + (eq (car fn) 'function) + (consp (setq fn-lambda (cadr fn))) + (eq (car fn-lambda) 'lambda)) + (let* ((specls (mapcar #'(lambda (specl) + (if (consp specl) + `(,(car specl) ,(eval (cadr specl))) + specl)) + 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))) + (make-top-level-form + `(defmethod ,name ,@qualifiers ,specializers) + *defmethod-times* + (make-defmethod-form-internal + name qualifiers + `(list ,@(mapcar #'(lambda (specializer) + (if (consp specializer) + ``(,',(car specializer) ,,(cadr specializer)) + `',specializer)) + specializers)) + unspecialized-lambda-list method-class-name + initargs-form + pv-table-symbol))))) + +(defun make-defmethod-form-internal (name qualifiers specializers-form + unspecialized-lambda-list method-class-name + initargs-form &optional pv-table-symbol) + `(load-defmethod + ',method-class-name + ',name + ',qualifiers + ,specializers-form + ',unspecialized-lambda-list + ,initargs-form + ;;Paper over a bug in KCL by passing the cache-symbol + ;;here in addition to in the list. + ',pv-table-symbol)) + +(defmacro make-method-function (method-lambda &environment env) + (make-method-function-internal method-lambda env)) + +(defun make-method-function-internal (method-lambda &optional env) + (multiple-value-bind (proto-gf proto-method) + (prototypes-for-make-method-lambda nil) + (multiple-value-bind (method-function-lambda initargs) + (make-method-lambda proto-gf proto-method method-lambda env) + (make-method-initargs-form proto-gf proto-method + method-function-lambda initargs env)))) + +(defun add-method-declarations (name qualifiers lambda-list body env) + (multiple-value-bind (parameters unspecialized-lambda-list specializers) + (parse-specialized-lambda-list lambda-list) + (declare (ignore parameters)) + (multiple-value-bind (documentation declarations real-body) + (extract-declarations body env) + (values `(lambda ,unspecialized-lambda-list + ,@(when documentation `(,documentation)) + (declare (method-name ,(list name qualifiers specializers))) + (declare (method-lambda-list ,@lambda-list)) + ,@declarations + ,@real-body) + unspecialized-lambda-list specializers)))) + +(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)) + (make-method-initargs-form-internal method-lambda initargs env)) + +(unless (fboundp 'make-method-initargs-form) + (setf (symbol-function 'make-method-initargs-form) + (symbol-function 'real-make-method-initargs-form))) + +(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)) (multiple-value-bind (documentation declarations real-body) - (extract-declarations body) - (multiple-value-bind (parameters lambda-list specializers) - (parse-specialized-lambda-list specialized-lambda-list) - (let* ((required-parameters - (mapcar #'(lambda (r s) (declare (ignore s)) r) - parameters - specializers)) - (parameters-to-reference - (make-parameter-references specialized-lambda-list - required-parameters - declarations - generic-function-name - specializers)) - (class-declarations - `(declare - ,@(remove nil - (mapcar #'(lambda (a s) (and (symbolp s) - (neq s 't) - `(class ,a ,s))) - parameters - specializers)))) - (lambda-expression - ;; Remove the documentation string and insert the - ;; appropriate class declarations. The documentation - ;; string is removed to make it easy for us to insert - ;; new declarations later, they will just go after the - ;; cadr of the method lambda. The class declarations - ;; are inserted to communicate the class of the method's - ;; arguments to the code walk. - (let () - `(lambda ,lambda-list - ,class-declarations - ,@declarations - (progn ,@parameters-to-reference) - (block ,(if (listp generic-function-name) - (cadr generic-function-name) - generic-function-name) - ,@real-body))))) - (let ((*expand-defmethod-internal-real-body* real-body)) - (multiple-value-bind - (function optimized-function closure-generator initargs) - (make-method-lambda-and-optimized-lambda - proto-generic-function proto-method lambda-expression env) - (values function - optimized-function - closure-generator - initargs - specializers - documentation))))))) - - -(declaim (ftype (function (T T T T) (values list list)) - call-make-method-lambda - call-make-optimized-method-lambda)) - -(defvar *optimized-method-lambda* NIL) - -(defun make-method-lambda-and-optimized-lambda - (generic-function method lambda-expression env) - ;; Given the method body lambda-expression from expand-defmethod-internal, - ;; this method calls make-method-lambda to make the method-functions. - ;; To adhere to the AMOP while retaining maximum efficiency, method - ;; functions are actually stored in two ways: as a (1) METHOD-FUNCTION and - ;; (2) as a METHOD-OPTIMIZED-FUNCTION or METHOD-CLOSURE-GENERATOR. - ;; METHOD-FUNCTION is the documented function of the AMOP. - ;; METHOD-OPTIMIZED-FUNCTION is the optimized function used by PCL in actual - ;; method function invocation (METHOD-FUNCTION-FOR-CACHING). Its arguments are - ;; the actual arguments of method, and it recieves its next-methods by - ;; looking at the global *NEXT-METHODS*. Alternatively, if the method's - ;; body contains slot-value accesses that can be optimized for caching, - ;; a METHOD-CLOSURE-GENERATOR is stored instead of METHOD-OPTIMIZED-FUNCTION - ;; to generate an optimized caching function for given parameter types. - ;; - (let ((*optimized-method-lambda* NIL)) - (multiple-value-bind (method-lambda initargs) - (call-make-method-lambda - generic-function method lambda-expression env) - (let* ((optimized-method-lambda - *optimized-method-lambda*) - (store-method-function-p - (call-store-method-function-p generic-function method initargs)) - (store-method-optimized-function-p - (call-store-method-optimized-function-p - generic-function method initargs)) - (store-closure-generator-p - (call-store-closure-generator-p - generic-function method initargs)) - (standard-method-lambda-p - (and (equal (caddr method-lambda) - *standard-pcl-make-method-lambda-doc-string*) - optimized-method-lambda))) - (when (and (not standard-method-lambda-p) - store-method-optimized-function-p) - ;; Somebody modified make-method-lambda, but didn't specify that - ;; the generic-function doesn't use method-optimized-function. So, - ;; to be safe, define the optimized-method-lambda to just call the - ;; method-lambda code they returned with the default method lambda - ;; arguments of the generic-function-args and *next-methods*. - ;; For efficiency, the user should redefine - ;; compute-discriminating-function to directly call method-function - ;; rather than method-function-for-caching, and optionally define - ;; a generic-function-uses-method-optimized-function-p method on - ;; the generic-function/method class to return nil so no dummy - ;; optimized-method-function is created. - ;; Alternatively, if the new make-method-lambda returns a lambda - ;; with the same arguments as a normal method lambda, then the - ;; make-method-lambda could be designed analogous to the one on - ;; standard-generic-function/standard-method, and making sure that - ;; the CADDR of the method-lambda returned equals - ;; *standard-pcl-make-method-lambda-doc-string* to signify - ;; that it's safe to use the *optimized-method-lambda* returned. - (setf optimized-method-lambda - `(lambda (&rest generic-function-args) - (method-function-funcall (function ,method-lambda) - generic-function-args - (mapcar #'method-function-method - *next-methods*))))) - (values (when store-method-function-p - method-lambda) - (when store-method-optimized-function-p - optimized-method-lambda) - (when store-closure-generator-p - (call-make-closure-generator-form generic-function method - optimized-method-lambda initargs)) - initargs))))) - -(defun make-std-documented-method-function (optimized-function) - ;; Make a standard documented method-function out of optimized-function. - #'(lambda (args &rest next-methods) - (let ((*next-methods* - (mapcar #'(lambda (method) - (or (method-optimized-function method) - (method-function-for-caching - method - (mapcar #'pcl::wrapper-of args)))) - next-methods))) - (method-function-apply optimized-function args)))) - -(defun early-make-method-lambda (generic-function ; will be nil - method ; will be nil - lambda-expression - environment) - (multiple-value-bind (optimized-method-lambda initargs) - (make-optimized-standard-method-lambda generic-function method - lambda-expression environment) - (setf *optimized-method-lambda* optimized-method-lambda) - (values - (make-documented-standard-method-lambda - lambda-expression - environment - *standard-pcl-make-method-lambda-doc-string* - (getf initargs :identifier)) - initargs))) - -(defun make-optimized-standard-method-lambda - (generic-function method lambda-expression environment) - ;; Make the standard PCL rev4b optimized method lambda from - ;; the old expand-method-internal. - (let* ((method-lambda lambda-expression) - (lambda-list (cadr lambda-expression)) - (required-parameters - (let ((collecting NIL)) - (dolist (parameter lambda-list collecting) - (if (memq parameter lambda-list-keywords) - (return collecting) - (setf collecting (nconc collecting (list parameter))))))) - - (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 - ;or #'next-method-p 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 - (this-method-p nil) ;flag indicating that this-method - ;should be in the method definition - (save-original-args nil) ;flag indicating whether or not the - ;original arguments to the method - ;must be preserved. This happens - ;for two reasons: - ; - the method takes &mumble args, - ; so one of the lexical functions - ; might be used in a default value - ; form - ; - call-next-method is used without - ; arguments at least once in the - ; body of the method - (original-args ()) - (mumblep nil) ;flag indicating whether or not the - ;method takes &mumble arguments - (applyp nil) ;flag indicating whether or not the - ;method takes &mumble arguments -- - ;and call-next-method or next-method-p - ;was seen within their defaults - ;somewhere. If it does, it means - ;call-next-method without arguments - ;must be APPLY'd to original-args. - ;If this gets set true, - ;save-original-args is set so as well - (aux-bindings ()) ;Suffice to say that &aux is one of - ;damndest things to have put in a - ;language. - (slots (mapcar #'list required-parameters)) - - (real-body *expand-defmethod-internal-real-body*) - (constant-value-p (and real-body - (null (cdr real-body)) - (constantp (car real-body)))) - (constant-value (and constant-value-p - (eval (car real-body)))) - (plist (if (and constant-value-p - (or (typep constant-value '(or number character)) - (and (symbolp constant-value) - (symbol-package constant-value)))) - (list :constant-value constant-value) - ())) - - (walked-lambda nil)) - (labels - ((walk-function (form context environment) - (cond ((not (eq context ':eval)) form) - ((not (listp form)) form) - ((eq (car form) 'call-next-method) - (setq call-next-method-p 't) - (unless (cdr form) - (setq save-original-args t)) - form) - ((eq (car form) 'next-method-p) - (setq next-method-p-p 't) - form) - ((eq (car form) 'this-method) - (setq this-method-p 't) - form) - ((and (eq (car form) 'function) - (cond ((eq (cadr form) 'call-next-method) - (setq call-next-method-p 't) - (setq save-original-args 't) - (setq closurep t) - form) - ((eq (cadr form) 'next-method-p) - (setq next-method-p-p 't) - (setq closurep t) - form) - ((eq (cadr form) 'this-method) - (setq this-method-p 't) - (setq closurep t) - form) - (t nil)))) - ((and (or (eq (car form) 'slot-value) - (eq (car form) 'set-slot-value) - (eq (car form) 'slot-boundp)) - (constantp (caddr form))) - (let ((parameter - (can-optimize-access - form required-parameters environment))) - (ecase (car form) - (slot-value - (optimize-slot-value generic-function method - slots parameter form)) - (set-slot-value - (optimize-set-slot-value generic-function method - slots parameter form)) - (slot-boundp - (optimize-slot-boundp generic-function method - slots parameter form))))) - ((and (or (symbolp (car form)) - (and (consp (car form)) - (eq (caar form) 'setf))) - (gboundp (car form)) - (if (eq *boot-state* 'complete) - (standard-generic-function-p (gdefinition (car form))) - (funcallable-instance-p (gdefinition (car form))))) - (optimize-generic-function-call form required-parameters - environment)) - (t form))) - (need-applyp (form) - (if (consp form) - (or (need-applyp (car form)) (need-applyp (cdr form))) - (memq form '(call-next-method next-method-p this-method))))) - - (setq walked-lambda (walk-form method-lambda environment #'walk-function)) - - ;; - ;; Add &allow-other-keys to the lambda list as an interim - ;; way of implementing lambda list congruence rules. - ;; - (when (and (memq '&key lambda-list) - (not (memq '&allow-other-keys lambda-list))) - (let* ((rll (reverse lambda-list)) - (aux (memq '&aux rll))) - (setq lambda-list - (if aux - (progn (setf (cdr aux) - (cons '&allow-other-keys (cdr aux))) - (nreverse rll)) - (nconc (nreverse rll) (list '&allow-other-keys)))))) - ;; Scan the lambda list to determine whether this method - ;; takes &mumble arguments. If it does, we set save-original-args - ;; and mumblep true. We also check to see if a call-next-method or - ;; next-method-p is somewhere within the argument default value - ;; forms. If so, we set applyp to T. - ;; - ;; (Note: This is an optimization of the applyp restriction of - ;; March 92 and earlier, which always set it to true if there - ;; were any &mumble arguments. I can't see this causing any - ;; problems. -- TL) - ;; - ;; This is also the place where we construct the original - ;; arguments lambda list if there has to be one. - (dolist (p lambda-list) - (if (memq p lambda-list-keywords) - (if (eq p '&aux) - (progn - (setq aux-bindings (cdr (memq '&aux lambda-list))) - (return nil)) - (progn - (setq mumblep T - applyp (need-applyp lambda-list) - save-original-args t) - (push '&rest original-args) - (push (make-symbol "AMPERSAND-ARGS") original-args) - (return nil))) - (push (make-symbol (symbol-name p)) original-args))) - (setq original-args (if save-original-args - (nreverse original-args) - ())) - - (multiple-value-bind (ignore walked-declarations walked-lambda-body) - (extract-declarations (cddr walked-lambda)) - (declare (ignore ignore)) - - - (when (some #'cdr slots) - (setq plist - (list* :optimized-slot-indices - (mapcan #'(lambda (parameter-entry) - (mapcar #'(lambda (slot-entry) - (cons (car parameter-entry) - slot-entry)) - (cdr parameter-entry))) - slots) - plist))) - (setq plist - (list* :needs-next-methods-p - (or next-method-p-p call-next-method-p) - plist)) - - ;;; changes are here... (mt) - (let ((fn-body `(lambda ,lambda-list - ,@walked-declarations - ,.walked-lambda-body)) - (method-identifier - (when (or this-method-p call-next-method-p) - (gentemp - (if method - (symbol-name (class-name (class-of method))) - "STANDARD-METHOD"))))) - (when method-identifier - (setf plist (list* :identifier method-identifier plist))) - (when (or call-next-method-p next-method-p-p this-method-p) - (setq fn-body - (add-lexical-functions-to-optimized-standard-method-lambda - walked-declarations - walked-lambda-body - fn-body - original-args - lambda-list - save-original-args - mumblep - applyp - aux-bindings - call-next-method-p - next-method-p-p - this-method-p - closurep - method-identifier))) - (when (call-store-optimized-method-lambda-p - generic-function method plist) - (setf plist (list* :optimized-method-lambda fn-body plist))) - (values - fn-body - plist)))))) - -(defmacro add-lexical-functions-to-optimized-1 - (lambda-list walked-lambda-body call-next-method-p next-method-p-p - this-method-p identifier) - ;; OK to use MACROLET, CALL-NEXT-METHOD is always passed some args, - ;; and all args are mandatory (else APPLYP would be true). - `(let (,@(when (or next-method-p-p call-next-method-p) - `((.next-method. (car *next-methods*)))) - ,@(when call-next-method-p - `((.next-methods. (cdr *next-methods*))))) - (macrolet (,@(when this-method-p - `((this-method () - `(get-method-from-identifier ',',identifier)))) - ,@(when call-next-method-p - `((call-next-method ,lambda-list - `(if .next-method. - (let ((*next-methods* .next-methods.)) - (method-function-funcall - .next-method. ,,@lambda-list)) - (no-next-method-trap - ',',identifier ,,@lambda-list))))) - ,@(when next-method-p-p - `((next-method-p () `(not (null .next-method.)))))) - ,@walked-lambda-body))) - -(defmacro add-lexical-functions-to-optimized-2 - (lambda-list walked-declarations walked-lambda-body original-args - aux-bindings call-next-method-p next-method-p-p this-method-p identifier) - ;; OK to use MACROLET. CALL-NEXT-METHOD is sometimes called in the - ;; body with zero args, so we have to save the original args. - `(let (,@(when (or next-method-p-p call-next-method-p) - `((.next-method. (car *next-methods*)))) - ,@(when call-next-method-p - `((.next-methods. (cdr *next-methods*))))) - (macrolet (,@(when this-method-p - `((this-method () - `(get-method-from-identifier ',',identifier)))) - ,@(when call-next-method-p - `((call-next-method (&rest cnm-args) - `(if .next-method. - (let ((*next-methods* .next-methods.)) - (method-function-funcall - .next-method. - ,@(if cnm-args cnm-args ',original-args))) - (no-next-method-trap ',',identifier ,@cnm-args))))) - ,@(when next-method-p-p - '((next-method-p () - `(not (null .next-method.)))))) - (let* (,@(mapcar #'list lambda-list original-args) - ,@aux-bindings) - ,@walked-declarations - ,@walked-lambda-body)))) - -(defmacro add-lexical-functions-to-optimized-3 - (walked-lambda original-args call-next-method-p next-method-p-p - this-method-p identifier) - ;; OK to use MACROLET. CALL-NEXT-METHOD is sometimes called in the - ;; body with zero args, so we have to save the original args. - `(let (,@(when (or next-method-p-p call-next-method-p) - `((.next-method. (car *next-methods*)))) - ,@(when call-next-method-p - `((.next-methods. (cdr *next-methods*))))) - (macrolet (,@(when this-method-p - `((this-method () - `(get-method-from-identifier ',',identifier)))) - ,@(when call-next-method-p - `((call-next-method (&rest cnm-args) - `(if .next-method. - (let ((*next-methods* .next-methods.)) - ,(if cnm-args - `(method-function-funcall - .next-method. ,@cnm-args) - `(method-function-apply - .next-method. - ,@',(remove '&rest original-args)))) - (no-next-method-trap ',',identifier ,@cnm-args))))) - ,@(when next-method-p-p - '((next-method-p () - `(not (null .next-method.)))))) - (method-function-apply (function ,walked-lambda) - ,@(remove '&rest original-args))))) - -(defmacro add-lexical-functions-to-optimized-4 - (walked-lambda-body call-next-method-p next-method-p-p - this-method-p identifier) - ;; - ;; We don't have to save the original arguments. In addition, - ;; this method doesn't take any &mumble arguments that have - ;; the lexical functions inside their default value forms. - ;; Closurep is true, however, so the there might be an - ;; (apply #'call-next-method...), so we can't use MACROLET. - ;; - ;; We can expand this into a simple lambda expression with an - ;; FLET to define the lexical functions. - ;; - `(let (,@(when (or next-method-p-p call-next-method-p) - `((.next-method. (car *next-methods*)))) - ,@(when call-next-method-p - `((.next-methods. (cdr *next-methods*))))) - (flet (,@(and this-method-p - `((this-method () - (get-method-from-identifier ',identifier)))) - ,@(and call-next-method-p - `((call-next-method (&rest cnm-args) - #+Genera - (declare (dbg:invisible-frame :clos-internal)) - (if .next-method. - (let ((*next-methods* .next-methods.)) - (method-function-apply .next-method. cnm-args)) - (apply #'no-next-method-trap - ',identifier cnm-args))))) - ,@(and next-method-p-p - '((next-method-p () - (not (null .next-method.)))))) - ,@walked-lambda-body))) - -(defmacro add-lexical-functions-to-optimized-5 - (lambda-list walked-declarations walked-lambda-body original-args - aux-bindings call-next-method-p next-method-p-p this-method-p identifier) - ;; - ;; This method doesn't accept any &mumble arguments that - ;; might try to call call-next-method or next-method-p. But we - ;; do have to save the original arguments (this is because - ;; call-next-method is being called with no arguments). - ;; Have to be careful though, there may be multiple calls to - ;; call-next-method, all we know is that at least one of them - ;; is with no arguments. - ;; - `(let (,@(when (or next-method-p-p call-next-method-p) - `((.next-method. (car *next-methods*)))) - ,@(when call-next-method-p - `((.next-methods. (cdr *next-methods*))))) - (flet (,@(and this-method-p - `((this-method () - (get-method-from-identifier ',identifier)))) - ,@(and call-next-method-p - `((call-next-method (&rest cnm-args) - (if .next-method. - (let ((*next-methods* .next-methods.)) - (if cnm-args - (method-function-apply .next-method. cnm-args) - (method-function-funcall - .next-method. ,@original-args))) - (apply #'no-next-method-trap - ',identifier cnm-args))))) - ,@(and next-method-p-p - '((next-method-p () - (not (null .next-method.)))))) - (let* (,@(mapcar #'list - (remtail lambda-list (memq '&aux lambda-list)) - original-args) - ,@aux-bindings) - ,@walked-declarations - ,@walked-lambda-body)))) - -(defmacro add-lexical-functions-to-optimized-6 - (walked-lambda original-args call-next-method-p next-method-p-p - this-method-p identifier) - ;; - ;; This is the fully general case. - ;; We must allow for the lexical functions being used inside - ;; the default value forms of &mumble arguments, and if must - ;; allow for call-next-method being called with no arguments. - ;; - `(let (,@(when (or next-method-p-p call-next-method-p) - `((.next-method. (car *next-methods*)))) - ,@(when call-next-method-p - `((.next-methods. (cdr *next-methods*))))) - (flet (,@(and this-method-p - `((this-method () - (get-method-from-identifier ',identifier)))) - ,@(and call-next-method-p - `((call-next-method (&rest cnm-args) - (if .next-method. - (let ((*next-methods* .next-methods.)) - (if cnm-args - (method-function-apply .next-method. cnm-args) - (method-function-apply - .next-method. - ,@(remove '&rest original-args)))) - (apply #'no-next-method-trap - ',identifier cnm-args))))) - ,@(and next-method-p-p - '((next-method-p () - (not (null .next-method.)))))) - (method-function-apply (function ,walked-lambda) - ,@(remove '&rest original-args))))) - -(defun add-lexical-functions-to-optimized-standard-method-lambda - (walked-declarations - walked-lambda-body - walked-lambda - original-args - lambda-list - save-original-args - mumblep - applyp - aux-bindings - call-next-method-p - next-method-p-p - this-method-p - closurep - identifier) - (cond ((and (null closurep) - (null applyp) - (null save-original-args)) - ;; OK to use MACROLET, CALL-NEXT-METHOD is always passed some args, - ;; and all args are mandatory (else APPLYP would be true). - `(lambda ,lambda-list - ,@walked-declarations - (add-lexical-functions-to-optimized-1 - ,lambda-list ,walked-lambda-body ,call-next-method-p - ,next-method-p-p ,this-method-p ,identifier))) - ((and (null closurep) - (null mumblep) - (null applyp) - save-original-args) - ;; OK to use MACROLET. CALL-NEXT-METHOD is sometimes called in the - ;; body with zero args, so we have to save the original args. - `(lambda ,original-args - (add-lexical-functions-to-optimized-2 - ,lambda-list ,walked-declarations ,walked-lambda-body - ,original-args ,aux-bindings ,call-next-method-p ,next-method-p-p - ,this-method-p ,identifier))) - ((and (null closurep) - (null applyp) - save-original-args) - ;; OK to use MACROLET. CALL-NEXT-METHOD is sometimes called in the - ;; body with zero args, so we have to save the original args. - `(lambda ,original-args - (add-lexical-functions-to-optimized-3 - ,walked-lambda ,original-args ,call-next-method-p - ,next-method-p-p ,this-method-p ,identifier))) - ((and (null save-original-args) - (null mumblep)) - ;; - ;; We don't have to save the original arguments. In addition, - ;; this method doesn't take any &mumble arguments that have - ;; the lexical functions inside their default value forms. - ;; Closurep is true, however, so the there might be an - ;; (apply #'call-next-method...), so we can't use MACROLET. - ;; - ;; We can expand this into a simple lambda expression with an - ;; FLET to define the lexical functions. - ;; - `(lambda ,lambda-list - ,@walked-declarations - (add-lexical-functions-to-optimized-4 - ,walked-lambda-body ,call-next-method-p ,next-method-p-p - ,this-method-p ,identifier))) - ((null mumblep) - ;; - ;; This method doesn't accept any &mumble arguments that - ;; might try to call call-next-method or next-method-p. But we - ;; do have to save the original arguments (this is because - ;; call-next-method is being called with no arguments). - ;; Have to be careful though, there may be multiple calls to - ;; call-next-method, all we know is that at least one of them - ;; is with no arguments. - ;; - `(lambda ,original-args - (add-lexical-functions-to-optimized-5 - ,lambda-list ,walked-declarations ,walked-lambda-body - ,original-args ,aux-bindings ,call-next-method-p ,next-method-p-p - ,this-method-p ,identifier))) - (t - ;; - ;; This is the fully general case. - ;; We must allow for the lexical functions being used inside - ;; the default value forms of &mumble arguments, and if must - ;; allow for call-next-method being called with no arguments. - ;; - `(lambda ,original-args - (add-lexical-functions-to-optimized-6 - ,walked-lambda ,original-args ,call-next-method-p - ,next-method-p-p ,this-method-p ,identifier))))) - - -(defun make-documented-standard-method-lambda (lambda-expression - environment - &optional - documentation - method-identifier) - ;; Make the lambda for the documented AMOP method-function. - ;; This is basically the same as make-optimized-standard-method-lambda, - ;; except in the form need for the documented method-functions of standard - ;; method lambda. Because the documented standard method functions aren't - ;; normally used in PCL's method dispatch, and only exist for correspondence - ;; to the AMOP in case somebody needs it, the code produced here is not as - ;; optimized as that produced by make-optimized-standard-method-lambda. - ;; In particular, it does not perform any of the normal permutation-vector - ;; optimizations for slot-value, and doesn't do anything tricky to optimized - ;; call-next-methods (add-lexical-functions-to-documented-standard-method-lambda). - (let* ((method-lambda lambda-expression) - (lambda-list (cadr lambda-expression)) - (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 - ;or #'next-method-p 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 - (this-method-p nil) ;flag indicating that this-method - ;should be in the method definition - (save-original-args nil) ;flag indicating whether or not the - ;original arguments to the method - ;must be preserved. This happens - ;for two reasons: - ; - the method takes &mumble args, - ; so one of the lexical functions - ; might be used in a default value - ; form - ; - call-next-method is used without - ; arguments at least once in the - ; body of the method - (original-args ()) - (mumblep nil) ;flag indicating whether or not the - ;method takes &mumble arguments - (applyp nil) ;flag indicating whether or not the - ;method takes &mumble arguments -- - ;and call-next-method or next-method-p - ;was seen within their defaults - ;somewhere. If it does, it means - ;call-next-method without arguments - ;must be APPLY'd to original-args. - ;If this gets set true, - ;save-original-args is set so as well - (aux-bindings ()) ;Suffice to say that &aux is one of - ;damndest things to have put in a - ;language. - (plist ()) - (walked-lambda nil)) - (labels - ((walk-function (form context environment) - (declare (ignore environment)) - (cond ((not (eq context ':eval)) form) - ((not (listp form)) form) - ((eq (car form) 'call-next-method) - (setq call-next-method-p 't) - (unless (cdr form) - (setq save-original-args t)) - form) - ((eq (car form) 'next-method-p) - (setq next-method-p-p 't) - form) - ((eq (car form) 'this-method) - (setq this-method-p 't) - form) - ((and (eq (car form) 'function) - (cond ((eq (cadr form) 'call-next-method) - (setq call-next-method-p 't) - (setq save-original-args 't) - (setq closurep t) - form) - ((eq (cadr form) 'next-method-p) - (setq next-method-p-p 't) - (setq closurep t) - form) - ((eq (cadr form) 'this-method) - (setq this-method-p 't) - (setq closurep t) - form) - (t nil)))) - ;; We don't try to optimize slot values for the - ;; documented method lambdas, since they're never - ;; really used anyway. - (t form))) - (need-applyp (form) - (if (consp form) - (or (need-applyp (car form)) (need-applyp (cdr form))) - (memq form '(call-next-method next-method-p this-method))))) - - (setq walked-lambda (walk-form method-lambda environment #'walk-function)) - - ;; - ;; Add &allow-other-keys to the lambda list as an interim - ;; way of implementing lambda list congruence rules. - ;; - (when (and (memq '&key lambda-list) - (not (memq '&allow-other-keys lambda-list))) - (let* ((rll (reverse lambda-list)) - (aux (memq '&aux rll))) - (setq lambda-list - (if aux - (progn (setf (cdr aux) - (cons '&allow-other-keys (cdr aux))) - (nreverse rll)) - (nconc (nreverse rll) (list '&allow-other-keys)))))) - ;; Scan the lambda list to determine whether this method - ;; takes &mumble arguments. If it does, we set save-original-args - ;; and mumblep true. We also check to see if a call-next-method or - ;; next-method-p is somewhere within the argument default value - ;; forms. If so, we set applyp to T. - ;; - ;; (Note: This is an optimization of the applyp restriction of - ;; Rev4b and earlier, which always set it to true if there - ;; were any &mumble arguments. I can't see this causing any - ;; problems. -- TL) - ;; - ;; This is also the place where we construct the original - ;; arguments lambda list if there has to be one. - (dolist (p lambda-list) - (if (memq p lambda-list-keywords) - (if (eq p '&aux) - (progn - (setq aux-bindings (cdr (memq '&aux lambda-list))) - (return nil)) - (progn - (setq mumblep T - applyp (need-applyp lambda-list) - save-original-args t) - (push '&rest original-args) - (push (make-symbol "AMPERSAND-ARGS") original-args) - (return nil))) - (push (make-symbol (symbol-name p)) original-args))) - (setq original-args (if save-original-args - (nreverse original-args) - ())) - - (multiple-value-bind (ignore walked-declarations walked-lambda-body) - (extract-declarations (cddr walked-lambda)) - (declare (ignore ignore)) - - (setq plist - (list* :needs-next-methods-p (or next-method-p-p call-next-method-p) - plist)) - - ;;; changes are here... (mt) - (let ((fn-body - `(lambda ,lambda-list - ,@walked-declarations - ,.walked-lambda-body))) - (if (or call-next-method-p next-method-p-p this-method-p) - (setf fn-body - (add-lexical-functions-to-documented-standard-method-lambda - walked-declarations - walked-lambda-body - fn-body - original-args - lambda-list - save-original-args - mumblep - applyp - aux-bindings - call-next-method-p - next-method-p-p - this-method-p - closurep - documentation - method-identifier)) - (setf fn-body - `(lambda (args &rest next-methods) - ,@(when documentation - (list documentation)) - (declare (ignore next-methods)) - (apply #',fn-body args)))) - (values - fn-body - plist)))))) - -(defmacro add-lexical-functions-to-documented-general - (walked-lambda call-next-method-p next-method-p-p this-method-p identifier) - ;; - ;; This is the fully general case. - ;; We must allow for the lexical functions being used inside - ;; the default value forms of &mumble arguments, and if must - ;; allow for call-next-method being called with no arguments. - ;; - `(let (,@(when (or next-method-p-p call-next-method-p) - `((.next-method. (car next-methods)))) - ,@(when call-next-method-p - `((.next-methods. (cdr next-methods))))) - (flet (,@(and this-method-p - `((this-method () - (get-method-from-identifier ',identifier)))) - ,@(and call-next-method-p - `((call-next-method (&rest cnm-args) - (if .next-method. - (method-function-funcall - (method-function .next-method.) - (or cnm-args args) - .next-methods.) - (no-next-method-trap ',identifier cnm-args))))) - ,@(and next-method-p-p - '((next-method-p () - (not (null .next-method.)))))) - (method-function-apply (function ,walked-lambda) args)))) - -(defun add-lexical-functions-to-documented-standard-method-lambda - (walked-declarations - walked-lambda-body - walked-lambda - original-args - lambda-list - save-original-args - mumblep - applyp - aux-bindings - call-next-method-p - next-method-p-p - this-method-p - closurep - documentation - identifier) - (declare (ignore walked-declarations walked-lambda-body original-args - lambda-list save-original-args mumblep applyp aux-bindings - closurep)) - ;; This could produce more efficient code by using the special case tricks - ;; of add-lexical-functions-to-optimized-standard-method-lambda, - ;; but documented method lambda's aren't normally used, so it wasn't - ;; worth doing here. - ;; NOTE: Contents of documentation must appear in the CADDR of the - ;; lambda list returned as shown here to keep tricks of make-method-lambda - ;; happy (so it knows that the make-method-lambda used the standard - ;; return method.) - (cond (t - ;; - ;; This is the fully general case. - ;; We must allow for the lexical functions being used inside - ;; the default value forms of &mumble arguments, and if must - ;; allow for call-next-method being called with no arguments. - ;; - `(lambda (args &rest next-methods) - ,@(when documentation - (list documentation)) - (add-lexical-functions-to-documented-general - ,walked-lambda ,call-next-method-p ,next-method-p-p - ,this-method-p ,identifier))))) - - - -(defun no-next-method-trap (method-identifier &rest args) - (let ((method (get-method-from-identifier method-identifier))) - (if (and method method-identifier) - (apply #'no-next-method (method-generic-function method) method args) - (error "No next method.")))) + (extract-declarations (cddr method-lambda) env) + (let* ((name-decl (get-declaration 'method-name declarations)) + (sll-decl (get-declaration 'method-lambda-list declarations)) + (method-name (when (consp name-decl) (car name-decl))) + (generic-function-name (when method-name (car method-name))) + (specialized-lambda-list (or sll-decl (cadr method-lambda)))) + (multiple-value-bind (parameters lambda-list specializers) + (parse-specialized-lambda-list specialized-lambda-list) + (let* ((required-parameters + (mapcar #'(lambda (r s) (declare (ignore s)) r) + parameters + specializers)) + (slots (mapcar #'list required-parameters)) + (calls (list nil)) + (parameters-to-reference + (make-parameter-references specialized-lambda-list + required-parameters + declarations + method-name + specializers)) + (class-declarations + `(declare + ,@(remove nil + (mapcar #'(lambda (a s) (and (symbolp s) + (neq s 't) + `(class ,a ,s))) + parameters + specializers)))) + (method-lambda + ;; Remove the documentation string and insert the + ;; appropriate class declarations. The documentation + ;; string is removed to make it easy for us to insert + ;; new declarations later, they will just go after the + ;; cadr of the method lambda. The class declarations + ;; are inserted to communicate the class of the method's + ;; arguments to the code walk. + `(lambda ,lambda-list + ,class-declarations + ,@declarations + (progn ,@parameters-to-reference) + (block ,(if (listp generic-function-name) + (cadr generic-function-name) + generic-function-name) + ,@real-body))) + (constant-value-p (and (null (cdr real-body)) + (constantp (car real-body)))) + (constant-value (and constant-value-p + (eval (car real-body)))) + (plist (if (and constant-value-p + (or (typep constant-value '(or number character)) + (and (symbolp constant-value) + (symbol-package constant-value)))) + (list :constant-value constant-value) + ())) + (applyp (dolist (p lambda-list nil) + (cond ((memq p '(&optional &rest &key)) + (return t)) + ((eq p '&aux) + (return nil)))))) + (multiple-value-bind (walked-lambda call-next-method-p closurep + next-method-p-p) + (walk-method-lambda method-lambda required-parameters env + slots calls) + (multiple-value-bind (ignore walked-declarations walked-lambda-body) + (extract-declarations (cddr walked-lambda)) + (declare (ignore ignore)) + (when (or next-method-p-p call-next-method-p) + (setq plist (list* :needs-next-methods-p 't plist))) + (when (some #'cdr slots) + (multiple-value-bind (slot-name-lists call-list) + (slot-name-lists-from-slots slots calls) + (let ((pv-table-symbol (make-symbol "pv-table"))) + (setq plist + `(,@(when slot-name-lists + `(:slot-name-lists ,slot-name-lists)) + ,@(when call-list + `(:call-list ,call-list)) + :pv-table-symbol ,pv-table-symbol + ,@plist)) + (setq walked-lambda-body + `((pv-binding (,required-parameters ,slot-name-lists + ,pv-table-symbol) + ,@walked-lambda-body)))))) + (when (and (memq '&key lambda-list) + (not (memq '&allow-other-keys lambda-list))) + (let ((aux (memq '&aux lambda-list))) + (setq lambda-list (nconc (ldiff lambda-list aux) + (list '&allow-other-keys) + aux)))) + (values `(lambda (.method-args. .next-methods.) + (simple-lexical-method-functions + (,lambda-list .method-args. .next-methods. + :call-next-method-p ,call-next-method-p + :next-method-p-p ,next-method-p-p + :closurep ,closurep + :applyp ,applyp) + ,@walked-declarations + ,@walked-lambda-body)) + `(,@(when plist + `(:plist ,plist)) + ,@(when documentation + `(:documentation ,documentation))))))))))) + +(unless (fboundp 'make-method-lambda) + (setf (symbol-function 'make-method-lambda) + (symbol-function 'real-make-method-lambda))) + +(defmacro simple-lexical-method-functions ((lambda-list method-args next-methods + &rest lmf-options) + &body body) + `(progn + ,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) + ,@body))))) + +(defmacro fast-lexical-method-functions ((lambda-list next-method-call args rest-arg + &rest lmf-options) + &body body) + `(bind-fast-lexical-method-macros (,args ,rest-arg ,next-method-call) + (bind-lexical-method-functions (,@lmf-options) + (bind-args (,(nthcdr (length args) lambda-list) ,rest-arg) + ,@body)))) + +(defmacro bind-simple-lexical-method-macros ((method-args next-methods) &body body) + `(macrolet ((call-next-method-bind (&body body) + `(let ((.next-method. (car ,',next-methods)) + (,',next-methods (cdr ,',next-methods))) + .next-method. ,',next-methods + ,@body)) + (call-next-method-body (cnm-args) + `(if .next-method. + (funcall (if (std-instance-p .next-method.) + (method-function .next-method.) + .next-method.) ; for early methods + (or ,cnm-args ,',method-args) + ,',next-methods) + (error "No next method."))) + (next-method-p-body () + `(not (null .next-method.)))) + ,@body)) + +(defstruct method-call + (function #'identity :type function) + call-method-args) + +(defmacro invoke-method-call1 (function args cm-args) + `(let ((.function. ,function) + (.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.)))) + +(defmacro invoke-method-call (method-call restp &rest required-args+rest-arg) + `(invoke-method-call1 (method-call-function ,method-call) + ,(if restp + `(list* ,@required-args+rest-arg) + `(list ,@required-args+rest-arg)) + (method-call-call-method-args ,method-call))) + +(defstruct fast-method-call + (function #'identity :type function) + pv-cell + next-method-call + arg-info) + +#-akcl +(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)) + +(defstruct fast-instance-boundp + (index 0 :type fixnum)) + +(eval-when (compile load eval) +(defvar *allow-emf-call-tracing-p* t) +(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*) + (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) + `(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")) + (setq restp (eval restp)) + `(progn + (trace-emf-call ,emf ,restp (list ,@required-args+rest-arg)) + (cond (#-(or lucid excl) (typep ,emf 'fast-method-call) + #+(or lucid excl) (fast-method-call-p ,emf) + (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 ,(car required-args+rest-arg)))) + (and .slots. + (not (eq (%instance-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 ,emf ,@required-args+rest-arg) + `(funcall ,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)) + (restp (cdr arg-info)) + (nreq (car arg-info))) + (if restp + (let* ((rest-args (nthcdr nreq args)) + (req-args (ldiff args rest-args))) + (apply (fast-method-call-function emf) + (fast-method-call-pv-cell emf) + (fast-method-call-next-method-call emf) + (nconc req-args (list rest-args)))) + (cond ((null args) + (if (eql nreq 0) + (invoke-fast-method-call emf) + (error "wrong number of args"))) + ((null (cdr args)) + (if (eql nreq 1) + (invoke-fast-method-call emf (car args)) + (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"))) + (t + (apply (fast-method-call-function emf) + (fast-method-call-pv-cell emf) + (fast-method-call-next-method-call emf) + args)))))) + (method-call + (apply (method-call-function emf) + args + (method-call-call-method-args emf))) + (fixnum + (cond ((null args) (error "1 or 2 args expected")) + ((null (cdr args)) + (let ((value (%instance-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) + (car args))) + (t (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)) + *slot-unbound*)))) + (function + (apply emf args)))) + +;; This can be improved alot. +(defun gf-make-function-from-emf (gf emf) + (etypecase emf + (fast-method-call (let* ((arg-info (gf-arg-info gf)) + (nreq (arg-info-number-required arg-info)) + (restp (arg-info-applyp arg-info))) + #'(lambda (&rest args) + (trace-emf-call emf t args) + (apply (fast-method-call-function emf) + (fast-method-call-pv-cell emf) + (fast-method-call-next-method-call emf) + (if restp + (let* ((rest-args (nthcdr nreq args)) + (req-args (ldiff args rest-args))) + (nconc req-args rest-args)) + args))))) + (method-call #'(lambda (&rest args) + (trace-emf-call emf t args) + (apply (method-call-function emf) + args + (method-call-call-method-args emf)))) + (function emf))) + +(defmacro bind-fast-lexical-method-macros ((args rest-arg next-method-call) + &body body) + `(macrolet ((call-next-method-bind (&body body) + `(let () ,@body)) + (call-next-method-body (cnm-args) + `(if ,',next-method-call + ,(if (and (null ',rest-arg) + (consp cnm-args) + (eq (car cnm-args) 'list)) + `(invoke-effective-method-function + ,',next-method-call nil + ,@(cdr cnm-args)) + (let ((call `(invoke-effective-method-function + ,',next-method-call + ,',(not (null rest-arg)) + ,@',args + ,@',(when rest-arg `(,rest-arg))))) + `(if ,cnm-args + (bind-args ((,@',args ,@',(when rest-arg + `(&rest ,rest-arg))) + ,cnm-args) + ,call) + ,call))) + (error "No next method."))) + (next-method-p-body () + `(not (null ,',next-method-call)))) + ,@body)) + +(defmacro bind-lexical-method-functions + ((&key call-next-method-p next-method-p-p closurep applyp) + &body body) + (cond ((and (null call-next-method-p) (null next-method-p-p) + (null closurep) + (null applyp)) + `(let () ,@body)) + ((and (null closurep) + (null applyp)) + ;; OK to use MACROLET, and all args are mandatory + ;; (else APPLYP would be true). + `(call-next-method-bind + (macrolet ((call-next-method (&rest cnm-args) + `(call-next-method-body ,(when cnm-args `(list ,@cnm-args)))) + (next-method-p () + `(next-method-p-body))) + ,@body))) + (t + `(call-next-method-bind + (flet (,@(and call-next-method-p + '((call-next-method (&rest cnm-args) + #+Genera + (declare (dbg:invisible-frame :clos-internal)) + (call-next-method-body cnm-args)))) + ,@(and next-method-p-p + '((next-method-p () + (next-method-p-body))))) + ,@body))))) + +(defmacro bind-args ((lambda-list args) &body body) + #|| ; Lucid and Allegro don't compile the function inline + `(apply #'(lambda ,lambda-list ,@body) ,args) + ||# + (let ((args-tail '.args-tail.) + (key '.key.) + (state 'required)) + (flet ((process-var (var) + (if (memq var lambda-list-keywords) + (progn + (case var + (&optional (setq state 'optional)) + (&key (setq state 'key)) + (&allow-other-keys) + (&rest (setq state 'rest)) + (&aux (setq state 'aux)) + (otherwise + (error "Encountered the non-standard lambda list keyword ~S." + var))) + nil) + (case state + (required `((,var (pop ,args-tail)))) + (optional (cond ((not (consp var)) + `((,var (when ,args-tail (pop ,args-tail))))) + ((null (cddr var)) + `((,(car var) (if ,args-tail + (pop ,args-tail) + ,(cadr var))))) + (t + `((,(caddr var) ,args-tail) + (,(car var) (if ,args-tail + (pop ,args-tail) + ,(cadr var))))))) + (rest `((,var ,args-tail))) + (key (cond ((not (consp var)) + `((,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-arg1 ,keyword ,args-tail)) + (,variable (if (consp ,key) + (car ,key) + ,(cadr var)))))) + (t + (multiple-value-bind (keyword variable) + (if (consp (car var)) + (values (caar var) (cadar var)) + (values (make-keyword (car var)) (car var))) + `((,key (get-key-arg1 ,keyword ,args-tail)) + (,(caddr var) ,key) + (,variable (if (consp ,key) + (car ,key) + ,(cadr var)))))))) + (aux `(,var)))))) + (let ((bindings (mapcan #'process-var lambda-list))) + `(let* ((,args-tail ,args) + ,@bindings) + ,@(unless bindings `((declare (ignore ,args-tail)))) + ,@body))))) + +(defun get-key-arg (keyword list) + (loop (when (atom list) (return nil)) + (when (eq (car list) keyword) (return (cadr list))) + (setq list (cddr list)))) + +(defun get-key-arg1 (keyword list) + (loop (when (atom list) (return nil)) + (when (eq (car list) keyword) (return (cdr list))) + (setq list (cddr list)))) + +(defun walk-method-lambda (method-lambda required-parameters env slots calls) + (let ((call-next-method-p nil) ;flag indicating that call-next-method + ;should be in the method definition + (closurep nil) ;flag indicating that #'call-next-method + ;was seen in the body of a method + (next-method-p-p nil)) ;flag indicating that next-method-p + ;should be in the method definition + (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 (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)) + (t form)))) + + (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 (gboundp name) + (if (eq *boot-state* 'complete) + (standard-generic-function-p (gdefinition name)) + (funcallable-instance-p (gdefinition name))))) (defun make-parameter-references (specialized-lambda-list - required-parameters - declarations - generic-function-name - specializers) + required-parameters + declarations + method-name + specializers) (flet ((ignoredp (symbol) - (dolist (decl (cdar declarations)) - (when (and (eq (car decl) 'ignore) - (memq symbol (cdr decl))) - (return t))))) + (dolist (decl (cdar declarations)) + (when (and (eq (car decl) 'ignore) + (memq symbol (cdr decl))) + (return t))))) (gathering ((references (collecting))) (iterate ((s (list-elements specialized-lambda-list)) - (p (list-elements required-parameters))) - (progn p) - (cond ((not (listp s))) - ((ignoredp (car s)) - (warn "In defmethod ~S ~S, there is a~%~ + (p (list-elements required-parameters))) + (progn p) + (cond ((not (listp s))) + ((ignoredp (car s)) + (warn "In defmethod ~S, there is a~%~ redundant ignore declaration for the parameter ~S." - generic-function-name - specializers - (car s))) - (t - (gather (car s) references))))))) + method-name + specializers + (car s))) + (t + (gather (car s) references))))))) -(defvar *method-identifier-table* (make-hash-table :test #'eq)) - -(defun get-method-from-identifier (identifier) - (gethash identifier *method-identifier-table*)) - -(defun set-get-method-from-identifier (identifier new-method) - (setf (gethash identifier *method-identifier-table*) new-method)) - -(defsetf get-method-from-identifier set-get-method-from-identifier) - (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) (defun method-function-plist (method-function) - (gethash method-function *method-function-plist*)) + (unless (eq method-function *mf1*) + (rotatef *mf1* *mf2*) + (rotatef *mf1p* *mf2p*) + (rotatef *mf1cp* *mf2cp*)) + (unless (or (eq method-function *mf1*) (null *mf1cp*)) + (setf (gethash *mf1* *method-function-plist*) *mf1p*)) + (unless (eq method-function *mf1*) + (setf *mf1* method-function + *mf1cp* nil + *mf1p* (gethash method-function *method-function-plist*))) + *mf1p*) (defun #-setf SETF\ PCL\ METHOD-FUNCTION-PLIST #+setf (setf method-function-plist) (val method-function) - (setf (gethash method-function *method-function-plist*) val)) - -(defun method-function-get (method-function key) - (getf (method-function-plist method-function) key)) + (unless (eq method-function *mf1*) + (rotatef *mf1* *mf2*) + (rotatef *mf1cp* *mf2cp*) + (rotatef *mf1p* *mf2p*)) + (unless (or (eq method-function *mf1*) (null *mf1cp*)) + (setf (gethash *mf1* *method-function-plist*) *mf1p*)) + (setf *mf1* method-function + *mf1cp* t + *mf1p* val)) + +(defun method-function-get (method-function key &optional default) + (getf (method-function-plist method-function) key default)) (defun #-setf SETF\ PCL\ METHOD-FUNCTION-GET #+setf (setf method-function-get) (val method-function key) - (setf (getf (method-function-plist method-function) key) val)) + (setf (getf (method-function-plist method-function) key) val)) -(defun method-function-method (method-function) - (method-function-get method-function 'method)) -(defun set-method-function-method (method-function new-value) - (setf (method-function-get method-function 'method) new-value)) +(defun method-function-pv-table (method-function) + (method-function-get method-function :pv-table)) + +(defun method-function-method (method-function) + (method-function-get method-function :method)) -(defsetf method-function-method set-method-function-method) +(defun method-function-needs-next-methods-p (method-function) + (method-function-get method-function :needs-next-methods-p t)) -(defun load-defmethod - (class name quals specls ll doc function optimized-function - closure-generator initargs) +(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) (when (listp name) (do-standard-defsetf-1 (cadr name))) - (let ((method-spec (make-method-spec name quals specls))) + (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) (record-definition 'method method-spec) - (when function - (setq function - (set-function-name (method-function-storage-form function) - method-spec))) - (when optimized-function - (setq optimized-function - (set-function-name - (method-function-storage-form optimized-function) - method-spec))) - (when closure-generator - (setq closure-generator (method-function-storage-form closure-generator))) - (load-defmethod-internal - name quals specls ll doc function class - optimized-function closure-generator initargs))) + (load-defmethod-internal class name quals specls ll initargs pv-table-symbol))) (defun load-defmethod-internal - (gf-spec qualifiers specializers lambda-list doc fn method-class - optimized-function closure-generator initargs) + (method-class gf-spec qualifiers specializers lambda-list + initargs pv-table-symbol) (when (listp gf-spec) (do-standard-defsetf-1 (cadr gf-spec))) - - (let ((method (apply - #'add-named-method - gf-spec method-class - qualifiers specializers lambda-list fn - optimized-function - closure-generator - :documentation doc - :definition-source `((defmethod ,gf-spec - ,@qualifiers - ,specializers) - ,(load-truename)) - initargs))) - (when (and (eq *boot-state* 'complete) - (neq (find-class method-class nil) - (generic-function-method-class (gdefinition gf-spec)))) + (when pv-table-symbol + (setf (getf (getf initargs ':plist) :pv-table-symbol) + pv-table-symbol)) + (let ((method (apply #'add-named-method + gf-spec qualifiers specializers lambda-list + :definition-source `((defmethod ,gf-spec + ,@qualifiers + ,specializers) + ,(load-truename)) + initargs))) + (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~%~ + "~&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)))) + may mean that this method was compiled improperly.~%" + qualifiers specializers gf-spec + method-class (class-name (class-of method)))) method)) - - (defun make-method-spec (gf-spec qualifiers unparsed-specializers) `(method ,gf-spec ,@qualifiers ,unparsed-specializers)) +(defun initialize-method-function (initargs &optional return-function-p method) + (let* ((mf (getf initargs ':function)) + (method-spec (getf initargs ':method-spec)) + (plist (getf initargs ':plist)) + (pv-table-symbol (getf plist ':pv-table-symbol)) + (pv-table nil) + (mff (getf initargs ':fast-function))) + (flet ((set-mf-property (p v) + (when mf + (setf (method-function-get mf p) v)) + (when mff + (setf (method-function-get mff p) v)))) + (when method-spec + (when mf + (setq mf (set-function-name mf method-spec))) + (when mff + (let ((name `(,(or (get (car method-spec) 'fast-sym) + (setf (get (car method-spec) 'fast-sym) + (intern (format nil "FAST-~A" + (car method-spec)) + *the-pcl-package*))) + ,@(cdr method-spec)))) + (set-function-name mff name) + (unless mf + (set-mf-property :name name))))) + (when plist + (let ((snl (getf plist :slot-name-lists)) + (cl (getf plist :call-list))) + (when (or snl cl) + (setq pv-table (intern-pv-table :slot-name-lists snl + :call-list cl)) + (when pv-table (set pv-table-symbol pv-table)) + (set-mf-property :pv-table pv-table))) + (loop (when (null plist) (return nil)) + (set-mf-property (pop plist) (pop plist))) + (when method + (set-mf-property :method method)) + (when return-function-p + (or mf (method-function-from-fast-function mff))))))) + + + +(defun analyze-lambda-list (lambda-list) + ;;(declare (values nrequired noptional keysp restp allow-other-keys-p + ;; keywords keyword-parameters)) + (flet ((parse-keyword-argument (arg) + (if (listp arg) + (if (listp (car arg)) + (caar arg) + (make-keyword (car arg))) + (make-keyword arg)))) + (let ((nrequired 0) + (noptional 0) + (keysp nil) + (restp nil) + (allow-other-keys-p nil) + (keywords ()) + (keyword-parameters ()) + (state 'required)) + (dolist (x lambda-list) + (if (memq x lambda-list-keywords) + (case x + (&optional (setq state 'optional)) + (&key (setq keysp 't + state 'key)) + (&allow-other-keys (setq allow-other-keys-p 't)) + (&rest (setq restp 't + state 'rest)) + (&aux (return t)) + (otherwise + (error "Encountered the non-standard lambda list keyword ~S." x))) + (ecase state + (required (incf nrequired)) + (optional (incf noptional)) + (key (push (parse-keyword-argument x) keywords) + (push x keyword-parameters)) + (rest ())))) + (values nrequired noptional keysp restp allow-other-keys-p + (reverse keywords) + (reverse keyword-parameters))))) + +(defun keyword-spec-name (x) + (let ((key (if (atom x) x (car x)))) + (if (atom key) + (intern (symbol-name key) (find-package "KEYWORD")) + (car key)))) + +(defun ftype-declaration-from-lambda-list (lambda-list #+cmu name) + (multiple-value-bind (nrequired noptional keysp restp allow-other-keys-p + keywords keyword-parameters) + (analyze-lambda-list lambda-list) + (declare (ignore keyword-parameters)) + (let* (#+cmu (old (c::info function type name)) + #+cmu (old-ftype (if (c::function-type-p old) old nil)) + #+cmu (old-restp (and old-ftype (c::function-type-rest old-ftype))) + #+cmu (old-keys (and old-ftype + (mapcar #'c::key-info-name + (c::function-type-keywords old-ftype)))) + #+cmu (old-keysp (and old-ftype (c::function-type-keyp old-ftype))) + #+cmu (old-allowp (and old-ftype (c::function-type-allowp old-ftype))) + (keywords #+cmu (union old-keys (mapcar #'keyword-spec-name keywords)) + #-cmu (mapcar #'keyword-spec-name keywords))) + `(function ,(append (make-list nrequired :initial-element 't) + (when (plusp noptional) + (append '(&optional) + (make-list noptional :initial-element 't))) + (when (or restp #+cmu old-restp) + '(&rest t)) + (when (or keysp #+cmu old-keysp) + (append '(&key) + (mapcar #'(lambda (key) + `(,key t)) + keywords) + (when (or allow-other-keys-p #+cmu old-allowp) + '(&allow-other-keys))))) + *)))) + +(defun proclaim-defgeneric (spec lambda-list) + #-cmu (declare (ignore lambda-list)) + (when (consp spec) + (setq spec (get-setf-function-name (cadr spec)))) + (let (#+cmu + (decl `(ftype ,(ftype-declaration-from-lambda-list lambda-list #+cmu spec) + ,spec))) + #+cmu (proclaim decl) + #+kcl (setf (get spec 'compiler::proclaimed-closure) t))) + ;;;; Early generic-function support ;;; ;;; (defvar *early-generic-functions* ()) (defun ensure-generic-function (function-specifier - &rest all-keys - &key environment - &allow-other-keys) + &rest all-keys + &key environment + &allow-other-keys) (declare (ignore environment)) - (let ((existing (and (gboundp function-specifier) - (gdefinition function-specifier)))) + (let ((existing (and (gboundp function-specifier) + (gdefinition function-specifier)))) (if (and existing - (eq *boot-state* 'complete) - (null (generic-function-p existing))) - (generic-clobbers-function function-specifier) - (apply #'ensure-generic-function-using-class existing function-specifier all-keys)))) + (eq *boot-state* 'complete) + (null (generic-function-p existing))) + (generic-clobbers-function function-specifier) + (apply #'ensure-generic-function-using-class + existing function-specifier all-keys)))) (defun generic-clobbers-function (function-specifier) #+Lispm (zl:signal 'generic-clobbers-function :name function-specifier) @@ -1502,7 +1224,7 @@ work during bootstrapping. will require that you decide what to do with the existing function~%~ definition.~%~ The PCL-specific function MAKE-SPECIALIZABLE may be useful to you." - function-specifier)) + function-specifier)) #+Lispm (zl:defflavor generic-clobbers-function (name) (si:error) @@ -1510,12 +1232,12 @@ work during bootstrapping. #+Lispm (zl:defmethod #+Genera (dbg:report generic-clobbers-function) - #+ti (generic-clobbers-function :report) - (stream) + #+ti (generic-clobbers-function :report) + (stream) (format stream - "~S aready names a ~a" - name - (if (and (symbolp name) (macro-function name)) "macro" "function"))) + "~S aready names a ~a" + name + (if (and (symbolp name) (macro-function name)) "macro" "function"))) #+Genera (zl:defmethod (sys:proceed generic-clobbers-function :specialize-it) () @@ -1530,6 +1252,216 @@ work during bootstrapping. (make-specializable name) (funcall continuation :specialize-it)) +(defvar *sgf-wrapper* + (make-wrapper (early-class-size 'standard-generic-function))) + +(defvar *sgf-slots-init* + (mapcar #'(lambda (canonical-slot) + (if (memq (getf canonical-slot :name) '(arg-info source)) + *slot-unbound* + (let ((initfunction (getf canonical-slot :initfunction))) + (if initfunction + (funcall initfunction) + *slot-unbound*)))) + (early-collect-inheritance 'standard-generic-function))) + +(defvar *sgf-method-class-index* + (bootstrap-slot-index 'standard-generic-function 'method-class)) + +(defun early-gf-p (x) + (and (fsc-instance-p x) + (eq (instance-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*)) + +(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*)) + +(defvar *sgf-dfun-state-index* + (bootstrap-slot-index 'standard-generic-function 'dfun-state)) + +(defstruct (arg-info + (:conc-name nil) + (:constructor make-arg-info ())) + (arg-info-lambda-list :no-lambda-list) + arg-info-precedence + arg-info-metatypes + arg-info-number-optional + arg-info-key/rest-p + arg-info-keywords ;nil no keyword or rest allowed + ;(k1 k2 ..) each method must accept these keyword arguments + ;T must have &key or &rest + + gf-info-simple-accessor-type ; nil, reader, writer, boundp + (gf-precompute-dfun-and-emf-p nil) ; set by set-arg-info + + gf-info-static-c-a-m-emf + (gf-info-c-a-m-emf-std-p t) + gf-info-fast-mf-p) + +(defun arg-info-valid-p (arg-info) + (not (null (arg-info-number-optional arg-info)))) + +(defun arg-info-applyp (arg-info) + (or (plusp (arg-info-number-optional arg-info)) + (arg-info-key/rest-p arg-info))) + +(defun arg-info-number-required (arg-info) + (length (arg-info-metatypes arg-info))) + +(defun arg-info-nkeys (arg-info) + (count-if #'(lambda (x) (neq x 't)) (arg-info-metatypes arg-info))) + +(defun set-arg-info (gf &key new-method (lambda-list nil lambda-list-p) + argument-precedence-order) + (let* ((arg-info (if (eq *boot-state* 'complete) + (gf-arg-info gf) + (early-gf-arg-info gf))) + (methods (if (eq *boot-state* 'complete) + (generic-function-methods gf) + (early-gf-methods gf))) + (was-valid-p (integerp (arg-info-number-optional arg-info))) + (first-p (and new-method (null (cdr methods))))) + (when (and (not lambda-list-p) methods) + (setq lambda-list (gf-lambda-list gf))) + (when (or lambda-list-p + (and first-p (eq (arg-info-lambda-list arg-info) ':no-lambda-list))) + (multiple-value-bind (nreq nopt keysp restp allow-other-keys-p keywords) + (analyze-lambda-list lambda-list) + (declare (ignore allow-other-keys-p)) + (when (and methods (not first-p)) + (let ((gf-nreq (arg-info-number-required arg-info)) + (gf-nopt (arg-info-number-optional arg-info)) + (gf-key/rest-p (arg-info-key/rest-p arg-info))) + (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." + lambda-list gf)))) + (when lambda-list-p + (setf (arg-info-lambda-list arg-info) lambda-list)) + (setf (arg-info-metatypes arg-info) (make-list nreq)) + (setf (arg-info-precedence arg-info) + (compute-precedence lambda-list nreq argument-precedence-order)) + (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 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) + (early-method-lambda-list method) + (method-lambda-list method))) + (flet ((lose (string &rest args) + (error "Attempt to add the method ~S to the generic function ~S.~%~ + But ~A" method gf (apply #'format nil string args))) + (compare (x y) + (if (> x y) "more" "fewer"))) + (let ((gf-nreq (arg-info-number-required arg-info)) + (gf-nopt (arg-info-number-optional arg-info)) + (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." + (compare nreq gf-nreq))) + (unless (= nopt gf-nopt) + (lose "the method has ~S optional arguments than the generic function." + (compare nopt gf-nopt))) + (unless (eq (or keysp restp) gf-key/rest-p) + (error "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))))))) + +(defun set-arg-info1 (gf arg-info new-method methods was-valid-p first-p) + (let* ((existing-p (and methods (cdr methods) new-method)) + (nreq (length (arg-info-metatypes arg-info))) + (metatypes (if existing-p + (arg-info-metatypes arg-info) + (make-list nreq))) + (type (if existing-p + (gf-info-simple-accessor-type arg-info) + nil))) + (when (arg-info-valid-p arg-info) + (dolist (method (if new-method (list new-method) methods)) + (let* ((specializers (if (or (eq *boot-state* 'complete) + (not (consp method))) + (method-specializers method) + (early-method-specializers method t))) + (class (if (or (eq *boot-state* 'complete) (not (consp method))) + (class-of method) + (early-method-class method))) + (new-type (when (and class + (or (not (eq *boot-state* 'complete)) + (eq (generic-function-method-combination gf) + *standard-method-combination*))) + (cond ((eq class *the-class-standard-reader-method*) + 'reader) + ((eq class *the-class-standard-writer-method*) + 'writer) + ((eq class *the-class-standard-boundp-method*) + 'boundp))))) + (setq metatypes (mapcar #'raise-metatype metatypes specializers)) + (setq type (cond ((null type) new-type) + ((eq type new-type) type) + (t nil))))) + (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)) + (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) + (setf (gf-info-simple-accessor-type arg-info) t)))) + (unless was-valid-p + (let ((name (if (eq *boot-state* 'complete) + (generic-function-name gf) + (early-gf-name gf)))) + (setf (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)))))))) + (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 + #'make-method-lambda + (list gf (class-prototype method-class) + '(lambda) nil)))) + (and methods (null (cdr methods)) + (let ((specls (method-specializers (car methods)))) + (and (classp (car specls)) + (eq 'standard-generic-function (class-name (car specls))) + (classp (cadr specls)) + (eq 'standard-method (class-name (cadr specls))))))))) + arg-info) + ;;; ;;; This is the early definition of ensure-generic-function-using-class. ;;; @@ -1541,82 +1473,129 @@ work during bootstrapping. ;;; 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) - &allow-other-keys) + &key (lambda-list nil lambda-list-p) + &allow-other-keys) (declare (ignore keys)) - (if existing - existing - (unless (assoc spec *generic-function-fixups* :test #'equal) - (pushnew spec *early-generic-functions* :test #'equal) - (let ((fin (allocate-funcallable-instance-1))) - (when (eq spec 'print-object) - (set-funcallable-instance-function - fin #'(lambda (instance stream) - (printing-random-thing (instance stream) - (format stream "std-instance"))))) - (setf (gdefinition spec) fin) - (when lambda-list-p - (proclaim-defgeneric spec lambda-list)) - (setf (fsc-instance-slots fin) (list nil nil spec)) - (set-function-name fin spec) - fin)))) - -(defun early-gf-p (x) - (and (fsc-instance-p x) - (listp (fsc-instance-slots x)))) - -(defmacro early-gf-methods (early-gf) - `(let ((fsc-slots (fsc-instance-slots ,early-gf))) - (if (listp fsc-slots) - (car fsc-slots) - ;; This only happens when pcl is loaded on top of itself. - (slot-value ,early-gf 'methods)))) - -(defmacro set-early-gf-methods (early-gf new-value) - `(let ((fsc-slots (fsc-instance-slots ,early-gf))) - (if (listp fsc-slots) - (setf (car fsc-slots) ,new-value) - ;; This only happens when pcl is loaded on top of itself. - (setf (slot-value ,early-gf 'methods) ,new-value)))) - -(defsetf early-gf-methods set-early-gf-methods) - -(defmacro early-gf-discriminator-code (early-gf);These are macros so that - `(cadr (fsc-instance-slots ,early-gf))) ;they can be setf'd. - -(defun early-gf-name (early-gf) - (caddr (fsc-instance-slots early-gf))) - + (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) + (error "The function ~S is not already defined" spec))) + (existing + (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)))) + +(defun make-early-gf (spec &optional lambda-list lambda-list-p function) + (let ((fin (allocate-funcallable-instance *sgf-wrapper* *sgf-slots-init*))) + (set-funcallable-instance-function + fin + (or function + (if (eq spec 'print-object) + #'(lambda (instance stream) + (printing-random-thing (instance stream) + (format stream "std-instance"))) + #'(lambda (&rest args) + (declare (ignore args)) + (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-truename)) + (set-function-name fin spec) + (let ((arg-info (make-arg-info))) + (setf (early-gf-arg-info fin) arg-info) + (when lambda-list-p + (proclaim-defgeneric spec lambda-list) + (set-arg-info fin :lambda-list lambda-list))) + fin)) + +(defun set-dfun (gf &optional dfun cache info) + (when cache + (setf (cache-owner cache) gf)) + (let ((new-state (if (and dfun (or cache info)) + (list* dfun cache info) + dfun))) + (if (eq *boot-state* 'complete) + (setf (gf-dfun-state gf) new-state) + (setf (instance-ref (get-slots gf) *sgf-dfun-state-index*) new-state))) + dfun) + +(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*)))) + (typecase state + (function nil) + (cons (cadr state))))) + +(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*)))) + (typecase state + (function nil) + (cons (cddr state))))) + +(defvar *sgf-name-index* + (bootstrap-slot-index 'standard-generic-function 'name)) + +(defun early-gf-name (gf) + (instance-ref (get-slots gf) *sgf-name-index*)) + +(defun gf-lambda-list (gf) + (let ((arg-info (if (eq *boot-state* 'complete) + (gf-arg-info gf) + (early-gf-arg-info gf)))) + (if (eq ':no-lambda-list (arg-info-lambda-list arg-info)) + (let ((methods (if (eq *boot-state* 'complete) + (generic-function-methods gf) + (early-gf-methods gf)))) + (if (null methods) + (progn + (warn "No way to determine the lambda list for ~S." gf) + nil) + (let* ((method (car (last methods))) + (ll (if (consp method) + (early-method-lambda-list method) + (method-lambda-list method))) + (k (member '&key ll))) + (if k + (append (ldiff ll (cdr k)) '(&allow-other-keys)) + ll)))) + (arg-info-lambda-list arg-info)))) (defmacro real-ensure-gf-internal (gf-class all-keys env) `(progn (cond ((symbolp ,gf-class) - (setq ,gf-class (find-class ,gf-class t ,env))) - ((classp ,gf-class)) - (t - (error "The :GENERIC-FUNCTION-CLASS argument (~S) was neither a~%~ + (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))) + ,gf-class))) (remf ,all-keys :generic-function-class) (remf ,all-keys :environment) (let ((combin (getf ,all-keys :method-combination '.shes-not-there.))) (unless (eq combin '.shes-not-there.) - (setf (getf ,all-keys :method-combination) - (find-method-combination (class-prototype ,gf-class) - (car combin) - (cdr combin))))) + (setf (getf ,all-keys :method-combination) + (find-method-combination (class-prototype ,gf-class) + (car combin) + (cdr combin))))) )) (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) + 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)) + (eq (class-of existing) generic-function-class)) (change-class existing generic-function-class)) (prog1 (apply #'reinitialize-instance existing all-keys) @@ -1625,28 +1604,41 @@ work during bootstrapping. (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) + 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)) + (apply #'make-instance generic-function-class + :name function-specifier all-keys)) (when lambda-list-p (proclaim-defgeneric function-specifier lambda-list)))) - -(defun early-make-a-method - (class qualifiers arglist specializers function optimized-function - closure-generator doc &optional slot-name other-initargs) +(defun get-generic-function-info (gf) + ;; values nreq applyp metatypes nkeys arg-info + (multiple-value-bind (applyp metatypes arg-info) + (let* ((arg-info (if (early-gf-p gf) + (early-gf-arg-info gf) + (gf-arg-info gf))) + (metatypes (arg-info-metatypes arg-info))) + (values (arg-info-applyp arg-info) + metatypes + arg-info)) + (values (length metatypes) applyp metatypes + (count-if #'(lambda (x) (neq x 't)) metatypes) + arg-info))) + +(defun early-make-a-method (class qualifiers arglist specializers initargs doc + &optional slot-name) + (initialize-method-function initargs) (let ((parsed ()) - (unparsed ())) + (unparsed ())) ;; Figure out whether we got class objects or class names as the ;; specializers and set parsed and unparsed appropriately. If we ;; got class objects, then we can compute unparsed, but if we got @@ -1655,67 +1647,61 @@ work during bootstrapping. ;; Note that the use of not symbolp in this call to every should be ;; read as 'classp' we can't use classp itself because it doesn't ;; exist yet. - (setf function (method-function-storage-form function)) - (setf optimized-function (method-function-storage-form optimized-function)) - (setf closure-generator (method-function-storage-form closure-generator)) (if (every #'(lambda (s) (not (symbolp s))) specializers) - (setq parsed specializers - unparsed (mapcar #'(lambda (s) - (if (eq s 't) 't (class-name s))) - specializers)) - (setq unparsed specializers - parsed ())) - (list :early-method ;This is an early method dammit! - - (or optimized-function - (make-not-for-caching-method-function closure-generator)) - ;Function is here for the benefit - ;of early-lookup-method. - - parsed ;The parsed specializers. This is used - ;by early-method-specializers to cache - ;the parse. Note that this only comes - ;into play when there is more than one - ;early method on an early gf. - - (list class ;A list to which real-make-a-method - qualifiers ;can be applied to make a real method - arglist ;corresponding to this early one. - unparsed - function - optimized-function - closure-generator - doc - slot-name - other-initargs) - ))) + (setq parsed specializers + unparsed (mapcar #'(lambda (s) + (if (eq s 't) 't (class-name s))) + specializers)) + (setq unparsed specializers + parsed ())) + (list :early-method ;This is an early method dammit! + + (getf initargs ':function) + (getf initargs ':fast-function) + + parsed ;The parsed specializers. This is used + ;by early-method-specializers to cache + ;the parse. Note that this only comes + ;into play when there is more than one + ;early method on an early gf. + + (list class ;A list to which real-make-a-method + qualifiers ;can be applied to make a real method + arglist ;corresponding to this early one. + unparsed + initargs + doc + slot-name) + ))) (defun real-make-a-method - (class qualifiers lambda-list specializers function optimized-function - closure-generator doc &optional slot-name other-initargs) + (class qualifiers lambda-list specializers initargs doc + &optional slot-name) (setq specializers (parse-specializers specializers)) - (apply #'make-instance - class - :qualifiers qualifiers - :lambda-list lambda-list - :specializers specializers - :function (method-function-storage-form function) - :optimized-function (method-function-storage-form optimized-function) - :closure-generator (method-function-storage-form closure-generator) - :documentation doc - :slot-name slot-name - :allow-other-keys t - other-initargs)) + (apply #'make-instance class + :qualifiers qualifiers + :lambda-list lambda-list + :specializers specializers + :documentation doc + :slot-name slot-name + :allow-other-keys t + initargs)) (defun early-method-function (early-method) - (cadr early-method)) + (values (cadr early-method) (caddr early-method))) + +(defun early-method-class (early-method) + (find-class (car (fifth early-method)))) (defun early-method-standard-accessor-p (early-method) - (let ((class (car (cadddr early-method)))) + (let ((class (first (fifth early-method)))) (or (eq class 'standard-reader-method) (eq class 'standard-writer-method) (eq class 'standard-boundp-method)))) +(defun early-method-standard-accessor-slot-name (early-method) + (seventh (fifth early-method))) + ;;; ;;; Fetch the specializers of an early method. This is basically just a ;;; simple accessor except that when the second argument is t, this converts @@ -1732,43 +1718,38 @@ work during bootstrapping. ;;; (defun early-method-specializers (early-method &optional objectsp) (if (and (listp early-method) - (eq (car early-method) :early-method)) + (eq (car early-method) :early-method)) (cond ((eq objectsp 't) - (or (caddr early-method) - (setf (caddr early-method) - (mapcar #'find-class (cadddr (cadddr early-method)))))) - (t - (cadddr (cadddr early-method)))) + (or (fourth early-method) + (setf (fourth early-method) + (mapcar #'find-class (cadddr (fifth early-method)))))) + (t + (cadddr (fifth early-method)))) (error "~S is not an early-method." early-method))) (defun early-method-qualifiers (early-method) - (cadr (cadddr early-method))) + (cadr (fifth early-method))) + +(defun early-method-lambda-list (early-method) + (caddr (fifth early-method))) (defun early-add-named-method (generic-function-name - method-class - qualifiers - specializers - arglist - function - optimized-function - closure-generator - &rest other-initargs) + qualifiers + specializers + arglist + &rest initargs) (let* ((gf (ensure-generic-function generic-function-name)) - (existing - (dolist (m (early-gf-methods gf)) - (when (and (equal (early-method-specializers m) specializers) - (equal (early-method-qualifiers m) qualifiers)) - (return m)))) - (new (make-a-method method-class - qualifiers - arglist - specializers - function - optimized-function - closure-generator - () - () - other-initargs))) + (existing + (dolist (m (early-gf-methods gf)) + (when (and (equal (early-method-specializers m) specializers) + (equal (early-method-qualifiers m) qualifiers)) + (return m)))) + (new (make-a-method 'standard-method + qualifiers + arglist + specializers + initargs + ()))) (when existing (remove-method gf existing)) (add-method gf new))) @@ -1783,7 +1764,10 @@ work during bootstrapping. (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)) - (early-update-discriminator-code 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. @@ -1794,237 +1778,104 @@ work during bootstrapping. (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))) - (early-update-discriminator-code 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)) + &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)) + (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))) -(defun early-update-discriminator-code (generic-function) - (let* ((methods (early-gf-methods generic-function)) - (early-dfun - (cond ((null methods) - #'(lambda (&rest ignore) - (declare (ignore ignore)) - (error "Called an early generic-function that ~ - has no methods?"))) - ((null (cdr methods)) - ;; If there is only one method, just use that method's - ;; function. This corresponds to the important fact - ;; that early generic-functions with only one method - ;; always call that method when they are called. If - ;; there is more than one method, we have to install - ;; a simple little discriminator-code for this generic - ;; function. - (cadr (car methods))) - (t - (set-function-name - #'(lambda (&rest args) (early-dfun methods args)) - (early-gf-name generic-function)))))) - (set-funcallable-instance-function generic-function early-dfun) - (setf (early-gf-discriminator-code generic-function) early-dfun))) - -(defun early-get-cpl (object) - (bootstrap-get-slot 'std-class - (class-of object) - 'class-precedence-list)) - -(defun early-sort-methods (list args) - (if (null (cdr list)) - list - (sort list - #'(lambda (specls-1 specls-2) - (iterate ((s1 (list-elements specls-1)) - (s2 (list-elements specls-2)) - (a (list-elements args))) - (cond ((eq s1 s2)) - ((eq s2 *the-class-t*) (return t)) - ((eq s1 *the-class-t*) (return nil)) - (t (return (memq s2 (memq s1 (early-get-cpl a)))))))) - :key #'(lambda (em) (early-method-specializers em t))))) - -(defun early-dfun (methods args) - (let ((primary ()) - (before ()) - (after ()) - (around ())) - (dolist (method methods) - (let* ((specializers (early-method-specializers method t)) - (qualifiers (early-method-qualifiers method)) - (args args) - (specs specializers)) - (when (loop - (when (or (null args) - (null specs)) - ;; If we are out of specs, then we must be in the optional, - ;; rest or keywords arguments. This method is applicable - ;; to these arguments. Return T. - (return t)) - (let ((arg (pop args)) - (spec (pop specs))) - (unless (or (eq spec *the-class-t*) - (memq spec (early-get-cpl arg))) - (return nil)))) - (cond ((null qualifiers) (push method primary)) - ((equal qualifiers '(:before)) (push method before)) - ((equal qualifiers '(:after)) (push method after)) - ((equal qualifiers '(:around)) (push method around)) - (t - (error "Unrecognized qualifier in early method.")))))) - (setq primary (early-sort-methods primary args) - before (early-sort-methods before args) - after (early-sort-methods after args) - around (early-sort-methods around args)) - (flet ((do-main-combined-method (&rest arguments) - (dolist (m before) (apply (cadr m) arguments)) - (multiple-value-prog1 - (let ((*next-methods* (mapcar #'car (cdr primary)))) - (apply (cadar primary) arguments)) - (dolist (m after) (apply (cadr m) arguments))))) - (if (null around) - (apply #'do-main-combined-method args) - (let ((*next-methods* - (append (mapcar #'cadr (cdr around)) - (list #'do-main-combined-method)))) - (apply (cadar around) args)))))) - (defvar *fegf-debug-p* nil) (defun fix-early-generic-functions (&optional (noisyp *fegf-debug-p*)) - (allocate-instance (find-class 'standard-generic-function)) ;Be sure this - ;class has an - ;instance. - (let* ((class (find-class 'standard-generic-function)) - (wrapper (class-wrapper class)) - (statics-slots-copy - (wrapper-allocate-static-slot-storage-copy wrapper)) - (default-initargs - (default-initargs class () (class-default-initargs class))) - #+Lucid - (lucid::*redefinition-action* nil)) - (flet ((fix-structure (gf) - (let ((static-slots - (%allocate-static-slot-storage--class statics-slots-copy))) - (setf (fsc-instance-wrapper gf) wrapper - (fsc-instance-slots gf) static-slots)))) - (let ((accessors nil)) - (dolist (early-gf-spec *early-generic-functions*) - (when (every #'early-method-standard-accessor-p - (early-gf-methods (gdefinition early-gf-spec))) - (push early-gf-spec accessors))) - (dolist (spec (nconc accessors - '(slot-boundp-using-class - (setf slot-value-using-class) - slot-value-using-class))) - (setq *early-generic-functions* - (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* ((early-gf (gdefinition early-gf-spec)) - (early-static-slots - (fsc-instance-slots early-gf)) - (early-discriminator-code nil) - (early-methods nil) - (aborted t)) - (flet ((trampoline (&rest args) - (apply early-discriminator-code args))) - (if (not (listp early-static-slots)) - (when noisyp (format t "already fixed?")) - (unwind-protect - (progn - (setq early-discriminator-code - (early-gf-discriminator-code early-gf)) - (setq early-methods - (early-gf-methods early-gf)) - (setf (gdefinition early-gf-spec) #'trampoline) - (when noisyp (format t "trampoline...")) - (fix-structure early-gf) - (when noisyp (format t "fixed...")) - (apply #'initialize-instance early-gf - :name early-gf-spec default-initargs) - (loop - (when (null early-methods) (return nil)) - (let ((early-method (pop early-methods))) - (destructuring-bind - (class quals lambda-list specs fn - optimized-function closure-generator doc - slot-name other-initargs) - (cadddr early-method) - (setq specs - (early-method-specializers early-method t)) - (let ((method (real-make-a-method - class - quals - lambda-list - specs - fn - optimized-function - closure-generator - doc - slot-name - other-initargs))) - (real-add-method early-gf method) - (when noisyp (format t "m")))))) - (setf (generic-function-name early-gf) early-gf-spec) - (setq aborted nil)) - (setf (gdefinition early-gf-spec) early-gf) - (when noisyp (format t ".")) - (when aborted - (setf (fsc-instance-slots early-gf) - early-static-slots)))))))) - + (setq *fegf-started-p* t) + (let ((accessors nil)) + ;; Rearrange *early-generic-functions* to speed up fix-early-generic-functions. + (dolist (early-gf-spec *early-generic-functions*) + (when (every #'early-method-standard-accessor-p + (early-gf-methods (gdefinition early-gf-spec))) + (push early-gf-spec accessors))) + (dolist (spec (nconc accessors + '(accessor-method-slot-name + generic-function-methods + method-specializers + specializerp + specializer-type + specializer-class + slot-definition-location + slot-definition-name + class-slots + gf-arg-info + class-precedence-list + slot-boundp-using-class + (setf slot-value-using-class) + slot-value-using-class + structure-class-p + standard-class-p + funcallable-standard-class-p + specializerp))) + (setq *early-generic-functions* + (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)))) + (setf (fourth args) + (early-method-specializers early-method t)) + (apply #'real-make-a-method args))) + (early-gf-methods gf)))) + (setf (generic-function-method-class gf) *the-class-standard-method*) + (setf (generic-function-method-combination gf) *standard-method-combination*) + (set-methods gf methods))) + (dolist (fns *early-functions*) (setf (symbol-function (car fns)) (symbol-function (caddr fns)))) (dolist (fixup *generic-function-fixups*) - (let ((fspec (car fixup)) - (methods (cdr fixup)) - (gf (make-instance 'standard-generic-function))) - (set-function-name gf fspec) - (setf (generic-function-name gf) fspec) - (loop - (when (null methods) (return nil)) - (let ((method (pop methods))) - (destructuring-bind (lambda-list specializers method-fn-name) - method - (let* - ((optimized-function - (if method-fn-name - (symbol-function method-fn-name) - (symbol-function fspec))) - (function - (when (call-store-method-function-p - gf - (class-prototype *the-class-standard-method*) - nil) - (make-std-documented-method-function - optimized-function))) - (method (make-a-method 'standard-method - () - lambda-list - specializers - function - optimized-function - nil - nil))) - (real-add-method gf method))))) - (setf (gdefinition fspec) gf))))) + (let* ((fspec (car fixup)) + (gf (gdefinition fspec)) + (methods (mapcar #'(lambda (method) + (let* ((lambda-list (first method)) + (specializers (second method)) + (method-fn-name (third method)) + (fn-name (or method-fn-name fspec)) + (fn (symbol-function fn-name)) + (initargs + (list :function + (set-function-name + #'(lambda (args next-methods) + (declare (ignore next-methods)) + (apply fn args)) + `(call ,fn-name))))) + (make-a-method 'standard-method + () + lambda-list + specializers + initargs + nil))) + (cdr fixup)))) + (setf (generic-function-method-class gf) *the-class-standard-method*) + (setf (generic-function-method-combination gf) *standard-method-combination*) + (set-methods gf methods))))) ;;; @@ -2033,32 +1884,32 @@ work during bootstrapping. ;;; implemented. ;;; (defun parse-defmethod (cdr-of-form) - (declare (values name qualifiers specialized-lambda-list body)) + ;;(declare (values name qualifiers specialized-lambda-list body)) (let ((name (pop cdr-of-form)) - (qualifiers ()) - (spec-ll ())) + (qualifiers ()) + (spec-ll ())) (loop (if (and (car cdr-of-form) (atom (car cdr-of-form))) - (push (pop cdr-of-form) qualifiers) - (return (setq qualifiers (nreverse qualifiers))))) + (push (pop cdr-of-form) qualifiers) + (return (setq qualifiers (nreverse qualifiers))))) (setq spec-ll (pop cdr-of-form)) (values name qualifiers spec-ll cdr-of-form))) (defun parse-specializers (specializers) (flet ((parse (spec) - (let ((result (specializer-from-type spec))) - (if (specializerp result) - result - (if (symbolp spec) - (error "~S used as a specializer,~%~ + (let ((result (specializer-from-type spec))) + (if (specializerp result) + result + (if (symbolp spec) + (error "~S used as a specializer,~%~ but is not the name of a class." - spec) - (error "~S is not a legal specializer." spec)))))) + spec) + (error "~S is not a legal specializer." spec)))))) (mapcar #'parse specializers))) (defun unparse-specializers (specializers-or-method) (if (listp specializers-or-method) (flet ((unparse (spec) - (if (specializerp spec) + (if (specializerp spec) (let ((type (specializer-type spec))) (if (and (consp type) (eq (car type) 'class)) @@ -2068,10 +1919,41 @@ work during bootstrapping. class-name type)) type)) - (error "~S is not a legal specializer." spec)))) - (mapcar #'unparse specializers-or-method)) + (error "~S is not a legal specializer." spec)))) + (mapcar #'unparse specializers-or-method)) (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-symbol (format nil "~S" method)))) + (multiple-value-bind (gf-spec quals specls) + (parse-defmethod spec) + (and (setq gf (and (or errorp (gboundp gf-spec)) + (gdefinition gf-spec))) + (let ((nreq (compute-discriminating-function-arglist-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)))))))) + (values gf method name))) + (defun extract-parameters (specialized-lambda-list) @@ -2099,145 +1981,150 @@ work during bootstrapping. required-parameters)) (defun parse-specialized-lambda-list (arglist &optional post-keyword) - (declare (values parameters lambda-list specializers required-parameters)) + ;;(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 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.~%~ + ((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) - (declare (type list parameters lambda-list)) - (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))))))) + 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))))))) (eval-when (load eval) (setq *boot-state* 'early)) -#-cmu +#-cmu ;; CMUCL Has a real symbol-macrolet +(progn (defmacro symbol-macrolet (bindings &body body &environment env) (let ((specs (mapcar #'(lambda (binding) - (list (car binding) - (variable-lexical-p (car binding) env) - (cadr binding))) - bindings))) + (list (car binding) + (variable-lexical-p (car binding) env) + (cadr binding))) + bindings))) (walk-form `(progn ,@body) - env - #'(lambda (f c e) - (expand-symbol-macrolet-internal specs f c e))))) + env + #'(lambda (f c e) + (expand-symbol-macrolet-internal specs f c e))))) -#-cmu (defun expand-symbol-macrolet-internal (specs form context env) (let ((entry nil)) (cond ((not (eq context :eval)) form) - ((symbolp form) - (if (and (setq entry (assoc form specs)) - (eq (cadr entry) (variable-lexical-p form env))) - (caddr entry) - form)) - ((not (listp form)) form) - ((member (car form) '(setq setf)) - ;; Have to be careful. We must only convert the form to a SETF - ;; form when we convert one of the 'logical' variables to a form - ;; Otherwise we will get looping in implementations where setf - ;; is a macro which expands into setq. - (let ((kind (car form))) - (labels ((scan-setf (tail) - (if (null tail) - nil - (walker::relist* - tail - (if (and (setq entry (assoc (car tail) specs)) - (eq (cadr entry) - (variable-lexical-p (car tail) - env))) - (progn (setq kind 'setf) - (caddr entry)) - (car tail)) - (cadr tail) - (scan-setf (cddr tail)))))) - (let (new-tail) - (setq new-tail (scan-setf (cdr form))) - (walker::recons form kind new-tail))))) - ((eq (car form) 'multiple-value-setq) - (let* ((vars (cadr form)) - (gensyms (mapcar #'(lambda (i) (declare (ignore i)) (gensym)) - vars))) - `(multiple-value-bind ,gensyms - ,(caddr form) - .,(reverse (mapcar #'(lambda (v g) `(setf ,v ,g)) - vars - gensyms))))) - (t form)))) + ((symbolp form) + (if (and (setq entry (assoc form specs)) + (eq (cadr entry) (variable-lexical-p form env))) + (caddr entry) + form)) + ((not (listp form)) form) + ((member (car form) '(setq setf)) + ;; Have to be careful. We must only convert the form to a SETF + ;; form when we convert one of the 'logical' variables to a form + ;; Otherwise we will get looping in implementations where setf + ;; is a macro which expands into setq. + (let ((kind (car form))) + (labels ((scan-setf (tail) + (if (null tail) + nil + (walker::relist* + tail + (if (and (setq entry (assoc (car tail) specs)) + (eq (cadr entry) + (variable-lexical-p (car tail) + env))) + (progn (setq kind 'setf) + (caddr entry)) + (car tail)) + (cadr tail) + (scan-setf (cddr tail)))))) + (let (new-tail) + (setq new-tail (scan-setf (cdr form))) + (walker::recons form kind new-tail))))) + ((eq (car form) 'multiple-value-setq) + (let* ((vars (cadr form)) + (gensyms (mapcar #'(lambda (i) (declare (ignore i)) (gensym)) + vars))) + `(multiple-value-bind ,gensyms + ,(caddr form) + .,(reverse (mapcar #'(lambda (v g) `(setf ,v ,g)) + vars + gensyms))))) + (t form)))) +) (defmacro with-slots (slots instance &body body) (let ((in (gensym))) `(let ((,in ,instance)) - #+cmu (declare (ext::ignorable ,in)) - ,@(let ((instance (un-the instance))) - (and (symbolp instance) + #+cmu (declare (ignorable ,in)) + ,@(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) - slot-entry - (car slot-entry))) - (slot-name - (if (symbolp slot-entry) - slot-entry - (cadr slot-entry)))) - `(,variable-name - (slot-value ,in ',slot-name)))) - slots) - ,@body)))) + (let ((variable-name + (if (symbolp slot-entry) + slot-entry + (car slot-entry))) + (slot-name + (if (symbolp slot-entry) + slot-entry + (cadr slot-entry)))) + `(,variable-name + (slot-value ,in ',slot-name)))) + slots) + ,@body)))) (defmacro with-accessors (slots instance &body body) (let ((in (gensym))) `(let ((,in ,instance)) - #+cmu (declare (ext::ignorable ,in)) - ,@(let ((instance (un-the instance))) - (and (symbolp instance) + #+cmu (declare (ignorable ,in)) + ,@(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))) - `(,variable-name - (,accessor-name ,in)))) - slots) + (let ((variable-name (car slot-entry)) + (accessor-name (cadr slot-entry))) + `(,variable-name + (,accessor-name ,in)))) + slots) ,@body)))) + diff --git a/pcl/braid.lisp b/pcl/braid.lisp index 5fcc5d00a..f6d2ce9be 100644 --- a/pcl/braid.lisp +++ b/pcl/braid.lisp @@ -36,132 +36,115 @@ (in-package 'pcl) -(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))) - -(defun canonical-slot-name (canonical-slot) - (getf canonical-slot :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 - (early-collect-default-initargs cpl) - (gathering1 (collecting) - (dolist (definition *early-class-definitions*) - (when (memq class-name (ecd-superclass-names definition)) - (gather1 (ecd-class-name definition)))))))) - -(defun early-collect-cpl (class-name) - (labels ((walk (c) - (let* ((definition (early-class-definition c)) - (supers (ecd-superclass-names definition))) - (cons c - (apply #'append (mapcar #'early-collect-cpl supers)))))) - (remove-duplicates (walk class-name) :from-end nil :test #'eq))) - -(defun early-collect-slots (cpl) - (let* ((definitions (mapcar #'early-class-definition cpl)) - (super-slots (mapcar #'ecd-canonical-slots definitions)) - (slots (apply #'append (reverse super-slots)))) - (dolist (s1 slots) - (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." - name1))))) - slots)) - -(defun early-collect-default-initargs (cpl) - (let ((default-initargs ())) - (dolist (class-name cpl) - (let ((definition (early-class-definition class-name))) - (dolist (option (ecd-other-initargs definition)) - (unless (eq (car option) :default-initargs) - (error "The defclass option ~S is not supported by the bootstrap~%~ - object system." - (car option))) - (setq default-initargs - (nconc default-initargs (reverse (cdr option))))))) - (reverse default-initargs))) - - -;;; -;;; bootstrap-get-slot and bootstrap-set-slot are used to access and change -;;; the values of slots during bootstrapping. During bootstrapping, there -;;; are only two kinds of objects whose slots we need to access, CLASSes -;;; and SLOT-DEFINITIONs. The first argument to these functions tells whether the -;;; object is a CLASS or a SLOT-DEFINITION. -;;; -;;; Note that the way this works it stores the slot in the same place in -;;; memory that the full object system will expect to find it later. This -;;; is critical to the bootstrapping process, the whole changeover to the -;;; full object system is predicated on this. -;;; -;;; One important point is that the layout of standard classes and standard -;;; slots must be computed the same way in this file as it is by the full -;;; object system later. -;;; -(defun bootstrap-get-slot (type object slot-name) - (let ((index (bootstrap-slot-index type slot-name))) - (svref (std-instance-slots object) index))) - -(defun bootstrap-set-slot (type object slot-name new-value) - (let ((index (bootstrap-slot-index type slot-name))) - (setf (svref (std-instance-slots object) index) new-value))) - -(defvar *early-class-slots* nil) - -(defun early-class-slots (class-name) - (cdr (or (assoc class-name *early-class-slots*) - (let ((a (cons class-name - (mapcar #'canonical-slot-name - (early-collect-inheritance class-name))))) - (push a *early-class-slots*) - a)))) - -(defun early-class-original-static-slot-storage-copy (class-name) - (%allocate-origional-static-slot-storage-copy - (length (the list (early-class-slots class-name))))) - -(defun bootstrap-slot-index (class-name slot-name) - (or (posq slot-name (the list (early-class-slots class-name))) - (error "~S not found" slot-name))) - +(defun allocate-standard-instance (wrapper &optional (slots-init nil slots-init-p)) + #-new-kcl-wrapper (declare (special *slot-unbound*)) + #-new-kcl-wrapper + (let ((instance (%%allocate-instance--class)) + (no-of-slots (wrapper-no-of-instance-slots wrapper))) + (setf (%std-instance-wrapper instance) wrapper) + (setf (%std-instance-slots instance) + (if slots-init-p + (make-array no-of-slots :initial-contents slots-init) + (make-array no-of-slots :initial-element *slot-unbound*))) + instance) + #+new-kcl-wrapper + (apply #'si:make-structure wrapper + (if slots-init-p + slots-init + (let ((no-of-slots (si::s-data-length wrapper))) + (if (< no-of-slots (fill-pointer *init-vector*)) + (aref *init-vector* no-of-slots) + (get-init-list no-of-slots)))))) + +(defmacro allocate-funcallable-instance-slots (wrapper &optional + slots-init-p slots-init) + #-new-kcl-wrapper + `(let ((no-of-slots (wrapper-no-of-instance-slots ,wrapper))) + ,(if slots-init-p + `(if ,slots-init-p + (make-array no-of-slots :initial-contents ,slots-init) + (make-array no-of-slots :initial-element *slot-unbound*)) + `(make-array no-of-slots :initial-element *slot-unbound*))) + #+new-kcl-wrapper + (if slots-init-p + `(if ,slots-init-p + (allocate-standard-instance ,wrapper ,slots-init) + (allocate-standard-instance ,wrapper)) + `(allocate-standard-instance ,wrapper))) + +(defun allocate-funcallable-instance (wrapper &optional (slots-init nil slots-init-p)) + (let ((fin (allocate-funcallable-instance-1))) + (set-funcallable-instance-function + fin #'(lambda (&rest args) + (declare (ignore args)) + (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)) + #-new-kcl-wrapper + (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)))) + #+new-kcl-wrapper + (if slots-init-p + (allocate-standard-instance wrapper slots-init) + (allocate-standard-instance wrapper))) ;;; ;;; bootstrap-meta-braid ;;; ;;; This function builds the base metabraid from the early class definitions. ;;; +(defmacro initial-classes-and-wrappers (&rest classes) + `(progn + ,@(mapcar #'(lambda (class) + (let ((wr (intern (format nil "~A-WRAPPER" class) + *the-pcl-package*))) + `(setf ,wr ,(if (eq class 'standard-generic-function) + '*sgf-wrapper* + `(make-wrapper (early-class-size ',class))) + ,class (allocate-standard-instance + ,(if (eq class 'standard-generic-function) + 'funcallable-standard-class-wrapper + 'standard-class-wrapper)) + (wrapper-class ,wr) ,class + #+new-kcl-wrapper (si::s-data-name ,wr) + #+new-kcl-wrapper ',class + (find-class ',class) ,class))) + classes))) + (defun bootstrap-meta-braid () - (let* ((slot-class-original-slot-copy - (early-class-original-static-slot-storage-copy 'slot-class)) - (standard-class-original-slot-copy - (early-class-original-static-slot-storage-copy 'standard-class)) - (built-in-class-original-slot-copy - (early-class-original-static-slot-storage-copy 'built-in-class)) - (structure-class-original-slot-copy - (early-class-original-static-slot-storage-copy 'structure-class)) - (slot-class (%allocate-instance--class standard-class-original-slot-copy)) - (standard-class (%allocate-instance--class standard-class-original-slot-copy)) - (built-in-class (%allocate-instance--class standard-class-original-slot-copy)) - (structure-class (%allocate-instance--class standard-class-original-slot-copy)) - (direct-slotd (%allocate-instance--class standard-class-original-slot-copy)) - (effective-slotd (%allocate-instance--class standard-class-original-slot-copy)) - (class-eq (%allocate-instance--class standard-class-original-slot-copy)) - (slot-class-wrapper (make-wrapper slot-class)) - (standard-class-wrapper (make-wrapper standard-class)) - (built-in-class-wrapper (make-wrapper built-in-class)) - (structure-class-wrapper (make-wrapper structure-class)) - (direct-slotd-wrapper (make-wrapper direct-slotd)) - (effective-slotd-wrapper (make-wrapper effective-slotd)) - (class-eq-wrapper (make-wrapper class-eq))) + (let* ((name 'class) + (predicate-name (make-type-predicate-name name))) + (setf (symbol-function predicate-name) + #'(lambda (x) (declare (ignore x)) t)) + (do-satisfies-deftype name predicate-name)) + (let* ((*create-classes-from-internal-structure-definitions-p* nil) + standard-class-wrapper standard-class + funcallable-standard-class-wrapper funcallable-standard-class + slot-class-wrapper slot-class + built-in-class-wrapper built-in-class + structure-class-wrapper structure-class + standard-direct-slot-definition-wrapper standard-direct-slot-definition + standard-effective-slot-definition-wrapper standard-effective-slot-definition + class-eq-specializer-wrapper class-eq-specializer + standard-generic-function-wrapper standard-generic-function) + (initial-classes-and-wrappers + standard-class funcallable-standard-class + slot-class built-in-class structure-class + standard-direct-slot-definition standard-effective-slot-definition + class-eq-specializer standard-generic-function) ;; ;; First, make a class metaobject for each of the early classes. For ;; each metaobject we also set its wrapper. Except for the class T, @@ -170,29 +153,16 @@ (dolist (definition *early-class-definitions*) (let* ((name (ecd-class-name definition)) (meta (ecd-metaclass definition)) - (original-slot-copy - (ecase meta - (slot-class slot-class-original-slot-copy) - (standard-class standard-class-original-slot-copy) - (built-in-class built-in-class-original-slot-copy) - (structure-class structure-class-original-slot-copy))) - (class (case name - (slot-class slot-class) - (standard-class standard-class) - (standard-direct-slot-definition direct-slotd) - (standard-effective-slot-definition effective-slotd) - (built-in-class built-in-class) - (structure-class structure-class) - (class-eq-specializer class-eq) - (otherwise (%allocate-instance--class original-slot-copy))))) - (when (eq meta 'standard-class) - (inform-type-system-about-class class name)) - (setf (std-instance-wrapper class) - (ecase meta - (slot-class slot-class-wrapper) - (standard-class standard-class-wrapper) - (built-in-class built-in-class-wrapper) - (structure-class structure-class-wrapper))) + (wrapper (ecase meta + (slot-class slot-class-wrapper) + (standard-class standard-class-wrapper) + (funcallable-standard-class funcallable-standard-class-wrapper) + (built-in-class built-in-class-wrapper) + (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)) + (inform-type-system-about-std-class name)) (setf (find-class name) class))) ;; ;; @@ -205,397 +175,259 @@ (direct-slots (ecd-canonical-slots definition)) (other-initargs (ecd-other-initargs definition))) (let ((direct-default-initargs - (getf other-initargs :default-initargs))) + (getf other-initargs :direct-default-initargs))) (multiple-value-bind (slots cpl default-initargs direct-subclasses) (early-collect-inheritance name) - (declare (type list slots cpl default-initargs direct-subclasses)) (let* ((class (find-class name)) - (wrapper - (cond - ((eq class slot-class) slot-class-wrapper) - ((eq class standard-class) standard-class-wrapper) - ((eq class direct-slotd) direct-slotd-wrapper) - ((eq class effective-slotd) effective-slotd-wrapper) - ((eq class built-in-class) built-in-class-wrapper) - ((eq class structure-class) structure-class-wrapper) - ((eq class class-eq) class-eq-wrapper) - (t (make-wrapper class)))) - (proto nil) - (slot-names - (mapcar #'canonical-slot-name slots)) - (static-slot-copy - (%allocate-origional-static-slot-storage-copy (length slot-names)))) - (declare (type list slot-names)) - (cond ((eq name 't) - (setq *the-wrapper-of-t* wrapper - *the-class-t* class)) - ((memq name '(slot-object - standard-object - structure-object - built-in-class - slot-class - standard-class - funcallable-standard-class - structure-class - standard-direct-slot-definition - standard-effective-slot-definition)) - (set (intern (format nil "*THE-CLASS-~A*" (symbol-name name)) - *the-pcl-package*) - class))) + (wrapper (cond ((eq class slot-class) + slot-class-wrapper) + ((eq class standard-class) + standard-class-wrapper) + ((eq class funcallable-standard-class) + funcallable-standard-class-wrapper) + ((eq class standard-direct-slot-definition) + standard-direct-slot-definition-wrapper) + ((eq class standard-effective-slot-definition) + standard-effective-slot-definition-wrapper) + ((eq class built-in-class) + built-in-class-wrapper) + ((eq class structure-class) + structure-class-wrapper) + ((eq class class-eq-specializer) + class-eq-specializer-wrapper) + ((eq class standard-generic-function) + standard-generic-function-wrapper) + (t (make-wrapper (length slots) class)))) + (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*) + class) (dolist (slot slots) (unless (eq (getf slot :allocation :instance) :instance) (error "Slot allocation ~S not supported in bootstrap."))) - (setf (wrapper-instance-slots-layout wrapper) slot-names) - (setf (wrapper-allocate-static-slot-storage-copy wrapper) - static-slot-copy) + (setf (wrapper-instance-slots-layout wrapper) + (mapcar #'canonical-slot-name slots)) (setf (wrapper-class-slots wrapper) ()) - (setq proto (%allocate-instance--class static-slot-copy)) - (setf (std-instance-wrapper proto) wrapper) + (setq proto (if (eq meta 'funcallable-standard-class) + (allocate-funcallable-instance wrapper) + (allocate-standard-instance wrapper))) (setq direct-slots (bootstrap-make-slot-definitions - name class direct-slots direct-slotd-wrapper nil)) + name class direct-slots + standard-direct-slot-definition-wrapper nil)) (setq slots (bootstrap-make-slot-definitions - name class slots effective-slotd-wrapper t)) + name class slots + standard-effective-slot-definition-wrapper t)) (case meta - (standard-class - (bootstrap-initialize-standard-class - class name class-eq-wrapper source - direct-supers direct-subclasses cpl wrapper - direct-slots slots direct-default-initargs - default-initargs proto)) - (built-in-class ; *the-class-t* - (bootstrap-initialize-built-in-class - class name class-eq-wrapper source - direct-supers direct-subclasses cpl wrapper - proto nil)) - (slot-class ; *the-class-slot-object* - (bootstrap-initialize-built-in-class - class name class-eq-wrapper source - direct-supers direct-subclasses cpl wrapper - proto nil) - (bootstrap-set-slot 'slot-class class 'direct-slots nil) - (bootstrap-set-slot 'slot-class class 'slots nil) - (bootstrap-set-slot 'slot-class class 'internal-slotds nil) - (bootstrap-set-slot 'slot-class class - 'side-effect-internal-slotds nil)) - (structure-class ; *the-class-structure-object* - (bootstrap-initialize-structure-class - class name class-eq-wrapper source - direct-supers direct-subclasses cpl wrapper))) - - (let ((class-name 'standard-direct-slot-definition)) - (dolist (slotd direct-slots) - (bootstrap-accessor-definitions - name - (bootstrap-get-slot class-name slotd 'name) - (bootstrap-get-slot class-name slotd 'readers) - (bootstrap-get-slot class-name slotd 'writers))))))))))) - -(defun bootstrap-accessor-definitions (class-name slot-name readers writers) - (flet ((do-reader-definition (reader) - (let ((optimized-method-function - (make-std-reader-method-function slot-name)) - (generic-function - (ensure-generic-function reader))) - (add-method - generic-function - (make-a-method - 'standard-reader-method - () - (list class-name) - (list class-name) - (when (call-store-method-function-p generic-function nil nil) - (make-documented-std-reader-method-function slot-name)) - optimized-method-function - NIL - "automatically generated reader method" - slot-name - `(:needs-next-methods-p NIL))))) - (do-writer-definition (writer) - (let ((optimized-method-function - (make-std-writer-method-function slot-name)) - (generic-function - (ensure-generic-function writer))) - (add-method - generic-function - (make-a-method - 'standard-writer-method - () - (list 'new-value class-name) - (list 't class-name) - (when (call-store-method-function-p generic-function nil nil) - (make-documented-std-writer-method-function slot-name)) - optimized-method-function - NIL - "automatically generated writer method" - slot-name - `(:needs-next-methods-p NIL)))))) - (dolist (reader readers) (do-reader-definition reader)) - (dolist (writer writers) (do-writer-definition writer)))) - + ((standard-class funcallable-standard-class) + (bootstrap-initialize-class + meta + class name class-eq-specializer-wrapper source + direct-supers direct-subclasses cpl wrapper proto + direct-slots slots direct-default-initargs default-initargs)) + (built-in-class ; *the-class-t* + (bootstrap-initialize-class + meta + class name class-eq-specializer-wrapper source + direct-supers direct-subclasses cpl wrapper proto)) + (slot-class ; *the-class-slot-object* + (bootstrap-initialize-class + meta + class name class-eq-specializer-wrapper source + direct-supers direct-subclasses cpl wrapper proto)) + (structure-class ; *the-class-structure-object* + (bootstrap-initialize-class + meta + class name class-eq-specializer-wrapper source + direct-supers direct-subclasses cpl wrapper)))))))) + + (let* ((smc-class (find-class 'standard-method-combination)) + (smc-wrapper (bootstrap-get-slot 'standard-class smc-class 'wrapper)) + (smc (allocate-standard-instance smc-wrapper))) + (flet ((set-slot (name value) + (bootstrap-set-slot 'standard-method-combination smc name value))) + (set-slot 'source (load-truename)) + (set-slot 'type 'standard) + (set-slot 'documentation "The standard method combination.") + (set-slot 'options ())) + (setq *standard-method-combination* smc)))) ;;; -;;; Initialize a standard class metaobject. +;;; Initialize a class metaobject. ;;; -(defun bootstrap-initialize-standard-class - (class - name class-eq-wrapper definition-source direct-supers direct-subclasses cpl - wrapper direct-slots slots direct-default-initargs default-initargs proto) - (declare (type list direct-slots slots)) +(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)) (set-slot (slot-name value) - (bootstrap-set-slot 'standard-class class slot-name value))) - (let ((class-precedence-list (classes cpl))) - - (set-slot 'default-initargs default-initargs) - (set-slot 'direct-slots direct-slots) - (set-slot 'direct-default-initargs direct-default-initargs) - (set-slot 'direct-subclasses (classes direct-subclasses)) - (set-slot 'direct-superclasses (classes direct-supers)) - (set-slot 'finalized-p T) - (set-slot 'name name) - (set-slot 'class-precedence-list class-precedence-list) - (set-slot 'prototype proto) - (set-slot 'slots slots) - - (set-slot 'cached-in-generic-functions ()) - (set-slot 'can-precede-list (classes (cdr cpl))) - (set-slot 'class-eq-specializer - (let ((spec (%allocate-instance--class - (early-class-original-static-slot-storage-copy - 'class-eq-specializer)))) - (setf (std-instance-wrapper spec) class-eq-wrapper) - (bootstrap-set-slot 'class-eq-specializer spec 'type - `(class-eq ,class)) - (bootstrap-set-slot 'class-eq-specializer spec 'object - class) - spec)) - (set-slot 'direct-methods (cons nil nil)) - (set-slot 'incompatible-superclass-list nil) - (set-slot 'predicate-name (or (cadr (assoc name *early-class-predicates*)) - (make-class-predicate-name name))) - (set-slot 'wrapper wrapper) - - (set-slot 'plist nil) - (set-slot 'source definition-source) - (set-slot 'type `(class ,class)) - (set-slot 'documentation NIL) - - (let ((internal-slotds ()) - (side-effect-internal-slotds ())) - (dolist (slot slots) - (let ((internal-slotd - (bootstrap-get-slot 'standard-effective-slot-definition - slot 'internal-slotd))) - (push internal-slotd internal-slotds) - (unless (bootstrap-get-slot 'standard-effective-slot-definition - slot - 'initfunction-side-effect-free-p) - (push internal-slotd side-effect-internal-slotds)))) - (set-slot 'internal-slotds (nreverse internal-slotds)) - (set-slot 'side-effect-internal-slotds - (nreverse side-effect-internal-slotds))) - (setf (wrapper-allocate-static-slot-storage-copy wrapper) - (%allocate-origional-static-slot-storage-copy (length slots))) - ))) - -;;; -;;; Initialize a built-in-class metaobject. -;;; -(defun bootstrap-initialize-built-in-class - (class name class-eq-wrapper source direct-supers direct-subclasses cpl - wrapper proto predicate-name) - (flet ((classes (names) (mapcar #'find-class names)) - (set-slot (slot-name value) - (bootstrap-set-slot 'built-in-class class slot-name value))) - - (set-slot 'default-initargs ()) - (set-slot 'direct-default-initargs ()) - (set-slot 'direct-slots ()) - (set-slot 'direct-subclasses (classes direct-subclasses)) - (set-slot 'direct-superclasses (classes direct-supers)) + (bootstrap-set-slot metaclass-name class slot-name value))) (set-slot 'name name) - (set-slot 'finalized-p T) - (set-slot 'class-precedence-list (classes cpl)) - (set-slot 'prototype - (or proto - (let* ((proto (%allocate-instance--class *empty-vector*))) - (setf (std-instance-wrapper proto) wrapper) - proto))) - (set-slot 'slots ()) - (set-slot 'source source) (set-slot 'type (if (eq class (find-class 't)) t `(class ,class))) (set-slot 'class-eq-specializer - (let ((spec (%allocate-instance--class - (early-class-original-static-slot-storage-copy - 'class-eq-specializer)))) - (setf (std-instance-wrapper spec) class-eq-wrapper) - (bootstrap-set-slot 'class-eq-specializer spec 'type - `(class-eq ,class)) - (bootstrap-set-slot 'class-eq-specializer spec 'object - class) - spec)) - - (set-slot 'direct-methods (cons nil nil)) + (let ((spec (allocate-standard-instance class-eq-wrapper))) + (bootstrap-set-slot 'class-eq-specializer spec 'type + `(class-eq ,class)) + (bootstrap-set-slot 'class-eq-specializer spec 'object + class) + spec)) + (set-slot 'class-precedence-list (classes cpl)) (set-slot 'can-precede-list (classes (cdr cpl))) (set-slot 'incompatible-superclass-list nil) - (set-slot 'internal-slotds nil) + (set-slot 'direct-superclasses (classes direct-supers)) + (set-slot 'direct-subclasses (classes direct-subclasses)) + (set-slot 'direct-methods (cons nil nil)) (set-slot 'wrapper wrapper) + #+new-kcl-wrapper + (setf (si::s-data-name wrapper) name) (set-slot 'predicate-name (or (cadr (assoc name *early-class-predicates*)) - predicate-name (make-class-predicate-name name))) - (set-slot 'plist nil) - (set-slot 'documentation (format nil "Built-in-class ~S" name)))) - -(defun bootstrap-initialize-structure-class - (class name class-eq-wrapper source direct-supers direct-subclasses cpl wrapper) - (unless (eq name 'structure-object) (error "You forgot to do something")) - (flet ((classes (names) (mapcar #'find-class names)) - (set-slot (slot-name value) - (bootstrap-set-slot 'structure-class class slot-name value))) - (let ((constructor-sym '|STRUCTURE-OBJECT class constructor|)) - - (set-slot 'default-initargs nil) - (set-slot 'direct-default-initargs nil) - (set-slot 'direct-slots nil) - (set-slot 'direct-subclasses (classes direct-subclasses)) - (set-slot 'direct-superclasses (classes direct-supers)) - (set-slot 'finalized-p T) - (set-slot 'name name) - (set-slot 'class-precedence-list (classes cpl)) - (set-slot 'prototype (funcall (symbol-function constructor-sym))) - (set-slot 'slots nil) - - (set-slot 'source source) - (set-slot 'type `(class ,class)) - (set-slot 'class-eq-specializer - (let ((spec (%allocate-instance--class - (early-class-original-static-slot-storage-copy - 'class-eq-specializer)))) - (setf (std-instance-wrapper spec) class-eq-wrapper) - (bootstrap-set-slot 'class-eq-specializer spec 'type - `(class-eq ,class)) - (bootstrap-set-slot 'class-eq-specializer spec 'object - class) - spec)) - (set-slot 'direct-methods (cons nil nil)) - (set-slot 'can-precede-list (classes (cdr cpl))) - (set-slot 'incompatible-superclass-list nil) - (set-slot 'wrapper wrapper) - (set-slot 'predicate-name (or (cadr (assoc name *early-class-predicates*)) - (make-class-predicate-name name))) - (set-slot 'internal-slotds nil) - (set-slot 'side-effect-internal-slotds nil) - (set-slot 'defstruct-conc-name "|STRUCTURE-OBJECT class ") - (set-slot 'defstruct-constructor constructor-sym) - (set-slot 'from-defclass-p t) - (set-slot 'plist nil) - (set-slot 'documentation NIL)))) + (set-slot 'plist + `(,@(and direct-default-initargs + `(direct-default-initargs ,direct-default-initargs)) + ,@(and default-initargs + `(default-initargs ,default-initargs)))) + (when (memq metaclass-name '(standard-class funcallable-standard-class + structure-class slot-class)) + (set-slot 'direct-slots direct-slots) + (set-slot 'slots slots) + (set-slot 'initialize-info nil)) + (if (eq metaclass-name 'structure-class) + (let ((constructor-sym '|STRUCTURE-OBJECT class constructor|)) + (set-slot 'predicate-name (or (cadr (assoc name *early-class-predicates*)) + (make-class-predicate-name name))) + (set-slot 'defstruct-form + `(defstruct (structure-object (:constructor ,constructor-sym)))) + (set-slot 'defstruct-constructor constructor-sym) + (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)))) + class)) (defun bootstrap-make-slot-definitions (name class slots wrapper effective-p) (let ((index -1)) - (declare (type fixnum index)) (mapcar #'(lambda (slot) (incf index) (bootstrap-make-slot-definition name class slot wrapper effective-p index)) slots))) -(defvar *early-slot-names* (make-hash-table :test 'eq)) - (defun bootstrap-make-slot-definition (name class slot wrapper effective-p index) - (declare (ignore name)) (let* ((slotd-class-name (if effective-p 'standard-effective-slot-definition 'standard-direct-slot-definition)) - (slotd (%allocate-instance--class - (early-class-original-static-slot-storage-copy slotd-class-name))) + (slotd (allocate-standard-instance wrapper)) (slot-name (getf slot :name))) - (setf (std-instance-wrapper slotd) wrapper) (flet ((get-val (name) (getf slot name)) (set-val (name val) (bootstrap-set-slot slotd-class-name slotd name val))) - (let ((initfunction (get-val :initfunction)) - (initargs (get-val :initargs))) - (set-val 'name slot-name) - (set-val 'initform (get-val :initform)) - (set-val 'initfunction initfunction) - (set-val 'initargs initargs) - (set-val 'readers (get-val :readers)) - (set-val 'writers (get-val :writers)) - (set-val 'allocation :instance) - (set-val 'type (get-val :type)) - (set-val 'class class) - (set-val 'documentation (get-val :documentation)) - (set-val 'initfunction-side-effect-free-p - (get-val :initfunction-side-effect-free-p)) - (when effective-p - (set-val 'location index) - (let* ((instance-type 'std-instance) - (reader-function - (make-optimized-std-reader-method-function - instance-type slot-name index)) - (writer-function - (make-optimized-std-writer-method-function - instance-type slot-name index)) - (boundp-function - (make-optimized-std-boundp-method-function - instance-type slot-name index))) - (set-val 'reader-function reader-function) - (set-val 'writer-function writer-function) - (set-val 'boundp-function boundp-function) - (set-val 'accessor-flags 7) - (let ((internal-slotd - (make-internal-slotd :name slot-name - :slot-definition slotd - :location index - :initargs initargs - :initfunction initfunction - :reader-function reader-function - :writer-function writer-function - :boundp-function boundp-function))) - (set-val 'internal-slotd internal-slotd))) - (push (cons class slotd) (gethash slot-name *early-slot-names*)))) + (set-val 'name slot-name) + (set-val 'initform (get-val :initform)) + (set-val 'initfunction (get-val :initfunction)) + (set-val 'initargs (get-val :initargs)) + (set-val 'readers (get-val :readers)) + (set-val 'writers (get-val :writers)) + (set-val 'allocation :instance) + (set-val 'type (or (get-val :type) t)) + (set-val 'documentation (or (get-val :documentation) "")) + (set-val 'class class) + (when effective-p + (set-val 'location index) + (let ((fsc-p nil)) + (set-val 'reader-function (make-optimized-std-reader-method-function + fsc-p slot-name index)) + (set-val 'writer-function (make-optimized-std-writer-method-function + fsc-p slot-name index)) + (set-val 'boundp-function (make-optimized-std-boundp-method-function + fsc-p slot-name index))) + (set-val 'accessor-flags 7) + (let ((table (or (gethash slot-name *name->class->slotd-table*) + (setf (gethash slot-name *name->class->slotd-table*) + (make-hash-table :test 'eq :size 5))))) + (setf (gethash class table) slotd))) + (when (and (eq name 'standard-class) + (eq slot-name 'slots) effective-p) + (setq *the-eslotd-standard-class-slots* slotd)) + (when (and (eq name 'funcallable-standard-class) + (eq slot-name 'slots) effective-p) + (setq *the-eslotd-funcallable-standard-class-slots* slotd)) slotd))) -(defun early-initialize-slot-gfs () - (maphash #'(lambda (name class+slotd-list) - (let ((table (or (gethash name *name->class->slotd-table*) - (setf (gethash name *name->class->slotd-table*) - (make-hash-table :test 'eq :size 5))))) - (dolist (c+s class+slotd-list) - (setf (gethash (car c+s) table) (cdr c+s))) - (unless *safe-to-use-slot-value-wrapper-optimizations-p* - (initialize-internal-slot-reader-gfs name)) - (unless *safe-to-use-set-slot-value-wrapper-optimizations-p* - (initialize-internal-slot-writer-gfs name)) - (unless *safe-to-use-slot-boundp-wrapper-optimizations-p* - (initialize-internal-slot-boundp-gfs name)))) - *early-slot-names*) - (clrhash *early-slot-names*)) - -(defun early-initialize-class-predicates () - (dolist (definition *early-class-definitions*) - (let* ((name (ecd-class-name definition)) - (class (find-class name))) - (setf (find-class-predicate name) - (make-class-predicate class)))) - (dolist (e *built-in-classes*) - (let* ((name (car e)) - (class (find-class name)) - (predicate-name (class-predicate-name class))) - (setf (find-class-predicate name) - (if (fboundp predicate-name) - (symbol-function predicate-name) - (make-class-predicate class)))))) +(defun bootstrap-accessor-definitions (early-p) + (let ((*early-p* early-p)) + (dolist (definition *early-class-definitions*) + (let ((name (ecd-class-name definition)) + (meta (ecd-metaclass definition))) + (unless (eq meta 'built-in-class) + (let ((direct-slots (ecd-canonical-slots definition))) + (dolist (slotd direct-slots) + (let ((slot-name (getf slotd :name)) + (readers (getf slotd :readers)) + (writers (getf slotd :writers))) + (bootstrap-accessor-definitions1 name slot-name readers writers nil) + (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))))))))))) + +(defun bootstrap-accessor-definition (class-name accessor-name slot-name type) + (multiple-value-bind (accessor-class make-method-function arglist specls doc) + (ecase type + (reader (values 'standard-reader-method #'make-std-reader-method-function + (list class-name) (list class-name) + "automatically generated reader method")) + (writer (values 'standard-writer-method #'make-std-writer-method-function + (list 'new-value class-name) (list 't class-name) + "automatically generated writer method")) + (boundp (values 'standard-boundp-method #'make-std-boundp-method-function + (list class-name) (list class-name) + "automatically generated boundp method"))) + (let ((gf (ensure-generic-function accessor-name))) + (if (find specls (early-gf-methods gf) + :key #'early-method-specializers + :test #'equal) + (unless (assoc accessor-name *generic-function-fixups* + :test #'equal) + (update-dfun gf)) + (add-method gf + (make-a-method accessor-class + () + arglist specls + (funcall make-method-function + class-name slot-name) + doc + slot-name)))))) + +(defun bootstrap-accessor-definitions1 (class-name slot-name readers writers boundps) + (flet ((do-reader-definition (reader) + (bootstrap-accessor-definition class-name reader slot-name 'reader)) + (do-writer-definition (writer) + (bootstrap-accessor-definition class-name writer slot-name 'writer)) + (do-boundp-definition (boundp) + (bootstrap-accessor-definition class-name boundp slot-name 'boundp))) + (dolist (reader readers) (do-reader-definition reader)) + (dolist (writer writers) (do-writer-definition writer)) + (dolist (boundp boundps) (do-boundp-definition boundp)))) + +(defun bootstrap-class-predicates (early-p) + (let ((*early-p* early-p)) + (dolist (definition *early-class-definitions*) + (let* ((name (ecd-class-name definition)) + (class (find-class name))) + (setf (find-class-predicate name) + (make-class-predicate class (class-predicate-name class))))))) (defun bootstrap-built-in-classes () ;; @@ -616,12 +448,9 @@ ;; class name. ;; (let* ((built-in-class (find-class 'built-in-class)) - (built-in-class-wrapper (class-wrapper built-in-class)) - (built-in-class-original-slot-copy - (early-class-original-static-slot-storage-copy 'built-in-class))) + (built-in-class-wrapper (class-wrapper built-in-class))) (dolist (e *built-in-classes*) - (let ((class (%allocate-instance--class built-in-class-original-slot-copy))) - (setf (std-instance-wrapper class) built-in-class-wrapper) + (let ((class (allocate-standard-instance built-in-class-wrapper))) (setf (find-class (car e)) class)))) ;; @@ -629,98 +458,136 @@ ;; (let ((class-eq-wrapper (class-wrapper (find-class 'class-eq-specializer)))) (dolist (e *built-in-classes*) - (destructuring-bind (name supers subs cpl prototype predicate-name) e + (destructuring-bind (name supers subs cpl prototype) e (let* ((class (find-class name)) - (wrapper (make-wrapper class))) + (wrapper (make-wrapper 0 class))) (set (get-built-in-class-symbol name) class) (set (get-built-in-wrapper-symbol name) wrapper) (setf (wrapper-instance-slots-layout wrapper) () - (wrapper-class-slots wrapper) () - (wrapper-allocate-static-slot-storage-copy wrapper) *empty-vector*) - - (bootstrap-initialize-built-in-class class - name class-eq-wrapper nil - supers subs - (cons name cpl) - wrapper prototype predicate-name)))))) + (wrapper-class-slots wrapper) ()) + + (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))) + (setf (find-class-predicate name) + (make-class-predicate class (class-predicate-name class)))))) ;;; ;;; ;;; +#-new-kcl-wrapper +(progn +(defvar *built-in-or-structure-wrapper-table* + (make-hash-table :test 'eq)) + +(defvar wft-type1 nil) +(defvar wft-wrapper1 nil) +(defvar wft-type2 nil) +(defvar wft-wrapper2 nil) + +(defun wrapper-for-structure (x) + (let ((type (structure-type x))) + (when (symbolp type) + (cond ((eq type 'std-instance) + (return-from wrapper-for-structure (std-instance-wrapper x))) + ((eq type wft-type1) (return-from wrapper-for-structure wft-wrapper1)) + ((eq type wft-type2) (return-from wrapper-for-structure wft-wrapper2)) + (t (setq wft-type2 wft-type1 wft-wrapper2 wft-wrapper1)))) + (let* ((cell (find-class-cell type)) + (class (or (find-class-cell-class cell) + (let* (#+lucid + (*structure-type* type) + #+lucid + (*structure-length* (structure-length x type))) + (find-class-from-cell type cell)))) + (wrapper (if class (class-wrapper class) *the-wrapper-of-t*))) + (when (symbolp type) + (setq wft-type1 type wft-wrapper1 wrapper)) + wrapper))) + +(defun built-in-or-structure-wrapper1 (x) + (let ((biw (or (built-in-wrapper-of x) *the-wrapper-of-t*))) + (or (and (eq biw *the-wrapper-of-t*) + (structurep x) + (let* ((type (type-of x)) + #+lucid + (*structure-type* type) + #+lucid + (*structure-length* (structure-length x type)) + (class (find-class type nil))) + (and class (class-wrapper class)))) + biw))) +) -(defun wrapper-of (x) - (fast-wrapper-of x)) - -(defun class-of (x) (wrapper-class (fast-wrapper-of x))) +#|| ; moved to low.lisp +(defmacro built-in-or-structure-wrapper (x) + (once-only (x) + (if (structure-functions-exist-p) ; otherwise structurep is too slow for this + `(if (structurep ,x) + (wrapper-for-structure ,x) + (if (symbolp ,x) + (if ,x *the-wrapper-of-symbol* *the-wrapper-of-null*) + (built-in-wrapper-of ,x))) + `(or (and (symbolp ,x) + (if ,x *the-wrapper-of-symbol* *the-wrapper-of-null*)) + (built-in-or-structure-wrapper1 ,x))))) +||# + +(defmacro wrapper-of-macro (x) + `(cond ((std-instance-p ,x) + (std-instance-wrapper ,x)) + ((fsc-instance-p ,x) + (fsc-instance-wrapper ,x)) + (t + (#+new-kcl-wrapper built-in-wrapper-of + #-new-kcl-wrapper built-in-or-structure-wrapper + ,x)))) + +(defun class-of (x) + (wrapper-class* (wrapper-of-macro x))) + +(defun wrapper-of (x) + (wrapper-of-macro x)) (defun structure-wrapper (x) (class-wrapper (find-class (structure-type x)))) (defvar find-structure-class nil) -(defun make-defclass-direct-slots-from-defstruct (structure-name) - ;; Make the slot descriptions for defclass for structure STRUCTURE-NAME. - ;; If the structure was defined with PCL's redefined Defstruct macro, - ;; build them from its trapped source. - ;; Otherwise hope that the lisp's low file redefined - ;; Structure-type-slot-description-list et al. to get the info about - ;; the structure from the lisp's internal record. If not, then oh well... - (let* ((defstruct-form (defstruct-form structure-name)) - (conc-name (defstruct-form-conc-name defstruct-form))) - (declare (type simple-string conc-name)) - (if defstruct-form - (mapcar - #'(lambda (descrip) - (let* ((name - (if (listp descrip) (car descrip) descrip)) - (accessor-symbol - (intern - (concatenate 'simple-string - conc-name (symbol-name name)) - (symbol-package structure-name)))) - (if (listp descrip) - `(:name ,name - :initform ,(second descrip) - ,@(when (memq :type descrip) - `(:type ,(cadr (memq :type descrip)))) - :defstruct-accessor-symbol ,accessor-symbol) - `(:name ,name - :initform NIL - :defstruct-accessor-symbol ,accessor-symbol)))) - (cdr defstruct-form)) - (if (known-structure-type-p structure-name) - (mapcar #'(lambda (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))) - (structure-type-slot-description-list structure-name)) - NIL)))) - -(defun find-structure-class (symbol &key warn) - (when warn - (if (safe-subtypep symbol 'structure) - (warn "Creating class for structure ~S even though don't know anything about it.~%Class will likely have incorrect slots and superclass information" - symbol) - (warn "Guessing that ~S is a structure-class, even though don't know anything about it.~%Class will likely have incorrect slots and superclass information." - symbol))) - (unless (eq find-structure-class symbol) - (let ((find-structure-class symbol)) - (ensure-class-using-class - symbol - NIL - :metaclass 'structure-class - :name symbol - :direct-superclasses - (when (structure-type-included-type-name symbol) - (list (structure-type-included-type-name symbol))) - :direct-slots - (make-defclass-direct-slots-from-defstruct symbol))))) +(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 + (when (structure-type-included-type-name symbol) + (list (structure-type-included-type-name 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))) (eval-when (compile eval) @@ -770,69 +637,62 @@ +(defun method-function-returning-nil (args next-methods) + (declare (ignore args next-methods)) + nil) + +(defun method-function-returning-t (args next-methods) + (declare (ignore args next-methods)) + t) + +(defun make-class-predicate (class name) + (let* ((gf (ensure-generic-function name)) + (mlist (if (eq *boot-state* 'complete) + (generic-function-methods gf) + (early-gf-methods gf)))) + (unless mlist + (unless (eq class *the-class-t*) + (let* ((default-method-function #'method-function-returning-nil) + (default-method-initargs (list :function + default-method-function)) + (default-method (make-a-method 'standard-method + () + (list 'object) + (list *the-class-t*) + default-method-initargs + "class predicate default method"))) + (setf (method-function-get default-method-function :constant-value) nil) + (add-method gf default-method))) + (let* ((class-method-function #'method-function-returning-t) + (class-method-initargs (list :function + class-method-function)) + (class-method (make-a-method 'standard-method + () + (list 'object) + (list class) + class-method-initargs + "class predicate class method"))) + (setf (method-function-get class-method-function :constant-value) t) + (add-method gf class-method))) + gf)) (eval-when (load eval) (clrhash *find-class*) (bootstrap-meta-braid) + (bootstrap-accessor-definitions t) + (bootstrap-class-predicates t) + (bootstrap-accessor-definitions nil) + (bootstrap-class-predicates nil) (bootstrap-built-in-classes) - (early-initialize-slot-gfs) - (early-initialize-class-predicates) (setq *boot-state* 'braid) - (setf (symbol-function 'load-defclass) #'real-load-defclass) ) (deftype slot-object () '(or standard-object structure-object)) - -;;; -;;; All of these method definitions must appear here because the bootstrap -;;; only allows one method per generic function until the braid is fully -;;; built. -;;; -(defmethod print-object (instance stream) - (printing-random-thing (instance stream) - (let ((name (class-name (class-of instance)))) - (if name - (format stream "~S" name) - (format stream "Instance"))))) - -(defmethod print-object ((class class) stream) - (named-object-print-function class stream)) - -(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 shared-initialize :after ((slotd standard-slot-definition) slot-names &key) - (declare (ignore slot-names)) - (if (eq (slot-value slotd 'allocation) :class) - (setf (slot-value slotd 'allocation) - (slot-value slotd 'class)))) - -(defmethod shared-initialize :after ((slotd structure-slot-definition) slot-names - &key (allocation :instance)) - (declare (ignore slot-names)) - (unless (eq allocation :instance) - (error "structure slots must have :instance allocation"))) - - -(defmethod inform-type-system-about-class ((class structure-class) name) - (inform-type-system-about-std-class name)) - +(defmethod no-applicable-method (generic-function &rest args) + (cerror "Retry call to ~S" + "No matching method for the generic-function ~S,~@ + when called with arguments ~S." + generic-function args) + (apply generic-function args)) diff --git a/pcl/cache.lisp b/pcl/cache.lisp index e702439a1..ac3b00434 100644 --- a/pcl/cache.lisp +++ b/pcl/cache.lisp @@ -73,29 +73,7 @@ ;;; sizes, the space that would be wasted by reserving line 0 to hold the ;;; lock count is more significant. ;;; - -(declaim (ftype (function () index) - get-wrapper-cache-number)) -(declaim (ftype (function (T T T) (values index index index index)) - compute-cache-parameters)) -(declaim (ftype (function (T T T) index) - compute-primary-cache-location - compute-primary-cache-location-from-location)) -(declaim (ftype (function (T) index) - cache-count)) -(declaim (ftype (function (T T T T) boolean) - fill-cache-p - fill-cache-from-cache-p)) -(declaim (ftype (function (T T &optional T) (values T boolean)) - find-free-cache-line)) -(declaim (ftype (function (index) index) - compute-line-size - default-limit-fn - power-of-two-ceiling)) -(declaim (ftype (function (T) boolean) - free-cache-vector)) - - + ;;; ;;; Caches ;;; @@ -114,37 +92,30 @@ `(svref (the simple-vector ,cache-vector) (#-cmu the #+cmu ext:truly-the fixnum ,location))) -(defun emit-cache-vector-ref (cache-vector-operand location-operand) - (operand :iref cache-vector-operand location-operand)) - - (defmacro cache-vector-size (cache-vector) `(array-dimension (the simple-vector ,cache-vector) 0)) (defun allocate-cache-vector (size) - (declare (type index size)) (make-array size :adjustable nil)) (defmacro cache-vector-lock-count (cache-vector) `(cache-vector-ref ,cache-vector 0)) (defun flush-cache-vector-internal (cache-vector) - (without-interrupts-simple + (without-interrupts (fill (the simple-vector cache-vector) nil) (setf (cache-vector-lock-count cache-vector) 0)) cache-vector) (defmacro modify-cache (cache-vector &body body) - `(without-interrupts-simple + `(without-interrupts (multiple-value-prog1 (progn ,@body) (let ((old-count (cache-vector-lock-count ,cache-vector))) - (declare (type index old-count)) + (declare (fixnum old-count)) (setf (cache-vector-lock-count ,cache-vector) - (the index - (if (= old-count most-positive-fixnum) - 1 - (the index (1+ old-count))))))))) + (if (= old-count most-positive-fixnum) + 1 (the fixnum (1+ old-count)))))))) (deftype field-type () '(integer 0 ;#.(position 'number wrapper-layout) @@ -152,9 +123,9 @@ (eval-when (compile load eval) (defun power-of-two-ceiling (x) - (declare (type index x)) + (declare (fixnum x)) ;;(expt 2 (ceiling (log x 2))) - (the index (ash 1 (integer-length (1- x))))) + (the fixnum (ash 1 (integer-length (1- x))))) (defconstant *nkeys-limit* 256) ) @@ -163,15 +134,16 @@ (:print-function print-cache) (:constructor make-cache ()) (:copier copy-cache-internal)) + (owner nil) (nkeys 1 :type (integer 1 #.*nkeys-limit*)) - (valuep nil :type boolean) - (nlines 0 :type index) + (valuep nil :type (member nil t)) + (nlines 0 :type fixnum) (field 0 :type field-type) - (limit-fn #'default-limit-fn :type real-function) - (mask 0 :type index) - (size 0 :type index) + (limit-fn #'default-limit-fn :type function) + (mask 0 :type fixnum) + (size 0 :type fixnum) (line-size 1 :type (integer 1 #.(power-of-two-ceiling (1+ *nkeys-limit*)))) - (max-location 0 :type index) + (max-location 0 :type fixnum) (vector #() :type simple-vector) (overflow nil :type list)) @@ -197,18 +169,18 @@ (defvar *free-cache-vectors* (make-hash-table :size 16 :test 'eql)) ;;; -;;; Return a cache that has had flush-cache-internal called on it. This +;;; 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) (let ((entry (gethash size *free-cache-vectors*))) - (without-interrupts-simple + (without-interrupts (cond ((null entry) (setf (gethash size *free-cache-vectors*) (cons 0 nil)) (get-cache-vector size)) ((null (cdr entry)) - (setf (car entry) (the fixnum (1+ (the fixnum (car entry))))) + (incf (car entry)) (flush-cache-vector-internal (allocate-cache-vector size))) (t (let ((cache (cdr entry))) @@ -217,7 +189,7 @@ (defun free-cache-vector (cache-vector) (let ((entry (gethash (cache-vector-size cache-vector) *free-cache-vectors*))) - (without-interrupts-simple + (without-interrupts (if (null entry) (error "Attempt to free a cache-vector not allocated by GET-CACHE-VECTOR.") (let ((thread (cdr entry))) @@ -243,7 +215,6 @@ (allocated (car entry)) (head (cdr entry)) (free 0)) - (declare (type index allocated free)) (loop (when (null head) (return t)) (setq head (cache-vector-ref head 0)) (incf free)) @@ -283,16 +254,16 @@ (defconstant wrapper-cache-number-mask (1- (expt 2 wrapper-cache-number-length))) + (defvar *get-wrapper-cache-number* (make-random-state)) (defun get-wrapper-cache-number () (let ((n 0)) - (declare (type index n)) + (declare (fixnum n)) (loop (setq n - (logand (the index wrapper-cache-number-mask) - (the index (random most-positive-fixnum - *get-wrapper-cache-number*)))) + (logand wrapper-cache-number-mask + (random most-positive-fixnum *get-wrapper-cache-number*))) (unless (zerop n) (return n))))) @@ -326,18 +297,8 @@ ;;; cache numbers on machines where the addressing modes make that a good ;;; idea. ;;; -;;; For May 92, the wrapper field UNRESERVED-FIELD, accessable by macro -;;; WRAPPER-UNRESERVED-FIELD, has been created to allow a programmer to -;;; store his own items in the wrapper if so desired. (Since there is -;;; only one wrapper per class, this could be added at minimal cost). -;;; It would be nice for this kind of low level hook to be part of the -;;; MOP. -- TL. - -(defconstant *temporary-static-slot-storage-copy* (make-array 1)) - #-structure-wrapper (progn - (eval-when (compile load eval) (defconstant wrapper-layout '(number @@ -348,34 +309,25 @@ number number number - wrapper-identifier state instance-slots-layout class-slots class - allocate-static-slot-storage-copy - unreserved-field)) - -(defconstant wrapper-length (length wrapper-layout)) - -(deftype wrapper () `(simple-vector 15)) ; #.(length wrapper-layout) + no-of-instance-slots)) ) (eval-when (compile load eval) -(declaim (ftype (function (T) index) wrapper-field)) (defun wrapper-field (type) (posq type wrapper-layout)) -(declaim (ftype (function (index) (or index null)) next-wrapper-field)) (defun next-wrapper-field (field-number) - (declare (type index field-number)) (position (nth field-number wrapper-layout) wrapper-layout :start (1+ field-number))) (defmacro first-wrapper-cache-number-index () - `(the field-type (wrapper-field 'number))) + `(wrapper-field 'number)) (defmacro next-wrapper-cache-number-index (field-number) `(next-wrapper-field ,field-number)) @@ -388,74 +340,45 @@ (defmacro cache-number-vector-ref (cnv n) `(svref ,cnv ,n)) -(defconstant *wrapper-identifier-symbol* (gensym "WRAPPER-IDENTIFIER")) (defmacro wrapper-ref (wrapper n) - `(svref (the wrapper ,wrapper) (the index ,n))) - -(defun emit-wrapper-ref (wrapper-operand field-operand) - (operand :iref wrapper-operand field-operand)) - - -(defmacro wrapper-p (x) - (once-only (x) - `(locally (declare #.*optimize-speed*) - (and (simple-vector-p ,x) - (= (the index (length (the simple-vector ,x))) - wrapper-length) - (eq (wrapper-ref ,x ,(wrapper-field 'wrapper-identifier)) - *wrapper-identifier-symbol*))))) + `(svref ,wrapper ,n)) (defmacro wrapper-state (wrapper) `(wrapper-ref ,wrapper ,(wrapper-field 'state))) (defmacro wrapper-instance-slots-layout (wrapper) - `(the list - (wrapper-ref ,wrapper ,(wrapper-field 'instance-slots-layout)))) + `(wrapper-ref ,wrapper ,(wrapper-field 'instance-slots-layout))) (defmacro wrapper-class-slots (wrapper) - `(the list - (wrapper-ref ,wrapper ,(wrapper-field 'class-slots)))) + `(wrapper-ref ,wrapper ,(wrapper-field 'class-slots))) (defmacro wrapper-class (wrapper) `(wrapper-ref ,wrapper ,(wrapper-field 'class))) -(defmacro wrapper-allocate-static-slot-storage-copy (wrapper) - `(the simple-vector - (wrapper-ref ,wrapper ,(wrapper-field 'allocate-static-slot-storage-copy)))) - -(defmacro wrapper-unreserved-field (wrapper) - "Field unreserved by PCL. May be used by user programs." - `(wrapper-ref ,wrapper ,(wrapper-field 'unreserved-field))) - +(defmacro wrapper-no-of-instance-slots (wrapper) + `(wrapper-ref ,wrapper ,(wrapper-field 'no-of-instance-slots))) (defmacro make-wrapper-internal () - `(let ((wrapper (make-array ,(length (the list wrapper-layout)) :adjustable nil))) - (declare (type wrapper wrapper)) + `(let ((wrapper (make-array ,(length wrapper-layout) :adjustable nil))) ,@(gathering1 (collecting) (iterate ((i (interval :from 0)) (desc (list-elements wrapper-layout))) (ecase desc - (wrapper-identifier - (gather1 `(setf (wrapper-ref wrapper ,i) - *wrapper-identifier-symbol*))) (number (gather1 `(setf (wrapper-ref wrapper ,i) - (the index (get-wrapper-cache-number))))) - (allocate-static-slot-storage-copy - (gather1 `(setf (wrapper-ref wrapper ,i) - *temporary-static-slot-storage-copy*))) - ((state instance-slots-layout class-slots class unreserved-field))))) - (setf (wrapper-state wrapper) 't) + (get-wrapper-cache-number)))) + ((state instance-slots-layout class-slots class no-of-instance-slots))))) + (setf (wrapper-state wrapper) 't) wrapper)) -(defun make-wrapper (class) +(defun make-wrapper (no-of-instance-slots &optional class) (let ((wrapper (make-wrapper-internal))) + (setf (wrapper-no-of-instance-slots wrapper) no-of-instance-slots) (setf (wrapper-class wrapper) class) wrapper)) -) ;#-structure-wrapper - +) ; In CMUCL we want to do type checking as early as possible; structures help this. #+structure-wrapper @@ -474,108 +397,90 @@ #+structure-wrapper (progn +#-new-kcl-wrapper (defun make-wrapper-cache-number-vector () - (let ((cnv (make-array wrapper-cache-number-vector-length))) + (let ((cnv (make-array #.wrapper-cache-number-vector-length + :element-type 'fixnum))) (dotimes (i #.wrapper-cache-number-vector-length) - (setf (svref cnv i) (get-wrapper-cache-number))) + (setf (aref cnv i) (get-wrapper-cache-number))) cnv)) (defstruct (wrapper + #+new-kcl-wrapper (:include si::basic-wrapper) (:print-function print-wrapper) - (:constructor make-wrapper (class))) + #-new-kcl-wrapper + (:constructor make-wrapper (no-of-instance-slots &optional class)) + #+new-kcl-wrapper + (:constructor make-wrapper-internal)) + #-new-kcl-wrapper (cache-number-vector (make-wrapper-cache-number-vector) :type cache-number-vector) - (state t :type (or (member t) cons)) ; a cons whose car is one of: flush or obsolete + #-new-kcl-wrapper + (state t :type (or (member t) cons)) + ;; either t or a list (state-sym new-wrapper) + ;; where state-sym is either :flush or :obsolete (instance-slots-layout nil :type list) (class-slots nil :type list) - (class *the-class-t* :type class) - (allocate-static-slot-storage-copy *temporary-static-slot-storage-copy* - :type simple-vector) - (unreserved-field nil)) - -#+akcl -(si::freeze-defstruct 'cache) + #-new-kcl-wrapper + (no-of-instance-slots 0 :type fixnum) + #-new-kcl-wrapper + (class *the-class-t* :type class)) + +(unless (boundp '*the-class-t*) (setq *the-class-t* nil)) + +#+new-kcl-wrapper +(defmacro wrapper-no-of-instance-slots (wrapper) + `(si::s-data-length ,wrapper)) + +#+new-kcl-wrapper +(defun make-wrapper (size &optional class) + (multiple-value-bind (raw slot-positions) + (if (< size 50) + (values si::*all-t-s-type* si::*standard-slot-positions*) + (values (make-array size :element-type 'unsigned-char) + (let ((array (make-array size :element-type 'unsigned-short))) + (dotimes (i size) + (declare (fixnum i)) + (setf (aref array i) (* #.(si::size-of t) i)))))) + (make-wrapper-internal :length size + :raw raw + :print-function 'print-std-instance + :slot-position slot-positions + :size (* size #.(si::size-of t)) + :class class))) (defun print-wrapper (wrapper stream depth) (declare (ignore depth)) (printing-random-thing (wrapper stream) - (format stream "wrapper ~S" (wrapper-class wrapper)))) + (format stream "Wrapper ~S" (wrapper-class wrapper)))) (defmacro first-wrapper-cache-number-index () 0) (defmacro next-wrapper-cache-number-index (field-number) - `(and (< (the index ,field-number) #.(1- wrapper-cache-number-vector-length)) - (1+ (the index ,field-number)))) + `(and (< ,field-number #.(1- wrapper-cache-number-vector-length)) + (1+ ,field-number))) (defmacro cache-number-vector-ref (cnv n) - `(svref ,cnv ,n)) + `(#-kcl svref #+kcl aref ,cnv ,n)) -(defun emit-wrapper-cache-number-vector (wrapper-operand) - (operand :wrapper-cache-number-vector wrapper-operand)) +) -(defun emit-cache-number-vector-ref (cnv-operand field-operand) - (operand :iref cnv-operand field-operand)) +(defmacro wrapper-cache-number-vector-ref (wrapper n) + `(the fixnum + (#-structure-wrapper svref #+structure-wrapper aref + (wrapper-cache-number-vector ,wrapper) ,n))) -) ;#+structure-wrapper +(defmacro class-no-of-instance-slots (class) + `(wrapper-no-of-instance-slots (class-wrapper ,class))) -(defmacro wrapper-cache-number-vector-ref (wrapper n) - `(svref (wrapper-cache-number-vector ,wrapper) ,n)) - - -;;; -;;; -;;; - -(defvar *built-in-or-structure-wrapper-table* - (make-hash-table :test 'eq)) - -(defvar wft-type1 nil) -(defvar wft-wrapper1 nil) -(defvar wft-type2 nil) -(defvar wft-wrapper2 nil) - -(defun wrapper-for-structure (x) - (let ((type (structure-type x))) - (when (symbolp type) - (cond ((eq type wft-type1) - (return-from wrapper-for-structure wft-wrapper1)) - ((eq type wft-type2) - (return-from wrapper-for-structure wft-wrapper2)) - (t (setq wft-type2 wft-type1 wft-wrapper2 wft-wrapper1)))) - (let* ((cell (find-class-cell type)) - (class (or (find-class-cell-class cell) - (let* (#+lucid - (*structure-type* type) - #+lucid - (*structure-length* (structure-length x type))) - (find-class-from-cell type cell)))) - (wrapper (if class (class-wrapper class) *the-wrapper-of-t*))) - (when (symbolp type) - (setq wft-type1 type wft-wrapper1 wrapper)) - wrapper))) - -(defmacro built-in-or-structure-wrapper (x) - (once-only (x) - `(if (structurep ,x) - (wrapper-for-structure ,x) - (if (symbolp ,x) - (if ,x *the-wrapper-of-symbol* *the-wrapper-of-null*) - (built-in-wrapper-of ,x))))) - -(defun built-in-or-structure-wrapper-fun (x) - (built-in-or-structure-wrapper x)) - -(defmacro fast-wrapper-of (x) - (once-only (x) - `(or (and (std-instance-p ,x) - (std-instance-wrapper ,x)) - (and (fsc-instance-p ,x) - (fsc-instance-wrapper ,x)) - #+pcl-user-instances - (and (get-user-instance-p ,x) - (get-user-instance-wrapper ,x)) - (built-in-or-structure-wrapper ,x)))) +(defmacro wrapper-class* (wrapper) + #-new-kcl-wrapper + `(wrapper-class ,wrapper) + #+new-kcl-wrapper + `(let ((wrapper ,wrapper)) + (or (wrapper-class wrapper) + (find-structure-class (si::s-data-name wrapper))))) ;;; ;;; The wrapper cache machinery provides general mechanism for trapping on @@ -597,7 +502,7 @@ (defun invalidate-wrapper (owrapper state nwrapper) (ecase state - ((flush obsolete) + ((:flush :obsolete) (let ((new-previous ())) ;; ;; First off, a previous call to invalidate-wrapper may have recorded @@ -609,8 +514,8 @@ ;; kind of transitivity of wrapper updates. ;; (dolist (previous (gethash owrapper *previous-nwrappers*)) - (when (eq state 'obsolete) - (setf (car previous) 'obsolete)) + (when (eq state ':obsolete) + (setf (car previous) ':obsolete)) (setf (cadr previous) nwrapper) (push previous new-previous)) @@ -624,42 +529,54 @@ (setf (gethash owrapper *previous-nwrappers*) () (gethash nwrapper *previous-nwrappers*) new-previous))))) -(defun wrapper-state-trap (wrapper object) - (let ((state (wrapper-state wrapper))) - (ecase (car state) - (flush - (flush-cache-trap wrapper (cadr state) object)) - (obsolete - (obsolete-instance-trap wrapper (cadr state) object))))) - -(defmacro fast-check-wrapper-validity (object - &optional (wrapper-fn 'fast-wrapper-of)) - (let ((owrapper (gensym "OWRAPPER"))) - (once-only (object) - `(let ((,owrapper (,wrapper-fn ,object))) - (if (eq 't (wrapper-state ,owrapper)) - ,owrapper - (wrapper-state-trap ,owrapper ,object)))))) - (defun check-wrapper-validity (instance) - (fast-check-wrapper-validity instance wrapper-of)) - - + (let* ((owrapper (wrapper-of instance)) + (state (wrapper-state owrapper))) + (if (eq state 't) + owrapper + (let ((nwrapper + (ecase (car state) + (:flush + (flush-cache-trap owrapper (cadr state) instance)) + (:obsolete + (obsolete-instance-trap owrapper (cadr state) instance))))) + ;; + ;; This little bit of error checking is superfluous. It only + ;; checks to see whether the person who implemented the trap + ;; handling screwed up. Since that person is hacking internal + ;; PCL code, and is not a user, this should be needless. Also, + ;; since this directly slows down instance update and generic + ;; function cache refilling, feel free to take it out sometime + ;; soon. + ;; + (cond ((neq nwrapper (wrapper-of instance)) + (error "Wrapper returned from trap not wrapper of instance.")) + ((invalid-wrapper-p nwrapper) + (error "Wrapper returned from trap invalid."))) + nwrapper)))) + +(defmacro check-wrapper-validity1 (object) + (let ((owrapper (gensym))) + `(let ((,owrapper (cond ((std-instance-p ,object) + (std-instance-wrapper ,object)) + ((fsc-instance-p ,object) + (fsc-instance-wrapper ,object)) + #+new-kcl-wrapper + (t (built-in-wrapper-of ,object)) + #-new-kcl-wrapper + (t (wrapper-of ,object))))) + (if (eq 't (wrapper-state ,owrapper)) + ,owrapper + (check-wrapper-validity ,object))))) (defvar *free-caches* nil) (defun get-cache (nkeys valuep limit-fn nlines) - (declare (type index nkeys) - (type boolean valuep) - (type real-function limit-fn) - (type index nlines)) - (let ((cache (or (without-interrupts-simple (pop *free-caches*)) - (make-cache)))) + (let ((cache (or (without-interrupts (pop *free-caches*)) (make-cache)))) (declare (type cache cache)) (multiple-value-bind (cache-mask actual-size line-size nlines) (compute-cache-parameters nkeys valuep nlines) - (declare (type index cache-mask actual-size line-size nlines)) (setf (cache-nkeys cache) nkeys (cache-valuep cache) valuep (cache-nlines cache) nlines @@ -668,32 +585,27 @@ (cache-mask cache) cache-mask (cache-size cache) actual-size (cache-line-size cache) line-size - (cache-max-location cache) - (the index (let ((line (1- nlines))) - (declare (type index line)) - (if (= nkeys 1) - (the index (* line line-size)) - (the index (1+ (the index (* line line-size))))))) + (cache-max-location cache) (let ((line (1- nlines))) + (if (= nkeys 1) + (* line line-size) + (1+ (* line line-size)))) (cache-vector cache) (get-cache-vector actual-size) (cache-overflow cache) nil) cache))) (defun get-cache-from-cache (old-cache new-nlines &optional (new-field (first-wrapper-cache-number-index))) - (declare (type index new-nlines) (type field-type new-field)) (let ((nkeys (cache-nkeys old-cache)) (valuep (cache-valuep old-cache)) - (cache (or (without-interrupts-simple (pop *free-caches*)) - (make-cache)))) - (declare (type cache cache) (type index nkeys) - (type boolean valuep)) + (cache (or (without-interrupts (pop *free-caches*)) (make-cache)))) + (declare (type cache cache)) (multiple-value-bind (cache-mask actual-size line-size nlines) (if (= new-nlines (cache-nlines old-cache)) (values (cache-mask old-cache) (cache-size old-cache) (cache-line-size old-cache) (cache-nlines old-cache)) (compute-cache-parameters nkeys valuep new-nlines)) - (declare (type index cache-mask actual-size line-size nlines)) - (setf (cache-nkeys cache) nkeys + (setf (cache-owner cache) (cache-owner old-cache) + (cache-nkeys cache) nkeys (cache-valuep cache) valuep (cache-nlines cache) nlines (cache-field cache) new-field @@ -701,12 +613,10 @@ (cache-mask cache) cache-mask (cache-size cache) actual-size (cache-line-size cache) line-size - (cache-max-location cache) - (the index (let ((line (1- nlines))) - (declare (type index line)) - (if (= nkeys 1) - (the index (* line line-size)) - (the index (1+ (the index (* line line-size))))))) + (cache-max-location cache) (let ((line (1- nlines))) + (if (= nkeys 1) + (* line line-size) + (1+ (* line line-size)))) (cache-vector cache) (get-cache-vector actual-size) (cache-overflow cache) nil) cache))) @@ -716,8 +626,7 @@ (size (cache-size old-cache)) (old-vector (cache-vector old-cache)) (new-vector (get-cache-vector size))) - (declare (type simple-vector old-vector new-vector) - (type index size)) + (declare (simple-vector old-vector new-vector)) (dotimes (i size) (setf (svref new-vector i) (svref old-vector i))) (setf (cache-vector new-cache) new-vector) @@ -726,42 +635,43 @@ (defun free-cache (cache) (free-cache-vector (cache-vector cache)) (setf (cache-vector cache) #()) + (setf (cache-owner cache) nil) (push cache *free-caches*) nil) (defun compute-line-size (x) - (declare (type index x)) (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 (type index nkeys)) + ;;(declare (values cache-mask actual-size line-size nlines)) + (declare (fixnum nkeys)) (if (= nkeys 1) (let* ((line-size (if valuep 2 1)) (cache-size (if (typep nlines-or-cache-vector 'fixnum) - (the index + (the fixnum (* line-size - (power-of-two-ceiling - (the index nlines-or-cache-vector)))) + (the fixnum + (power-of-two-ceiling + nlines-or-cache-vector)))) (cache-vector-size nlines-or-cache-vector)))) - (declare (type index line-size cache-size)) - (values (logxor (the index (1- cache-size)) (the index (1- line-size))) + (declare (fixnum line-size cache-size)) + (values (logxor (the fixnum (1- cache-size)) (the fixnum (1- line-size))) cache-size line-size - (the index (floor cache-size line-size)))) + (the fixnum (floor cache-size line-size)))) (let* ((line-size (power-of-two-ceiling (if valuep (1+ nkeys) nkeys))) (cache-size (if (typep nlines-or-cache-vector 'fixnum) - (the index + (the fixnum (* line-size - (the index + (the fixnum (power-of-two-ceiling nlines-or-cache-vector)))) (1- (cache-vector-size nlines-or-cache-vector))))) - (declare (type index line-size cache-size)) - (values (logxor (the index (1- cache-size)) (the index (1- line-size))) - (the index (1+ cache-size)) + (declare (fixnum line-size cache-size)) + (values (logxor (the fixnum (1- cache-size)) (the fixnum (1- line-size))) + (the fixnum (1+ cache-size)) line-size - (the index (floor cache-size line-size)))))) + (the fixnum (floor cache-size line-size)))))) @@ -785,21 +695,20 @@ ;;; compute the primary location of an entry. ;;; (defun compute-primary-cache-location (field mask wrappers) - (declare (type field-type field) (type index mask)) + (declare (type field-type field) (fixnum mask)) (if (not (listp wrappers)) - (the index - (logand mask (the index (wrapper-cache-number-vector-ref wrappers field)))) + (logand mask (the fixnum (wrapper-cache-number-vector-ref wrappers field))) (let ((location 0) (i 0)) - (declare (type index location i)) + (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 (type index wrapper-cache-number)) + (declare (fixnum wrapper-cache-number)) (if (zerop wrapper-cache-number) (return-from compute-primary-cache-location 0) - (setq location (the index (+ location wrapper-cache-number))))) + (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. @@ -807,9 +716,9 @@ (when (and (not (zerop i)) (zerop (mod i wrapper-cache-number-adds-ok))) (setq location - (the index (logand location wrapper-cache-number-mask)))) - (setf i (the index (1+ i)))) - (the index (1+ (the index (logand mask location))))))) + (logand location wrapper-cache-number-mask))) + (incf i)) + (the fixnum (1+ (logand mask location)))))) ;;; ;;; COMPUTE-PRIMARY-CACHE-LOCATION-FROM-LOCATION @@ -823,72 +732,27 @@ ;;; 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 (field cache location) - (declare (type field-type field) (type index location)) +(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 cache)) - (mask (cache-mask cache)) - (nkeys (cache-nkeys cache))) - (declare (type index result mask nkeys) (simple-vector cache-vector)) + (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) - (let* ((wrapper (cache-vector-ref cache-vector (+ i location))) + (let* ((wrapper (cache-vector-ref cache-vector (+ i from-location))) (wcn (wrapper-cache-number-vector-ref wrapper field))) - (declare (type index wcn)) - (setq result (the index (+ result wcn)))) + (declare (fixnum wcn)) + (setq result (+ result wcn))) (when (and (not (zerop i)) (zerop (mod i wrapper-cache-number-adds-ok))) - (setq result (the index (logand result wrapper-cache-number-mask))))) + (setq result (logand result wrapper-cache-number-mask)))) (if (= nkeys 1) (logand mask result) - (the index (1+ (the index (logand mask result))))))) - -(defun emit-1-wrapper-compute-primary-cache-location (wrapper primary wrapper-cache-no) - (with-lap-registers ((mask index) - #+structure-wrapper (cnv fixnum-vector)) - (let ((field wrapper-cache-no)) - (flatten-lap - (opcode :move (operand :cvar 'mask) mask) - (opcode :move (operand :cvar 'field) field) - #-structure-wrapper - (opcode :move (emit-wrapper-ref wrapper field) wrapper-cache-no) - #+structure-wrapper - (opcode :move (emit-wrapper-cache-number-vector wrapper) cnv) - #+structure-wrapper - (opcode :move (emit-cache-number-vector-ref cnv field) wrapper-cache-no) - (opcode :move (operand :ilogand wrapper-cache-no mask) primary))))) - -(defun emit-n-wrapper-compute-primary-cache-location (wrappers primary miss-label) - (with-lap-registers ((field index) - (mask index)) - (let ((add-wrapper-cache-numbers - (flatten-lap - (gathering1 (flattening-lap) - (iterate ((wrapper (list-elements wrappers)) - (i (interval :from 1))) - (gather1 - (with-lap-registers ((wrapper-cache-no index) - #+structure-wrapper (cnv fixnum-vector)) - (flatten-lap - #-structure-wrapper - (opcode :move (emit-wrapper-ref wrapper field) wrapper-cache-no) - #+structure-wrapper - (opcode :move (emit-wrapper-cache-number-vector wrapper) cnv) - #+structure-wrapper - (opcode :move (emit-cache-number-vector-ref cnv field) - wrapper-cache-no) - (opcode :izerop wrapper-cache-no miss-label) - (opcode :move (operand :i+ primary wrapper-cache-no) primary) - (when (zerop (the index (mod (the index i) - wrapper-cache-number-adds-ok))) - (opcode :move (operand :ilogand primary mask) primary)))))))))) - (flatten-lap - (opcode :move (operand :constant 0) primary) - (opcode :move (operand :cvar 'field) field) - (opcode :move (operand :cvar 'mask) mask) - add-wrapper-cache-numbers - (opcode :move (operand :ilogand primary mask) primary) - (opcode :move (operand :i1+ primary) primary))))) - + (the fixnum (1+ (logand mask result)))))) ;;; @@ -934,77 +798,54 @@ ((eq metatype new-metatype) new-metatype) (t 'class)))))) - - -(defun emit-fetch-wrapper (metatype argument dest miss-label &optional slot) - (let ((exit-emit-fetch-wrapper (make-symbol "exit-emit-fetch-wrapper"))) - (with-lap-registers ((arg t)) - (ecase metatype - (standard-instance - (let ((get-std-inst-wrapper (make-symbol "get-std-inst-wrapper")) - (get-fsc-inst-wrapper (make-symbol "get-fsc-inst-wrapper")) - #+pcl-user-instances - (get-user-inst-wrapper (make-symbol "get-user-inst-wrapper"))) - (flatten-lap - (opcode :move (operand :arg argument) arg) - (opcode :std-instance-p arg get-std-inst-wrapper) ;is it a std wrapper? - (opcode :fsc-instance-p arg get-fsc-inst-wrapper) ;is it a fsc wrapper? - #+pcl-user-instances - (opcode :user-instance-p arg get-user-inst-wrapper) ;is it a user wrapper? - (opcode :go miss-label) - #+pcl-user-instances - (opcode :label get-user-inst-wrapper) - #+pcl-user-instances - (opcode :move (operand :user-wrapper arg) dest) ;get user wrapper - #+pcl-user-instances - (and slot - (opcode :move (operand :user-slots arg) slot)) - #+pcl-user-instances - (opcode :go exit-emit-fetch-wrapper) - (opcode :label get-fsc-inst-wrapper) - (opcode :move (operand :fsc-wrapper arg) dest) ;get fsc wrapper - (and slot - (opcode :move (operand :fsc-slots arg) slot)) - (opcode :go exit-emit-fetch-wrapper) - (opcode :label get-std-inst-wrapper) - (opcode :move (operand :std-wrapper arg) dest) ;get std wrapper - (and slot - (opcode :move (operand :std-slots arg) slot)) - (opcode :label exit-emit-fetch-wrapper)))) - (class - (when slot (error "Can't do a slot reg for this metatype.")) - (let ((get-std-inst-wrapper (make-symbol "get-std-inst-wrapper")) - (get-fsc-inst-wrapper (make-symbol "get-fsc-inst-wrapper")) - #+pcl-user-instances - (get-user-inst-wrapper (make-symbol "get-user-inst-wrapper"))) - (flatten-lap - (opcode :move (operand :arg argument) arg) - (opcode :std-instance-p arg get-std-inst-wrapper) - (opcode :fsc-instance-p arg get-fsc-inst-wrapper) - #+pcl-user-instances - (opcode :user-instance-p arg get-user-inst-wrapper) - (opcode :move (operand :built-in-or-structure-wrapper arg) dest) - (opcode :go exit-emit-fetch-wrapper) - #+pcl-user-instances - (opcode :label get-user-inst-wrapper) - #+pcl-user-instances - (opcode :move (operand :user-wrapper arg) dest) - #+pcl-user-instances - (opcode :go exit-emit-fetch-wrapper) - (opcode :label get-fsc-inst-wrapper) - (opcode :move (operand :fsc-wrapper arg) dest) - (opcode :go exit-emit-fetch-wrapper) - (opcode :label get-std-inst-wrapper) - (opcode :move (operand :std-wrapper arg) dest) - (opcode :label exit-emit-fetch-wrapper)))) - ((built-in-instance structure-instance) - (when slot (error "Can't do a slot reg for this metatype.")) - (let () - (flatten-lap - (opcode :move (operand :arg argument) arg) - (opcode :std-instance-p arg miss-label) - (opcode :fsc-instance-p arg miss-label) - (opcode :move (operand :built-in-or-structure-wrapper arg) dest)))))))) +(defmacro with-dfun-wrappers ((args metatypes) + (dfun-wrappers invalid-wrapper-p + &optional wrappers classes types) + invalid-arguments-form + &body body) + `(let* ((args-tail ,args) (,invalid-wrapper-p nil) (invalid-arguments-p nil) + (,dfun-wrappers nil) (dfun-wrappers-tail nil) + ,@(when wrappers + `((wrappers-rev nil) (types-rev nil) (classes-rev nil)))) + (dolist (mt ,metatypes) + (unless args-tail + (setq invalid-arguments-p t) + (return nil)) + (let* ((arg (pop args-tail)) + (wrapper nil) + ,@(when wrappers + `((class *the-class-t*) + (type 't)))) + (unless (eq mt 't) + (setq wrapper (wrapper-of arg)) + (when (invalid-wrapper-p wrapper) + (setq ,invalid-wrapper-p t) + (setq wrapper (check-wrapper-validity arg))) + (cond ((null ,dfun-wrappers) + (setq ,dfun-wrappers wrapper)) + ((not (consp ,dfun-wrappers)) + (setq dfun-wrappers-tail (list wrapper)) + (setq ,dfun-wrappers (cons ,dfun-wrappers dfun-wrappers-tail))) + (t + (let ((new-dfun-wrappers-tail (list wrapper))) + (setf (cdr dfun-wrappers-tail) new-dfun-wrappers-tail) + (setf dfun-wrappers-tail new-dfun-wrappers-tail)))) + ,@(when wrappers + `((setq class (wrapper-class* wrapper)) + (setq type `(class-eq ,class))))) + ,@(when wrappers + `((push wrapper wrappers-rev) + (push class classes-rev) + (push type types-rev))))) + (if invalid-arguments-p + ,invalid-arguments-form + (let* (,@(when wrappers + `((,wrappers (nreverse wrappers-rev)) + (,classes (nreverse classes-rev)) + (,types (mapcar #'(lambda (class) + `(class-eq ,class)) + ,classes))))) + ,@body)))) ;;; @@ -1017,14 +858,12 @@ (defvar *dfun-arg-symbols* '(.ARG0. .ARG1. .ARG2. .ARG3.)) (defun dfun-arg-symbol (arg-number) - (declare (type index arg-number)) (or (nth arg-number (the list *dfun-arg-symbols*)) (intern (format nil ".ARG~A." arg-number) *the-pcl-package*))) (defvar *slot-vector-symbols* '(.SLOTS0. .SLOTS1. .SLOTS2. .SLOTS3.)) (defun slot-vector-symbol (arg-number) - (declare (type index arg-number)) (or (nth arg-number (the list *slot-vector-symbols*)) (intern (format nil ".SLOTS~A." arg-number) *the-pcl-package*))) @@ -1047,6 +886,18 @@ (when applyp (gather1 '&rest)))) +(defun make-emf-call (metatypes applyp fn-variable &optional emf-type) + (let ((required + (gathering1 (collecting) + (iterate ((i (interval :from 0)) + (s (list-elements metatypes))) + (progn s) + (gather1 (dfun-arg-symbol i)))))) + `(,(if (eq emf-type 'fast-method-call) + 'invoke-effective-method-function-fast + 'invoke-effective-method-function) + ,fn-variable ,applyp ,@required ,@(when applyp `(.dfun-rest-arg.))))) + (defun make-dfun-call (metatypes applyp fn-variable) (let ((required (gathering1 (collecting) @@ -1055,8 +906,30 @@ (progn s) (gather1 (dfun-arg-symbol i)))))) (if applyp - `(method-function-apply ,fn-variable ,@required .dfun-rest-arg.) - `(method-function-funcall ,fn-variable ,@required)))) + `(function-apply ,fn-variable ,@required .dfun-rest-arg.) + `(function-funcall ,fn-variable ,@required)))) + +(defun make-dfun-arg-list (metatypes applyp) + (let ((required + (gathering1 (collecting) + (iterate ((i (interval :from 0)) + (s (list-elements metatypes))) + (progn s) + (gather1 (dfun-arg-symbol i)))))) + (if applyp + `(list* ,@required .dfun-rest-arg.) + `(list ,@required)))) + +(defun make-fast-method-call-lambda-list (metatypes applyp) + (gathering1 (collecting) + (gather1 '.pv-cell.) + (gather1 '.next-method-call.) + (iterate ((i (interval :from 0)) + (s (list-elements metatypes))) + (progn s) + (gather1 (dfun-arg-symbol i))) + (when applyp + (gather1 '.dfun-rest-arg.)))) ;;; @@ -1087,18 +960,19 @@ (size () (cache-size .cache.)) (mask () (cache-mask .cache.)) (field () (cache-field .cache.)) + (overflow () (cache-overflow .cache.)) ;; ;; Return T IFF this cache location is reserved. The only time ;; this is true is for line number 0 of an nkeys=1 cache. ;; (line-reserved-p (line) - (declare (type index line)) + (declare (fixnum line)) (and (= (nkeys) 1) (= line 0))) ;; (location-reserved-p (location) - (declare (type index location)) + (declare (fixnum location)) (and (= (nkeys) 1) (= location 0))) ;; @@ -1108,21 +982,21 @@ ;; by line size. ;; (line-location (line) - (declare (type index line)) + (declare (fixnum line)) (when (line-reserved-p line) (error "line is reserved")) (if (= (nkeys) 1) - (the index (* line (line-size))) - (the index (1+ (the index (* line (line-size))))))) + (the fixnum (* line (line-size))) + (the fixnum (1+ (the fixnum (* line (line-size))))))) ;; ;; Given a cache location, return the line. This is the inverse ;; of LINE-LOCATION. ;; (location-line (location) - (declare (type index location)) + (declare (fixnum location)) (if (= (nkeys) 1) (floor location (line-size)) - (floor (the index (1- location)) (line-size)))) + (floor (the fixnum (1- location)) (line-size)))) ;; ;; Given a line number, return the wrappers stored at that line. ;; As usual, if nkeys=1, this returns a single value. Only when @@ -1130,12 +1004,12 @@ ;; line is reserved. ;; (line-wrappers (line) - (declare (type index line)) + (declare (fixnum line)) (when (line-reserved-p line) (error "Line is reserved.")) (location-wrappers (line-location line))) ;; (location-wrappers (location) ; avoid multiplies caused by line-location - (declare (type index location)) + (declare (fixnum location)) (if (= (nkeys) 1) (cache-vector-ref (vector) location) (let ((list (make-list (nkeys))) @@ -1148,12 +1022,12 @@ ;; wrappers are the same as wrappers. ;; (line-matches-wrappers-p (line wrappers) - (declare (type index line)) + (declare (fixnum line)) (and (not (line-reserved-p line)) (location-matches-wrappers-p (line-location line) wrappers))) ;; (location-matches-wrappers-p (loc wrappers) ; must not be reserved - (declare (type index loc)) + (declare (fixnum loc)) (let ((cache-vector (vector))) (declare (simple-vector cache-vector)) (if (= (nkeys) 1) @@ -1167,12 +1041,12 @@ ;; an error is signalled if the line is reserved. ;; (line-value (line) - (declare (type index line)) + (declare (fixnum line)) (when (line-reserved-p line) (error "Line is reserved.")) (location-value (line-location line))) ;; (location-value (loc) - (declare (type index loc)) + (declare (fixnum loc)) (and (valuep) (cache-vector-ref (vector) (+ loc (nkeys))))) ;; @@ -1189,12 +1063,12 @@ ;; An error is signalled if the line is reserved. ;; (line-valid-p (line wrappers) - (declare (type index line)) + (declare (fixnum line)) (when (line-reserved-p line) (error "Line is reserved.")) (location-valid-p (line-location line) wrappers)) ;; (location-valid-p (loc wrappers) - (declare (type index loc)) + (declare (fixnum loc)) (let ((cache-vector (vector)) (wrappers-mismatch-p (null wrappers))) (declare (simple-vector cache-vector)) @@ -1211,9 +1085,9 @@ ;; How many unreserved lines separate line-1 and line-2. ;; (line-separation (line-1 line-2) - (declare (type index line-1 line-2)) + (declare (fixnum line-1 line-2)) (let ((diff (the fixnum (- line-2 line-1)))) - (declare (type fixnum diff)) + (declare (fixnum diff)) (when (minusp diff) (setq diff (+ diff (nlines))) (when (line-reserved-p 0) @@ -1224,32 +1098,32 @@ ;; return a reserved line. ;; (next-line (line) - (declare (type index line)) - (if (= line (the index (1- (nlines)))) + (declare (fixnum line)) + (if (= line (the fixnum (1- (nlines)))) (if (line-reserved-p 0) 1 0) - (the index (1+ line)))) + (the fixnum (1+ line)))) ;; (next-location (loc) - (declare (type index loc)) + (declare (fixnum loc)) (if (= loc (max-location)) (if (= (nkeys) 1) (line-size) 1) - (the index (+ loc (line-size))))) + (the fixnum (+ loc (line-size))))) ;; ;; Given a line which has a valid entry in it, this will return ;; the primary cache line of the wrappers in that line. We just ;; call COMPUTE-PRIMARY-CACHE-LOCATION-FROM-LOCATION, this is an ;; easier packaging up of the call to it. ;; - (line-primary (field line) - (declare (type index field line)) - (location-line (line-primary-location field line))) + (line-primary (line) + (declare (fixnum line)) + (location-line (line-primary-location line))) ;; - (line-primary-location (field line) - (declare (type index field line)) + (line-primary-location (line) + (declare (fixnum line)) (compute-primary-cache-location-from-location - field (cache) (line-location line))) + (cache) (line-location line))) )) (defmacro with-local-cache-functions ((cache) &body body) @@ -1264,7 +1138,7 @@ *local-cache-functions*) ,@body))) -) ;eval-when +) ;;; ;;; Here is where we actually fill, recache and expand caches. @@ -1285,55 +1159,66 @@ ;;; (defvar *cache-expand-threshold* 1.25) -(defun cache-count (cache) - (with-local-cache-functions (cache) - (let ((count 0)(location (if (= (nkeys) 1) (line-size) 1))) - (declare (type index count)) - (dotimes (i (nlines) count) - (unless (or (location-reserved-p location) - (not (location-valid-p location nil))) - (setq count (the index (1+ count)))) - (setq location (next-location location)))))) - -#| -(defun entry-in-cache-p (cache wrappers value) - (declare (ignore value)) - (with-local-cache-functions (cache) - (dotimes (i (nlines)) - (unless (line-reserved-p i) - (when (equal (line-wrappers i) wrappers) - (return t)))))) -|# - (defun fill-cache (cache wrappers value &optional free-cache-p) - (declare (values cache)) + ;;(declare (values cache)) (unless wrappers ; fill-cache won't return if wrappers is nil, might as well check. (error "fill-cache: wrappers arg is NIL!")) (or (fill-cache-p nil cache wrappers value) - (and (< (the index (ceiling (* (cache-count cache) 1.25))) - (the index - (if (= (cache-nkeys cache) 1) - (1- (cache-nlines cache)) - (cache-nlines cache)))) + (and (< (ceiling (* (cache-count cache) 1.25)) + (if (= (cache-nkeys cache) 1) + (1- (cache-nlines cache)) + (cache-nlines cache))) (adjust-cache cache wrappers value free-cache-p)) (expand-cache cache wrappers value free-cache-p))) -(defun probe-cache (cache wrappers &optional default) - (declare (values value)) +(defvar *check-cache-p* nil) + +(defmacro maybe-check-cache (cache) + `(progn + (when *check-cache-p* + (check-cache ,cache)) + ,cache)) + +(defun check-cache (cache) + (with-local-cache-functions (cache) + (let ((location (if (= (nkeys) 1) 0 1)) + (limit (funcall (limit-fn) (nlines)))) + (dotimes (i (nlines) cache) + (when (and (not (location-reserved-p location)) + (line-full-p i)) + (let* ((home-loc (compute-primary-cache-location-from-location + cache location)) + (home (location-line (if (location-reserved-p home-loc) + (next-location home-loc) + home-loc))) + (sep (when home (line-separation 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)))) + (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-function (limit-fn) (nlines)))) - (declare (type index location limit)) + (limit (funcall (or limit-fn (limit-fn)) (nlines)))) + (declare (fixnum location limit)) (when (location-reserved-p location) (setq location (next-location location))) - (dotimes (i limit default) + (dotimes (i (1+ limit)) (when (location-matches-wrappers-p location wrappers) - (return (or (not (valuep)) (location-value location)))) - (setq location (next-location location)))))) + (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))) (defun map-cache (function cache &optional set-p) - (declare (type real-function function)) (with-local-cache-functions (cache) (let ((set-p (and set-p (valuep)))) (dotimes (i (nlines) cache) @@ -1341,18 +1226,38 @@ (let ((value (funcall function (line-wrappers i) (line-value i)))) (when set-p (setf (cache-vector-ref (vector) (+ (line-location i) (nkeys))) - value)))))))) + value))))) + (dolist (entry (overflow)) + (let ((value (funcall function (car entry) (cdr entry)))) + (when set-p + (setf (cdr entry) value)))))) + cache) +(defun cache-count (cache) + (with-local-cache-functions (cache) + (let ((count 0)) + (declare (fixnum count)) + (dotimes (i (nlines) count) + (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)) + (unless (line-reserved-p i) + (when (equal (line-wrappers i) wrappers) + (return t)))))) ;;; ;;; returns T or NIL ;;; - (defun fill-cache-p (forcep cache wrappers value) (with-local-cache-functions (cache) (let* ((location (compute-primary-cache-location (field) (mask) wrappers)) (primary (location-line location))) - (declare (type index location primary)) + (declare (fixnum location primary)) (multiple-value-bind (free emptyp) (find-free-cache-line primary cache wrappers) (when (or forcep emptyp) @@ -1361,32 +1266,33 @@ (cache-overflow cache))) ;;(fill-line free wrappers value) (let ((line free)) - (declare (type index line)) + (declare (fixnum line)) (when (line-reserved-p line) (error "Attempt to fill a reserved line.")) (let ((loc (line-location line)) (cache-vector (vector))) - (declare (type index loc) (simple-vector cache-vector)) + (declare (fixnum loc) (simple-vector cache-vector)) (cond ((= (nkeys) 1) (setf (cache-vector-ref cache-vector loc) wrappers) (when (valuep) (setf (cache-vector-ref cache-vector (1+ loc)) value))) (t (let ((i 0)) - (declare (type index i)) + (declare (fixnum i)) (dolist (w wrappers) (setf (cache-vector-ref cache-vector (+ loc i)) w) - (setq i (the index (1+ i))))) + (setq i (the fixnum (1+ i))))) (when (valuep) (setf (cache-vector-ref cache-vector (+ loc (nkeys))) - value)))))) - cache))))) + value)))) + (maybe-check-cache cache)))))))) (defun fill-cache-from-cache-p (forcep cache from-cache from-line) - (declare (type index from-line)) - (with-local-cache-functions (from-cache) - (let ((primary (line-primary (field) from-line))) - (declare (type index primary)) + (declare (fixnum from-line)) + (with-local-cache-functions (cache) + (let ((primary (location-line (compute-primary-cache-location-from-location + cache (line-location from-line) from-cache)))) + (declare (fixnum primary)) (multiple-value-bind (free emptyp) (find-free-cache-line primary cache) (when (or forcep emptyp) @@ -1394,25 +1300,25 @@ (push (cons (line-wrappers free) (line-value free)) (cache-overflow cache))) ;;(transfer-line from-cache-vector from-line cache-vector free) - (let ((from-cache-vector (vector)) - (to-cache-vector (cache-vector cache)) + (let ((from-cache-vector (cache-vector from-cache)) + (to-cache-vector (vector)) (to-line free)) - (declare (type index to-line)) + (declare (fixnum to-line)) (if (line-reserved-p to-line) (error "transfering something into a reserved cache line.") (let ((from-loc (line-location from-line)) (to-loc (line-location to-line))) - (declare (type index from-loc to-loc)) + (declare (fixnum from-loc to-loc)) (modify-cache to-cache-vector (dotimes (i (line-size)) (setf (cache-vector-ref to-cache-vector (+ to-loc i)) (cache-vector-ref from-cache-vector - (+ from-loc i)))))))) - cache))))) + (+ from-loc i))))))) + (maybe-check-cache cache))))))) ;;; -;;; Returns NIL or (values <field> <cache>) +;;; Returns NIL or (values <field> <cache-vector>) ;;; ;;; This is only called when it isn't possible to put the entry in the cache ;;; the easy way. That is, this function assumes that FILL-CACHE-P has been @@ -1427,7 +1333,7 @@ (let ((ncache (get-cache-from-cache cache (nlines) (field)))) (do ((nfield (cache-field ncache) (next-wrapper-cache-number-index nfield))) ((null nfield) (free-cache ncache) nil) - (setf (cache-field ncache) (the index nfield)) + (setf (cache-field ncache) nfield) (labels ((try-one-fill-from-line (line) (fill-cache-from-cache-p nil ncache cache line)) (try-one-fill (wrappers value) @@ -1441,7 +1347,7 @@ (return nil))) (try-one-fill wrappers value)) (progn (when free-old-cache-p (free-cache cache)) - (return ncache)) + (return (maybe-check-cache ncache))) (flush-cache-vector-internal (cache-vector ncache)))))))) @@ -1449,9 +1355,9 @@ ;;; returns: (values <cache>) ;;; (defun expand-cache (cache wrappers value free-old-cache-p) - (declare (values cache)) + ;;(declare (values cache)) (with-local-cache-functions (cache) - (let ((ncache (get-cache-from-cache cache (the index (* (nlines) 2))))) + (let ((ncache (get-cache-from-cache cache (* (nlines) 2)))) (labels ((do-one-fill-from-line (line) (unless (fill-cache-from-cache-p nil ncache cache line) (do-one-fill (line-wrappers line) (line-value line)))) @@ -1470,9 +1376,9 @@ (unless (try-one-fill wrappers value) (do-one-fill wrappers value)) (when free-old-cache-p (free-cache cache)) - ncache)))) - + (maybe-check-cache ncache))))) + ;;; ;;; This is the heart of the cache filling mechanism. It implements the decisions ;;; about where entries are placed. @@ -1483,78 +1389,71 @@ ;;; <empty?> is <line> in fact empty? ;;; (defun find-free-cache-line (primary cache &optional wrappers) - (declare (values line empty?)) - (declare (type index primary)) + ;;(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-function (limit-fn) (nlines))) - (field (field)) + (let ((limit (funcall (limit-fn) (nlines))) (wrappedp nil) (lines nil) - (p primary) (s primary) - (successp nil)) - (declare (type index p s limit) (type field-type field) - (type boolean wrappedp successp)) + (p primary) (s primary)) + (declare (fixnum p s limit)) (block find-free (loop ;; Try to find a free line starting at <s>. <p> is the ;; 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) (the index (1+ nsep)))) + (nsep (line-separation p s) (1+ nsep))) (()) - (declare (type index line 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. - (return-from find-free (setq successp t))) - (let ((osep (line-separation (line-primary field line) line))) - (when (and wrappedp (>= line primary)) - ;; have gone all the way around the cache, time to quit - (push line lines) - (return-from find-free (setq successp nil))) + (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))) + (when (>= osep limit) + (return-from find-free-cache-line (values primary nil))) (when (cond ((= nsep limit) t) - ((= nsep osep) (zerop (the index (random 2)))) + ((= nsep osep) (zerop (random 2))) ((> nsep osep) t) (t nil)) ;; See if we can displace what is in this line so that we ;; can use the line. - (when (= line (the index (1- (nlines)))) (setq wrappedp t)) - (setq p (line-primary field line)) + (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 index (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)) (let ((dline (pop lines)) (line (car lines))) - (declare (type index dline line)) - (when successp - ;;Copy from line to dline (dline is known to be free). - (let ((from-loc (line-location line)) - (to-loc (line-location dline)) - (cache-vector (vector))) - (declare (type index from-loc to-loc) (simple-vector cache-vector)) - (modify-cache cache-vector - (dotimes (i (line-size)) - (setf (cache-vector-ref cache-vector (+ to-loc i)) - (cache-vector-ref cache-vector (+ from-loc i))) - (setf (cache-vector-ref cache-vector (+ from-loc i)) - nil))))))) - (values (car lines) successp)))) + (declare (fixnum dline line)) + ;;Copy from line to dline (dline is known to be free). + (let ((from-loc (line-location line)) + (to-loc (line-location dline)) + (cache-vector (vector))) + (declare (fixnum from-loc to-loc) (simple-vector cache-vector)) + (modify-cache cache-vector + (dotimes (i (line-size)) + (setf (cache-vector-ref cache-vector (+ to-loc i)) + (cache-vector-ref cache-vector (+ from-loc i))) + (setf (cache-vector-ref cache-vector (+ from-loc i)) + nil)))))) + (values (car lines) t)))) (defun default-limit-fn (nlines) - (declare (type index nlines)) (case nlines ((1 2 4) 1) ((8 16) 4) (otherwise 6))) -(declaim (type cache *empty-cache*)) (defvar *empty-cache* (make-cache)) ; for defstruct slot initial value forms - - ;;; ;;; pre-allocate generic function caches. The hope is that this will put diff --git a/pcl/cmu-low.lisp b/pcl/cmu-low.lisp index 2c0b1a5ff..ab684398e 100644 --- a/pcl/cmu-low.lisp +++ b/pcl/cmu-low.lisp @@ -29,16 +29,9 @@ (in-package 'pcl) -(defun function-ftype-declaimed-p (name) - "Returns whether the function given by name already has its ftype declaimed." - (multiple-value-bind (ftype-info recorded-p) - (extensions:info function type name) - (declare (ignore ftype-info)) - recorded-p)) - (defmacro dotimes ((var count &optional (result nil)) &body body) - `(lisp:dotimes (,var (the index ,count) ,result) - (declare (type index ,var)) + `(lisp:dotimes (,var (the fixnum ,count) ,result) + (declare (fixnum ,var)) ,@body)) ;;; Just use our without-interrupts. We don't have the INTERRUPTS-ON/OFF local @@ -60,17 +53,6 @@ `(and (ext:structurep ,n-x) (eq (kernel:structure-ref ,n-x 0) 'std-instance))))) - ;; -;;;;;; Cache No's - ;; - -(proclaim '(inline object-cache-no)) - -(defun object-cache-no (symbol mask) - (logand (ext:truly-the fixnum (system:%primitive make-fixnum symbol)) - (the fixnum mask))) - - (defun function-arglist (fcn) "Returns the argument list of a compiled function, if possible." (cond ((symbolp fcn) @@ -111,28 +93,378 @@ (in-package "C") ;;From compiler/ir1util -(def-source-context pcl::defmethod (name &rest stuff) - (declare (type list stuff)) +(def-source-context pcl:defmethod (name &rest stuff) (let ((arg-pos (position-if #'listp stuff))) - (declare (type (or null index) arg-pos)) (if arg-pos - `(pcl::defmethod ,name ,@(subseq stuff 0 arg-pos) + `(pcl:defmethod ,name ,@(subseq stuff 0 arg-pos) ,(nth-value 2 (pcl::parse-specialized-lambda-list (elt stuff arg-pos)))) - `(pcl::defmethod ,name "<illegal syntax>")))) + `(pcl:defmethod ,name "<illegal syntax>")))) +(define-info-type type kind (member :primitive :defined :structure :class nil) + (if (or (info type builtin name) + (info type translator name)) + :primitive + nil)) +(define-info-type type class-info (or pcl::class symbol null) nil) -(in-package 'pcl) +(in-package "KERNEL") + +(export '(clos-type clos-type-class)) + +(defmacro cold-load-init (&rest forms) + `(progn ,@forms)) + +(defstruct (clos-type (:include ctype + (:class-info (type-class-or-lose 'clos)) + (:enumerable t)) + (:print-function %print-type)) + ;; + ;; The CLOS class. + (class nil)) + +(define-type-class clos) + +(define-type-method (clos :unparse) (x) + (clos-type-class x)) + +(define-type-method (clos :complex-union) (type1 type2) + (make-union-type (list type1 type2))) + +(define-type-method (clos :simple-=) (type1 type2) + (values (eq (clos-type-class type1) + (clos-type-class type2)) + t)) + +(define-type-method (clos :simple-subtypep) (type1 type2) + (let ((class1 (pcl:find-class (clos-type-class type1) nil)) + (class2 (pcl:find-class (clos-type-class type2) nil))) + (if (and class1 class2) + (values (member class2 + (pcl:class-precedence-list class2)) t) + (values nil nil)))) + +;; Add the new ctype to its supertypes. +;; +(let ((the-type-* (values-specifier-type '*))) + (pushnew 'clos (named-type-subclasses the-type-*))) +(let ((the-type-t (values-specifier-type 't))) + (pushnew 'clos (named-type-subclasses the-type-t))) + +(defun-cached (values-specifier-type + :hash-function (lambda (x) + (the fixnum + (logand (the fixnum (cache-hash-eq x)) + #x3FF))) + :hash-bits 10) + ((spec eq)) + (or (info type builtin spec) + (let ((expand (type-expand spec))) + (if (eq expand spec) + (let* ((lspec (if (atom spec) (list spec) spec)) + (fun (info type translator (car lspec)))) + (cond + (fun (funcall fun lspec)) + ((and (symbolp spec) + (eq (info type kind spec) :structure)) + (make-structure-type :name spec)) + ((and (symbolp spec) + (eq (info type kind spec) :class)) + (make-clos-type :class spec)) + ((or (and (consp spec) (symbolp (car spec))) + (symbolp spec)) + (signal 'parse-unknown-type :specifier spec) + ;; + ;; Inhibit caching... + (return-from values-specifier-type + (make-unknown-type :specifier spec))) + (t + (error "Bad thing to be a type specifier: ~S." + spec)))) + (values-specifier-type expand))))) + +(defun ctypep (obj type) + (declare (type ctype type)) + (etypecase type + ((or numeric-type named-type member-type array-type) + (values (typep obj (type-specifier type)) t)) + (structure-type + (if (structurep obj) + (let* ((name (structure-type-name type)) + (info (info type structure-info name)) + (defined-info (info type defined-structure-info name))) + (if (and info defined-info + (equal (c::dd-includes info) + (c::dd-includes defined-info))) + (values (typep obj name) t) + (values nil nil))) + (values nil t))) + (clos-type + (let ((class (clos-type-class type))) + (if (pcl::std-instance-p obj) + (values (pcl::*typep obj class) t) + (values nil t)))) + (union-type + (dolist (mem (union-type-types type) (values nil t)) + (multiple-value-bind (val win) + (ctypep obj mem) + (unless win (return (values nil nil))) + (when val (return (values t t)))))) + (function-type + (values (functionp obj) t)) + (unknown-type + (values nil nil)) + (alien-type-type + (values (alien-typep obj (alien-type-type-alien-type type)) t)) + (hairy-type + ;; Now the tricky stuff. + (let* ((hairy-spec (hairy-type-specifier type)) + (symbol (if (consp hairy-spec) (car hairy-spec) hairy-spec))) + (ecase symbol + (and + (if (atom hairy-spec) + (values t t) + (dolist (spec (cdr hairy-spec) (values t t)) + (multiple-value-bind (res win) + (ctypep obj (specifier-type spec)) + (unless win (return (values nil nil))) + (unless res (return (values nil t))))))) + (not + (multiple-value-bind + (res win) + (ctypep obj (specifier-type (cadr hairy-spec))) + (if win + (values (not res) t) + (values nil nil)))) + (satisfies + (let ((fun (second hairy-spec))) + (cond ((and (consp fun) (eq (car fun) 'lambda)) + (values (not (null (funcall (coerce fun 'function) obj))) + t)) + ((and (symbolp fun) (fboundp fun)) + (values (not (null (funcall fun obj))) t)) + (t + (values nil nil)))))))))) + +(in-package "LISP") + +(defun %%typep (object type) + (declare (type ctype type)) + (etypecase type + (named-type + (ecase (named-type-name type) + ((* t) + t) + ((nil) + nil) + (character (characterp object)) + (base-char (base-char-p object)) + (standard-char (and (characterp object) (standard-char-p object))) + (extended-char + (and (characterp object) (not (base-char-p object)))) + (function (functionp object)) + (cons (consp object)) + (symbol (symbolp object)) + (keyword + (and (symbolp object) + (eq (symbol-package object) + (symbol-package :foo)))) + (system-area-pointer (system-area-pointer-p object)) + (weak-pointer (weak-pointer-p object)) + (code-component (code-component-p object)) + (lra (lra-p object)) + (fdefn (fdefn-p object)) + (scavenger-hook (scavenger-hook-p object)) + (structure (structurep object)))) + (numeric-type + (and (numberp object) + (let ((num (if (complexp object) (realpart object) object))) + (ecase (numeric-type-class type) + (integer (integerp num)) + (rational (rationalp num)) + (float + (ecase (numeric-type-format type) + (short-float (typep object 'short-float)) + (single-float (typep object 'single-float)) + (double-float (typep object 'double-float)) + (long-float (typep object 'long-float)) + ((nil) (floatp num)))) + ((nil) t))) + (flet ((bound-test (val) + (let ((low (numeric-type-low type)) + (high (numeric-type-high type))) + (and (cond ((null low) t) + ((listp low) (> val (car low))) + (t (>= val low))) + (cond ((null high) t) + ((listp high) (< val (car high))) + (t (<= val high))))))) + (ecase (numeric-type-complexp type) + ((nil) t) + (:complex + (and (complexp object) + (bound-test (realpart object)) + (bound-test (imagpart object)))) + (:real + (and (not (complexp object)) + (bound-test object))))))) + (array-type + (and (arrayp object) + (ecase (array-type-complexp type) + ((t) (not (typep object 'simple-array))) + ((nil) (typep object 'simple-array)) + (* t)) + (or (eq (array-type-dimensions type) '*) + (do ((want (array-type-dimensions type) (cdr want)) + (got (array-dimensions object) (cdr got))) + ((and (null want) (null got)) t) + (unless (and want got + (or (eq (car want) '*) + (= (car want) (car got)))) + (return nil)))) + (or (eq (array-type-element-type type) *wild-type*) + (type= (array-type-specialized-element-type type) + (specifier-type (array-element-type object)))))) + (member-type + (if (member object (member-type-members type)) t)) + (structure-type + (structure-typep object (structure-type-name type))) + (clos-type + (pcl::*typep object (clos-type-class type))) + (union-type + (dolist (type (union-type-types type)) + (when (%%typep object type) + (return t)))) + (unknown-type + ;; Type may be unknown to the compiler (and SPECIFIER-TYPE), yet be + ;; a defined structure in the core. + (let ((orig-spec (unknown-type-specifier type))) + (if (and (symbolp orig-spec) + (info type defined-structure-info orig-spec)) + (structure-typep object orig-spec) + (error "Unknown type specifier: ~S" orig-spec)))) + (hairy-type + ;; Now the tricky stuff. + (let* ((hairy-spec (hairy-type-specifier type)) + (symbol (if (consp hairy-spec) (car hairy-spec) hairy-spec))) + (ecase symbol + (and + (or (atom hairy-spec) + (dolist (spec (cdr hairy-spec) t) + (unless (%%typep object (specifier-type spec)) + (return nil))))) + (not + (unless (and (listp hairy-spec) (= (length hairy-spec) 2)) + (error "Invalid type specifier: ~S" hairy-spec)) + (not (%%typep object (specifier-type (cadr hairy-spec))))) + (satisfies + (unless (and (listp hairy-spec) (= (length hairy-spec) 2)) + (error "Invalid type specifier: ~S" hairy-spec)) + (let ((fn (cadr hairy-spec))) + (if (funcall (typecase fn + (function fn) + (symbol (symbol-function fn)) + (t + (coerce fn 'function))) + object) + t + nil)))))) + (alien-type-type + (alien-internals:alien-typep object (alien-type-type-alien-type type))) + (function-type + (error "Function types are not a legal argument to TYPEP:~% ~S" + (type-specifier type))))) + +(defun %deftype (name expander &optional doc) + (ecase (info type kind name) + (:primitive + (error "Illegal to redefine standard type: ~S." name)) + (:structure + (warn "Redefining structure type ~S with DEFTYPE." name) + (c::undefine-structure (info type structure-info name))) + (:class + (warn "Redefining class ~S with DEFTYPE." name)) + ((nil :defined))) + (setf (info type kind name) :defined) + (setf (info type expander name) expander) + (when doc + (setf (documentation name 'type) doc)) + ;; ### Bootstrap hack -- we need to define types before %note-type-defined + ;; is defined. + (when (fboundp 'c::%note-type-defined) + (c::%note-type-defined name)) + name) + +(defun type-of (object) + "Return the type of OBJECT." + (typecase object + ;; First the ones that we can tell by testing the lowtag + (fixnum 'fixnum) + (function (type-specifier (ctype-of object))) + (null 'null) + (list 'cons) + + ;; Any other immediates. + (character + (typecase object + (standard-char 'standard-char) + (base-char 'base-char) + (t 'character))) + + ;; And now for the complicated ones. + (number + (etypecase object + (fixnum 'fixnum) + (bignum 'bignum) + (float + (etypecase object + (double-float 'double-float) + (single-float 'single-float) + (short-float 'short-float) + (long-float 'long-float))) + (ratio 'ratio) + (complex 'complex))) + (symbol + (if (eq (symbol-package object) + (symbol-package :foo)) + 'keyword + 'symbol)) + (structure + (let ((name (structure-ref object 0))) + (case name + (pcl::std-instance + (pcl:class-name (pcl:class-of object))) + (alien-internals:alien-value + `(alien:alien + ,(alien-internals:unparse-alien-type + (alien-internals:alien-value-type object)))) + (t name)))) + (array (type-specifier (ctype-of object))) + (system-area-pointer 'system-area-pointer) + (weak-pointer 'weak-pointer) + (code-component 'code-component) + (lra 'lra) + (fdefn 'fdefn) + (scavenger-hook 'scavenger-hook) + (t + (warn "Can't figure out the type of ~S" object) + t))) + +(in-package "PCL") (pushnew :structure-wrapper *features*) -(pushnew :structure-functions *features*) -(import 'ext:structurep) +(defun structure-functions-exist-p () + t) + +(defun structure-instance-p (x) + (and (structurep x) + (not (eq (kernel:structure-ref x 0) 'std-instance)))) -(defmacro structure-type (x) - `(kernel:structure-ref ,x 0)) +(defun structure-type (x) + (kernel:structure-ref x 0)) -(defun known-structure-type-p (type) +(defun structure-type-p (type) (not (null (ext:info c::type c::defined-structure-info type)))) (defun structure-type-included-type-name (type) @@ -142,9 +474,8 @@ include))) (defun structure-type-slot-description-list (type) - (nthcdr (length (the list - (let ((include (structure-type-included-type-name type))) - (and include (structure-type-slot-description-list include))))) + (nthcdr (length (let ((include (structure-type-included-type-name type))) + (and include (structure-type-slot-description-list include)))) (c::dd-slots (ext:info c::type c::defined-structure-info type)))) (defun structure-slotd-name (slotd) @@ -160,3 +491,8 @@ (unless (c::dsd-read-only slotd) (fdefinition `(setf ,(c::dsd-accessor slotd))))) +(defun structure-slotd-type (slotd) + (c::dsd-type slotd)) + +(defun structure-slotd-init-form (slotd) + (c::dsd-default slotd)) diff --git a/pcl/combin.lisp b/pcl/combin.lisp index 60215f20b..430905251 100644 --- a/pcl/combin.lisp +++ b/pcl/combin.lisp @@ -27,48 +27,82 @@ (in-package 'pcl) -(defun null-wrappers-method-function (&rest args) - ;; Function returned when get-method-function passed no wrappers for - ;; caching. I'm not exactly sure why get-method-function gets called - ;; with null wrappers when a generic function is first created, but - ;; they do. However, the method-function returned never seemed to - ;; get called, so to save a bunch of unneed closure-generation - ;; and other muckity-muck, this function is just returned instead. - (error "Internal PCL error: Calling method-function created by - get-method-function with wrappers NIL. Called with args: ~S" - args)) - (defun get-method-function (method &optional method-alist wrappers) - (or (cadr (assq method method-alist)) - (if wrappers - (method-function-for-caching method wrappers) - (or (method-optimized-function method) - #'null-wrappers-method-function)))) + (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-function (make-effective-method-function1 generic-function form) - 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) +(defun make-effective-method-function1 (generic-function form + method-alist-p wrappers-p) (if (and (listp form) - (eq (car form) 'call-method) - (method-p (cadr form)) - (or (every #'method-p (caddr form)) - (not (method-needs-next-methods-p (cadr 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))) + (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) +(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 - ;; as the effective method function. + ;; 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 @@ -76,48 +110,47 @@ ;; asks about them. If it does, we must tell it whether there are ;; or aren't to prevent the leaky next methods bug. ;; - (let ((method (cadr form))) - (if (not (method-needs-next-methods-p method)) - #'(lambda (method-alist wrappers) - (get-method-function method method-alist wrappers)) - (let* ((arg-info (gf-arg-info generic-function)) - (metatypes (arg-info-metatypes arg-info)) - (applyp (arg-info-applyp arg-info)) - (next-methods (caddr form))) - (declare (type boolean applyp)) - (multiple-value-bind (cfunction constants) - (get-function1 - `(lambda ,(make-dfun-lambda-list metatypes applyp) - (let ((*next-methods* .next-methods.)) - ,(make-dfun-call metatypes applyp '.method.))) - #'default-test-converter ;This could be optimized by making - ;the interface from here to the - ;walker more clear so that the - ;form wouldn't get walked at all. - #'(lambda (form) - (if (memq form '(.next-methods. .method.)) - (values form (list form)) - form)) - #'(lambda (form) - (cond ((eq form '.next-methods.) - (list (cons '.meth-list. next-methods))) - ((eq form '.method.) - (list (cons '.meth. method)))))) - #'(lambda (method-alist wrappers) - (flet ((fix-meth (meth) - (get-method-function meth method-alist wrappers))) - (apply-function cfunction - (mapcar #'(lambda (constant) - (cond ((atom constant) - constant) - ((eq (car constant) '.meth.) - (fix-meth (cdr constant))) - ((eq (car constant) '.meth-list.) - (mapcar #'fix-meth (cdr constant))) - (t constant))) - constants))))))))) + (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)))) -(declaim (type list *global-effective-method-gensyms*)) (defvar *global-effective-method-gensyms* ()) (defvar *rebound-effective-method-gensyms*) @@ -133,75 +166,190 @@ (let ((*rebound-effective-method-gensyms* ())) (dotimes (i 10) (get-effective-method-gensym))) -(defun make-effective-method-function-internal (generic-function effective-method) - (let* ((*rebound-effective-method-gensyms* *global-effective-method-gensyms*) - (arg-info (gf-arg-info generic-function)) - (metatypes (arg-info-metatypes arg-info)) - (applyp (arg-info-applyp arg-info))) - (declare (type boolean applyp)) - (labels ((test-converter (form) - (if (and (consp form) (eq (car form) 'call-method)) - (if (caddr form) - '.call-method-with-next. - '.call-method-without-next.) - (default-test-converter form))) - (code-converter (form) - (if (and (consp form) (eq (car form) 'call-method)) - ;; - ;; We have a `call' to CALL-METHOD. There may or may not be next - ;; methods and the two cases are a little different. It controls - ;; how many gensyms we will generate. - ;; - (let ((gensyms - (if (caddr form) - (list (get-effective-method-gensym) - (get-effective-method-gensym)) - (list (get-effective-method-gensym))))) - (values `(let ((*next-methods* ,(cadr gensyms))) - ,(make-dfun-call metatypes applyp (car gensyms))) - gensyms)) - (default-code-converter form))) - (constant-converter (form) - (if (and (consp form) (eq (car form) 'call-method)) - (if (caddr form) - (list (cons '.meth. (check-for-make-method (cadr form))) - (cons '.meth-list. - (mapcar #'check-for-make-method (caddr form)))) - (list (cons '.meth. (check-for-make-method (cadr form))))) - (default-constant-converter form))) - (check-for-make-method (effective-method) - (cond ((method-p effective-method) - effective-method) - ((and (listp effective-method) - (eq (car effective-method) 'make-method)) - (make-effective-method-function1 - generic-function - (make-progn (cadr effective-method)))) - (t - (error "Effective-method form is malformed."))))) +(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)) + `(lambda ,(make-fast-method-call-lambda-list metatypes applyp) + (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))) + +(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)))) + +(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 `(lambda ,(make-dfun-lambda-list metatypes applyp) - ,effective-method) - #'test-converter - #'code-converter - #'constant-converter) + (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) - (flet ((fix-meth (meth) - (if (method-p meth) - (get-method-function meth method-alist wrappers) - (funcall-function meth method-alist wrappers)))) - (apply-function cfunction - (mapcar #'(lambda (constant) - (cond ((atom constant) - constant) - ((eq (car constant) '.meth.) - (fix-meth (cdr constant))) - ((eq (car constant) '.meth-list.) - (mapcar #'fix-meth (cdr constant))) - (t constant))) - constants)))))))) + (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))))))) + +(defmacro call-method-list (&rest calls) + `(progn ,@calls)) + +(defun make-call-methods (methods) + `(call-method-list + ,@(mapcar #'(lambda (method) `(call-method ,method ())) methods))) + +(defun standard-compute-effective-method (generic-function combin applicable-methods) + (declare (ignore combin)) + (let ((before ()) + (primary ()) + (after ()) + (around ())) + (dolist (m applicable-methods) + (let ((qualifiers (if (listp m) + (early-method-qualifiers m) + (method-qualifiers m)))) + (cond ((member ':before qualifiers) (push m before)) + ((member ':after qualifiers) (push m after)) + ((member ':around qualifiers) (push m around)) + (t + (push m primary))))) + (setq before (reverse before) + after (reverse after) + primary (reverse primary) + around (reverse around)) + (cond ((null primary) + `(error "No primary method for the generic function ~S." ',generic-function)) + ((and (null before) (null after) (null around)) + ;; + ;; 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 + (if (or before after) + `(multiple-value-prog1 + (progn ,(make-call-methods before) + (call-method ,(first primary) ,(rest primary))) + ,(make-call-methods (reverse after))) + `(call-method ,(first primary) ,(rest primary))))) + (if around + `(call-method ,(first around) + (,@(rest around) (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) @@ -243,52 +391,6 @@ (declare (arglist format-string &rest format-arguments)) (apply *method-combination-error* args)) - - -;;; -;;; 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. -;;; - -(defclass method-combination (metaobject) () - (:predicate-name method-combination-p)) - - -(mapc - #'proclaim-incompatible-superclasses - '(;; superclass metaobject - (class eql-specializer class-eq-specializer method method-combination - generic-function slot-definition) - )) - -(defclass standard-method-combination - (documentation-mixin definition-source-mixin method-combination) - ((type :reader method-combination-type - :initarg :type) - (options :reader method-combination-options - :initarg :options))) - -(defmethod print-object ((mc method-combination) stream) - (printing-random-thing (mc stream) - (format stream - "Method-Combination ~S ~S" - (method-combination-type mc) - (method-combination-options mc)))) - -(eval-when (load eval) - (setq *standard-method-combination* - (make-instance 'standard-method-combination - :type 'standard - :documentation "The standard method combination." - :options ()))) - ;This definition appears in defcombin.lisp. ; ;(defmethod find-method-combination ((generic-function generic-function) @@ -299,45 +401,3 @@ ; "The method combination type STANDARD accepts no options.")) ; *standard-method-combination*) -(defun make-call-methods (methods) - (mapcar #'(lambda (method) `(call-method ,method ())) methods)) - -(defmethod compute-effective-method ((generic-function generic-function) - (combin standard-method-combination) - applicable-methods) - (let ((before ()) - (primary ()) - (after ()) - (around ())) - (dolist (m applicable-methods) - (let ((qualifiers (method-qualifiers m))) - (cond ((memq ':before qualifiers) (push m before)) - ((memq ':after qualifiers) (push m after)) - ((memq ':around qualifiers) (push m around)) - (t - (push m primary))))) - (setq before (reverse before) - after (reverse after) - primary (reverse primary) - around (reverse around)) - (cond ((null primary) - `(error "No primary method for the generic function ~S." ',generic-function)) - ((and (null before) (null after) (null around)) - ;; - ;; 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 - (if (or before after) - `(multiple-value-prog1 - (progn ,@(make-call-methods before) - (call-method ,(first primary) ,(rest primary))) - ,@(make-call-methods (reverse after))) - `(call-method ,(first primary) ,(rest primary))))) - (if around - `(call-method ,(first around) - (,@(rest around) (make-method ,main-effective-method))) - main-effective-method)))))) - diff --git a/pcl/construct.lisp b/pcl/construct.lisp index edbbc238a..197b7e9f1 100644 --- a/pcl/construct.lisp +++ b/pcl/construct.lisp @@ -229,8 +229,8 @@ (format stream "~S ~S (~S)" (or (class-name (class-of constructor)) "Constructor") - (or (constructor-name constructor) "Anonymous") - (constructor-code-type constructor)))) + (or (slot-value-or-default constructor 'name) "Anonymous") + (slot-value-or-default constructor 'code-type)))) (defmethod describe-object ((constructor constructor) stream) (format stream @@ -421,18 +421,21 @@ (wrapper (class-wrapper class)) (defaults (class-default-initargs class)) (make - (compute-applicable-methods #'make-instance (list class))) + (compute-applicable-methods (gdefinition 'make-instance) (list class))) (supplied-initarg-names (constructor-supplied-initarg-names constructor)) -; (default -; (compute-applicable-methods #'default-initargs -; (list class supplied-initarg-names))) ;? + (default + (compute-applicable-methods (gdefinition 'default-initargs) + (list class supplied-initarg-names))) ;? (allocate - (compute-applicable-methods #'allocate-instance (list class))) + (compute-applicable-methods (gdefinition 'allocate-instance) + (list class))) (initialize - (compute-applicable-methods #'initialize-instance (list proto))) + (compute-applicable-methods (gdefinition 'initialize-instance) + (list proto))) (shared - (compute-applicable-methods #'shared-initialize (list proto t))) + (compute-applicable-methods (gdefinition 'shared-initialize) + (list proto t))) (code-generators (constructor-code-generators constructor))) (flet ((call-code-generator (generator) @@ -441,12 +444,12 @@ (error "No FALLBACK generator?"))) (funcall generator class wrapper defaults initialize shared))) (if (or (cdr make) -; (cdr default) + (cdr default) (cdr allocate) - (check-initargs class - supplied-initarg-names - defaults - (append initialize shared))) + (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 @@ -465,10 +468,8 @@ ;;; (defun map-constructors (fn) - (declare (type real-function fn)) (let ((nclasses 0) (nconstructors 0)) - (declare (type index nclasses nconstructors)) (labels ((recurse (class) (incf nclasses) (dolist (constructor (class-constructors class)) @@ -535,36 +536,9 @@ (equal '(:after) (method-qualifiers m)))) methods)) - -;;; -;;; if initargs are valid return nil, otherwise return t. -;;; -(defun check-initargs (class supplied-initarg-names defaults methods) - (let ((legal (apply #'append - (mapcar #'slot-definition-initargs (class-slots class))))) - ;; Add to the set of slot-filling initargs the set of - ;; initargs that are accepted by the methods. If at - ;; any point we come across &allow-other-keys, we can - ;; just quit. - (dolist (method methods) - (multiple-value-bind (keys allow-other-keys) - (function-keywords method) - (when allow-other-keys - (return-from check-initargs nil)) - (setq legal (append keys legal)))) - ;; Now check the supplied-initarg-names and the default initargs - ;; against the total set that we know are legal. - (dolist (key supplied-initarg-names) - (unless (memq key legal) - (return-from check-initargs t))) - (dolist (default defaults) - (unless (memq (car default) legal) - (return-from check-initargs t))))) - - ;;; ;;; 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 first is a symbol +;;; 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: @@ -575,12 +549,11 @@ ;;; t there is at least one non-constant initform ;;; (defun compute-constant-vector (class) - (declare (values constants flag)) + ;;(declare (values constants flag)) (let* ((wrapper (class-wrapper class)) (layout (wrapper-instance-slots-layout wrapper)) (flag :unsupplied) (constants ())) - (declare (list layout)) (dolist (slotd (class-slots class)) (let ((name (slot-definition-name slotd)) (initform (slot-definition-initform slotd)) @@ -594,16 +567,11 @@ (t (push (cons name *slot-unbound*) constants) (setq flag 't))))) - (values - (apply #'vector - (mapcar #'cdr - (sort constants #'(lambda (x y) - (memq (car y) - (memq (car x) layout)))))) - flag))) - -(defmacro copy-constant-vector (constants) - `(copy-seq (the simple-vector ,constants))) + (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)))) ;;; @@ -627,7 +595,6 @@ (or (cdr (assq (slot-definition-name slotd) positions)) ':class))) (class-slots class)))) - (declare (list layout positions slot-initargs)) ;; Go through each of the initargs, and figure out what position ;; it fills by replacing the entries in slot-initargs it fills. (dolist (initarg initarg-names) @@ -680,8 +647,7 @@ (class name arglist supplied-initarg-names supplied-initargs) (declare (ignore name)) (let ((raw-allocator (raw-instance-allocator class)) - (slots-fetcher (slots-fetcher class)) - (wrapper-fetcher (wrapper-fetcher class))) + (slots-fetcher (slots-fetcher class))) `(function (lambda (class .wrapper. defaults init shared) (multiple-value-bind (.constants. @@ -705,15 +671,12 @@ (function (lambda ,arglist (declare #.*optimize-speed*) - (let ((.instance. (,raw-allocator)) - (.slots. (copy-constant-vector .constants.)) - (.positions. .supplied-initarg-positions.) - (.initargs. .constant-initargs.)) + (let* ((.instance. (,raw-allocator .wrapper. .constants.)) + (.slots. (,slots-fetcher .instance.)) + (.positions. .supplied-initarg-positions.) + (.initargs. .constant-initargs.)) .positions. - (setf (,slots-fetcher .instance.) .slots.) - (setf (,wrapper-fetcher .instance.) .wrapper.) - (dolist (entry .initfns-initargs-and-positions.) (let ((val (funcall (car entry))) (initarg (cadr entry))) @@ -721,7 +684,7 @@ (push val .initargs.) (push initarg .initargs.)) (dolist (pos (cddr entry)) - (setf (%svref .slots. pos) val)))) + (setf (%instance-ref .slots. pos) val)))) ,@(gathering1 (collecting) (doplist (initarg value) supplied-initargs @@ -730,7 +693,7 @@ (push .value. .initargs.) (push ',initarg .initargs.) (dolist (.p. (pop .positions.)) - (setf (%svref .slots. .p.) + (setf (%instance-ref .slots. .p.) .value.))))))) (dolist (fn .shared-initfns.) @@ -753,7 +716,6 @@ (supplied-initarg-positions ()) (constant-initargs ()) (used-positions ())) - (declare (list layout)) ;; ;; Go through each of the supplied initargs for three reasons. @@ -852,8 +814,7 @@ (class name arglist supplied-initarg-names supplied-initargs) (declare (ignore name)) (let ((raw-allocator (raw-instance-allocator class)) - (slots-fetcher (slots-fetcher class)) - (wrapper-fetcher (wrapper-fetcher class))) + (slots-fetcher (slots-fetcher class))) `(function (lambda (class .wrapper. defaults init shared) (multiple-value-bind (.constants. @@ -870,17 +831,15 @@ (null (non-pcl-shared-initialize-methods-p shared))) #'(lambda ,arglist (declare #.*optimize-speed*) - (let ((.instance. (,raw-allocator)) - (.slots. (copy-constant-vector .constants.)) - (.positions. .supplied-initarg-positions.)) + (let* ((.instance. (,raw-allocator .wrapper. .constants.)) + (.slots. (,slots-fetcher .instance.)) + (.positions. .supplied-initarg-positions.)) .positions. - (setf (,slots-fetcher .instance.) .slots.) - (setf (,wrapper-fetcher .instance.) .wrapper.) (dolist (entry .initfns-and-positions.) (let ((val (funcall (car entry)))) (dolist (pos (cdr entry)) - (setf (%svref .slots. pos) val)))) + (setf (%instance-ref .slots. pos) val)))) ,@(gathering1 (collecting) (doplist (initarg value) supplied-initargs @@ -888,7 +847,7 @@ (gather1 `(let ((.value. ,value)) (dolist (.p. (pop .positions.)) - (setf (%svref .slots. .p.) .value.))))))) + (setf (%instance-ref .slots. .p.) .value.))))))) .instance.)))))))) @@ -904,7 +863,6 @@ (initfns-and-positions ()) (supplied-initarg-positions ()) (used-positions ())) - (declare (list layout)) ;; ;; Go through each of the supplied initargs for three reasons. ;; @@ -993,8 +951,7 @@ (class name arglist supplied-initarg-names supplied-initargs) (declare (ignore name)) (let ((raw-allocator (raw-instance-allocator class)) - (slots-fetcher (slots-fetcher class)) - (wrapper-fetcher (wrapper-fetcher class))) + (slots-fetcher (slots-fetcher class))) `(function (lambda (class .wrapper. defaults init shared) (when (and (null (non-pcl-initialize-instance-methods-p init)) @@ -1008,13 +965,10 @@ (function (lambda ,arglist (declare #.*optimize-speed*) - (let ((.instance. (,raw-allocator)) - (.slots. (copy-constant-vector .constants.)) - (.positions. .supplied-initarg-positions.)) - + (let* ((.instance. (,raw-allocator .wrapper. .constants.)) + (.slots. (,slots-fetcher .instance.)) + (.positions. .supplied-initarg-positions.)) .positions. - (setf (,slots-fetcher .instance.) .slots.) - (setf (,wrapper-fetcher .instance.) .wrapper.) ,@(gathering1 (collecting) (doplist (initarg value) supplied-initargs @@ -1022,7 +976,7 @@ (gather1 `(let ((.value. ,value)) (dolist (.p. (pop .positions.)) - (setf (%svref .slots. .p.) .value.))))))) + (setf (%instance-ref .slots. .p.) .value.))))))) .instance.)))))))))) @@ -1037,7 +991,6 @@ (mapcar #'car defaults)))) (supplied-initarg-positions ()) (used-positions ())) - (declare (list layout)) ;; ;; Go through each of the supplied initargs for three reasons. ;; diff --git a/pcl/cpatch.lisp b/pcl/cpatch.lisp index 0cde7bfcf..23641de54 100644 --- a/pcl/cpatch.lisp +++ b/pcl/cpatch.lisp @@ -5,11 +5,6 @@ ;; copyright (c) 1990 Franz Inc. ;; -#+pcl-user-instances -(eval-when (compile load eval) -(error "Cannot use user-instances in EXCL on Sun4 with cpatch.lisp and - quadlap.lisp optimizations (see low.lisp).") -) (in-package :comp) (def-quad-op tail-funcall qp-end-block diff --git a/pcl/cpl.lisp b/pcl/cpl.lisp index 6947fca9a..ff05e951e 100644 --- a/pcl/cpl.lisp +++ b/pcl/cpl.lisp @@ -95,7 +95,7 @@ (cpd-class nil) (cpd-supers ()) (cpd-after ()) - (cpd-count 0 :type fixnum)) + (cpd-count 0)) (defun compute-std-cpl (class supers) (cond ((null supers) ;First two branches of COND @@ -112,13 +112,12 @@ (defvar *compute-std-cpl-class->entry-table-size* 60) -(declaim (ftype (function (T T) (values list index)) compute-std-cpl-phase-1)) (defun compute-std-cpl-phase-1 (class supers) (let ((nclasses 0) (all-cpds ()) (table (make-hash-table :size *compute-std-cpl-class->entry-table-size* :test #'eq))) - (declare (type index nclasses)) + (declare (fixnum nclasses)) (labels ((get-cpd (c) (or (gethash c table) (setf (gethash c table) (make-cpd)))) @@ -150,7 +149,6 @@ (push (car t2) (cpd-after (car t1)))))))) (defun compute-std-cpl-phase-3 (class all-cpds nclasses) - (declare (type index nclasses)) (let ((candidates ()) (next-cpd nil) (rcpl ())) @@ -197,7 +195,7 @@ (decf nclasses) (push (cpd-class next-cpd) rcpl) (dolist (after (cpd-after next-cpd)) - (when (zerop (the fixnum (decf (cpd-count after)))) + (when (zerop (decf (cpd-count after))) (push after candidates)))))) ;;; diff --git a/pcl/defclass.lisp b/pcl/defclass.lisp index aee35dec1..e5ded1bda 100644 --- a/pcl/defclass.lisp +++ b/pcl/defclass.lisp @@ -159,32 +159,32 @@ (*readers* ()) ;to have it to live nicely. (*writers* ())) (declare (special *initfunctions* *accessors* *readers* *writers*)) - (let* ((canonical-slots - (mapcar #'(lambda (spec) - (canonicalize-slot-specification name spec)) - slots)) - (other-initargs - (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*)))))) + (let ((canonical-slots + (mapcar #'(lambda (spec) + (canonicalize-slot-specification name spec)) + slots)) + (other-initargs + (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*)))))) (do-standard-defsetfs-for-defclass *accessors*) (let ((defclass-form (make-top-level-form `(defclass ,name) - *defclass-times* + (if defstruct-p '(load eval) *defclass-times*) `(progn ,@(mapcar #'(lambda (x) - `(proclaim-defgeneric ',x '(self))) - *readers*) + `(declaim (ftype (function (t) t) ,x))) + #+cmu *readers* #-cmu nil) ,@(mapcar #'(lambda (x) #-setf (when (consp x) (setq x (get-setf-function-name (cadr x)))) - `(proclaim-defgeneric ',x '(new self))) - *writers*) + `(declaim (ftype (function (t t) t) ,x))) + #+cmu *writers* #-cmu nil) (let ,(mapcar #'cdr *initfunctions*) (load-defclass ',name ',metaclass @@ -195,10 +195,17 @@ '(:from-defclass-p t)) other-initargs)) ',*accessors*)))))) - defclass-form))))) - -(defun float-zero () - 0.0) + (if defstruct-p + (progn + (eval defclass-form) ; define the class now, so that + `(progn ; the defstruct can be compiled. + ,(class-defstruct-form (find-class name)) + ,defclass-form)) + (progn + (when (and (eq *boot-state* 'complete) + (not (member 'compile *defclass-times*))) + (inform-type-system-about-std-class name)) + defclass-form))))))) (defun make-initfunction (initform) (declare (special *initfunctions*)) @@ -211,17 +218,12 @@ ((or (eql initform '0) (equal initform ''0)) '(function zero)) - ((or (eql initform '0.0) - (equal initform ''0.0)) - '(function float-zero)) (t (let ((entry (assoc initform *initfunctions* :test #'equal))) (unless entry - (setq entry - (list initform - (gensym) - `(slot-initfunction-storage-form - (function (lambda () ,initform))))) + (setq entry (list initform + (gensym) + `(function (lambda () ,initform)))) (push entry *initfunctions*)) (cadr entry))))) @@ -267,10 +269,8 @@ ',spec)) (if (eq initform unsupplied) `(list* ,@spec) - `(list* :initfunction ,(make-initfunction initform) - :initfunction-side-effect-free-p ,(simple-eval-access-p initform) - ,@spec)))))) - + `(list* :initfunction ,(make-initfunction initform) ,@spec)))))) + (defun canonicalize-defclass-option (class-name option) (declare (ignore class-name)) (case (car option) @@ -282,8 +282,6 @@ val (pop tail)) (push ``(,',key ,,(make-initfunction val) ,',val) canonical)) `(':direct-default-initargs (list ,@(nreverse canonical)))))) - (:documentation - `(:documentation ',(cadr option))) (otherwise `(',(car option) ',(cdr option))))) @@ -299,9 +297,12 @@ ;;; Each entry in *early-class-definitions* is an early-class-definition. ;;; ;;; -(declaim (type list *early-class-definitions*)) (defparameter *early-class-definitions* ()) +(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))) + (defun make-early-class-definition (name source metaclass superclass-names canonical-slots other-initargs) @@ -316,6 +317,125 @@ (defun ecd-canonical-slots (ecd) (nth 5 ecd)) (defun ecd-other-initargs (ecd) (nth 6 ecd)) +(defvar *early-class-slots* nil) + +(defun canonical-slot-name (canonical-slot) + (getf canonical-slot :name)) + +(defun early-class-slots (class-name) + (cdr (or (assoc class-name *early-class-slots*) + (let ((a (cons class-name + (mapcar #'canonical-slot-name + (early-collect-inheritance class-name))))) + (push a *early-class-slots*) + a)))) + +(defun early-class-size (class-name) + (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 + (early-collect-default-initargs cpl) + (gathering1 (collecting) + (dolist (definition *early-class-definitions*) + (when (memq class-name (ecd-superclass-names definition)) + (gather1 (ecd-class-name definition)))))))) + +(defun early-collect-slots (cpl) + (let* ((definitions (mapcar #'early-class-definition cpl)) + (super-slots (mapcar #'ecd-canonical-slots definitions)) + (slots (apply #'append (reverse super-slots)))) + (dolist (s1 slots) + (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." + name1))))) + slots)) + +(defun early-collect-cpl (class-name) + (labels ((walk (c) + (let* ((definition (early-class-definition c)) + (supers (ecd-superclass-names definition))) + (cons c + (apply #'append (mapcar #'early-collect-cpl supers)))))) + (remove-duplicates (walk class-name) :from-end nil :test #'eq))) + +(defun early-collect-default-initargs (cpl) + (let ((default-initargs ())) + (dolist (class-name cpl) + (let* ((definition (early-class-definition class-name)) + (others (ecd-other-initargs definition))) + (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." + initarg))) + (setq default-initargs + (nconc default-initargs (reverse (pop others))))))) + (reverse default-initargs))) + +(defun bootstrap-slot-index (class-name slot-name) + (or (position slot-name (early-class-slots class-name)) + (error "~S not found" slot-name))) + +;;; +;;; bootstrap-get-slot and bootstrap-set-slot are used to access and change +;;; the values of slots during bootstrapping. During bootstrapping, there +;;; are only two kinds of objects whose slots we need to access, CLASSes +;;; and SLOT-DEFINITIONs. The first argument to these functions tells whether the +;;; object is a CLASS or a SLOT-DEFINITION. +;;; +;;; Note that the way this works it stores the slot in the same place in +;;; memory that the full object system will expect to find it later. This +;;; is critical to the bootstrapping process, the whole changeover to the +;;; full object system is predicated on this. +;;; +;;; One important point is that the layout of standard classes and standard +;;; slots must be computed the same way in this file as it is by the full +;;; object system later. +;;; +(defmacro bootstrap-get-slot (type object slot-name) + `(instance-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)) + +(defun early-class-name (class) + (bootstrap-get-slot 'class class 'name)) + +(defun early-class-precedence-list (class) + (bootstrap-get-slot 'pcl-class class 'class-precedence-list)) + +(defun early-class-name-of (instance) + (early-class-name (class-of instance))) + +(defun early-class-slotds (class) + (bootstrap-get-slot 'slot-class class 'slots)) + +(defun early-slot-definition-name (slotd) + (bootstrap-get-slot 'standard-effective-slot-definition slotd 'name)) + +(defun early-slot-definition-location (slotd) + (bootstrap-get-slot 'standard-effective-slot-definition slotd 'location)) + +(defun early-accessor-method-slot-name (method) + (bootstrap-get-slot 'standard-accessor-method method 'slot-name)) + +(unless (fboundp 'class-name-of) + (setf (symbol-function 'class-name-of) + (symbol-function 'early-class-name-of))) + +(defun early-class-direct-subclasses (class) + (bootstrap-get-slot 'class class 'direct-subclasses)) + (proclaim '(notinline load-defclass)) (defun load-defclass (name metaclass supers canonical-slots canonical-options accessor-names) @@ -331,241 +451,10 @@ metaclass supers canonical-slots - (apply #'append canonical-options))) + canonical-options)) (existing (find name *early-class-definitions* :key #'ecd-class-name))) (setq *early-class-definitions* (cons ecd (remove existing *early-class-definitions*))) ecd)) -;;; -;;; FIND-CLASS -;;; -;;; This is documented in the CLOS specification. -;;; -(defvar *find-class* (make-hash-table :test #'eq)) - -(defmacro find-class-cell-class (cell) - `(car ,cell)) - -(defmacro find-class-cell-predicate (cell) - `(cdr ,cell)) - -(defun find-class-cell (symbol &optional dont-create-p) - (or (gethash symbol *find-class*) - (unless dont-create-p - (unless (legal-class-name-p symbol) - (error "~S is not a legal class name." symbol)) - (setf (gethash symbol *find-class*) (make-find-class-cell symbol))))) - -(defun found-unknown-class (symbol errorp) - (cond ((null errorp) nil) - ((legal-class-name-p symbol) - (error "No class named: ~S." symbol)) - (t - (error "~S is not a legal class name." symbol)))) - -(defmacro find-class-from-cell (symbol cell &optional (errorp t)) - `(or (find-class-cell-class ,cell) - (if (known-structure-type-p ,symbol) - (find-structure-class ,symbol) - #+structure-functions - (found-unknown-class ,symbol ,errorp) - #-structure-functions - (find-maybe-structure-class ,symbol ,errorp)))) - -#-structure-functions -(defun likely-to-name-structure-p (symbol) - ;; Returns whether Symbol is likely to name an already-defined - ;; structure by whether it can find the default make or predicate - ;; functions that would have been created by Defstruct. This - ;; obviously may fail. - (let ((name (symbol-name symbol))) - (declare (type simple-string name)) - (and (fboundp (intern (concatenate 'simple-string "MAKE-" name) - (symbol-package symbol))) - (fboundp (intern (concatenate 'simple-string name "-P") - (symbol-package symbol)))))) - -#-structure-functions -(defun find-maybe-structure-class (symbol errorp) - (if symbol - (multiple-value-bind (structurep surep) - (safe-subtypep symbol 'structure) - (declare (type boolean structurep surep)) - (if structurep - (find-structure-class symbol :warn T) - (if surep - (found-unknown-class symbol errorp) - (if (likely-to-name-structure-p symbol) - (find-structure-class symbol :warn T) - (found-unknown-class symbol errorp))))) - (found-unknown-class symbol errorp))) - -(defun find-class-predicate-from-cell (symbol cell &optional (errorp t)) - (unless (find-class-cell-class cell) - (find-class-from-cell symbol cell errorp)) - (find-class-cell-predicate cell)) - -(defun legal-class-name-p (x) - (and (symbolp x) - (not (keywordp x)))) - -(defun find-class (symbol &optional (errorp t) environment) - (declare (ignore environment)) - (find-class-from-cell symbol (gethash symbol *find-class*) errorp)) - -(defun find-class-predicate (symbol &optional (errorp t) environment) - (declare (ignore environment)) - (find-class-predicate-from-cell symbol (find-class-cell symbol errorp) errorp)) - -#-setf -(defsetf find-class (symbol &optional (errorp t) environment) (new-value) - (declare (ignore errorp environment)) - `(SETF\ PCL\ FIND-CLASS ,new-value ,symbol)) - -(defun #-setf SETF\ PCL\ FIND-CLASS #+setf (setf find-class) (new-value symbol) - (if (legal-class-name-p symbol) - (setf (find-class-cell-class (find-class-cell symbol)) new-value) - (error "~S is not a legal class name." symbol))) - -#-setf -(defsetf find-class-predicate (symbol &optional (errorp t) environment) (new-value) - (declare (ignore errorp environment)) - `(SETF\ PCL\ FIND-CLASS-PREDICATE ,new-value ,symbol)) - -(defun #-setf SETF\ PCL\ FIND-CLASS-PREDICATE #+setf (setf find-class-predicate) - (new-value symbol) - (if (legal-class-name-p symbol) - (setf (find-class-cell-predicate (find-class-cell symbol)) new-value) - (error "~S is not a legal class name." symbol))) - -(defun make-find-class-cell (class-name) - (cons nil - #'(lambda (x) - (let* ((class (find-class class-name)) - (class-predicate (make-class-predicate class))) - (declare (type compiled-function class-predicate)) - (setf (find-class-predicate class-name) class-predicate) - (funcall class-predicate x))))) - -(defun find-wrapper (symbol) - (class-wrapper (find-class symbol))) - - - - -(declaim (ftype (function (T) - (values index index boolean boolean boolean list list)) - analyze-lambda-list)) -(defun analyze-lambda-list (lambda-list) - (declare (values nrequired noptional keysp restp allow-other-keys-p - keywords keyword-parameters)) - (flet ((parse-keyword-argument (arg) - (if (listp arg) - (if (listp (car arg)) - (caar arg) - (make-keyword (car arg))) - (make-keyword arg)))) - (let ((nrequired 0) - (noptional 0) - (keysp nil) - (restp nil) - (allow-other-keys-p nil) - (keywords ()) - (keyword-parameters ()) - (state 'required)) - (declare (type index nrequired noptional) - (type boolean keysp restp allow-other-keys-p) - (type list keywords keyword-parameters)) - (dolist (x lambda-list) - (if (memq x lambda-list-keywords) - (case x - (&optional (setq state 'optional)) - (&key (setq keysp 't - state 'key)) - (&allow-other-keys (setq allow-other-keys-p 't)) - (&rest (setq restp 't - state 'rest)) - (&aux (return t)) - (otherwise - (error "Encountered the non-standard lambda list keyword ~S." x))) - (ecase state - (required (incf nrequired)) - (optional (incf noptional)) - (key (push (parse-keyword-argument x) keywords) - (push x keyword-parameters)) - (rest ())))) - (values nrequired noptional keysp restp allow-other-keys-p - (reverse keywords) - (reverse keyword-parameters))))) - -(defun keyword-spec-name (x) - (let ((key (if (atom x) x (car x)))) - (if (atom key) - (intern (symbol-name key) (find-package "KEYWORD")) - (car key)))) - -(defun ftype-declaration-from-lambda-list (lambda-list #+cmu name) - (multiple-value-bind (nrequired noptional keysp restp allow-other-keys-p - keys keyword-parameters) - (analyze-lambda-list lambda-list) - (declare (type index nrequired noptional) - (type boolean keysp restp #+cmu allow-other-keys-p) - (type list keys)) - (declare (ignore keyword-parameters #-cmu allow-other-keys-p)) - (let* (#+cmu (old (c::info function type name)) - #+cmu (old-ftype (if (c::function-type-p old) old nil)) - #+cmu (old-restp (and old-ftype (c::function-type-rest old-ftype))) - #+cmu (old-keys (and old-ftype - (mapcar #'c::key-info-name - (c::function-type-keywords old-ftype)))) - #+cmu (old-keysp (and old-ftype (c::function-type-keyp old-ftype))) - #+cmu (old-allowp (and old-ftype (c::function-type-allowp old-ftype))) - (keywords #+cmu (union old-keys (mapcar #'keyword-spec-name keys)) - #-cmu (mapcar #'keyword-spec-name keys))) - (declare (type list keywords)) - `(function ,(append (make-list nrequired :initial-element 't) - (when (plusp noptional) - (append '(&optional) - (make-list noptional :initial-element 't))) - (when (or restp #+cmu old-restp) - '(&rest t)) - (when (or keysp #+cmu old-keysp) - #+cmu - (append '(&key) - (mapcar #'(lambda (key) - `(,key t)) - keywords) - (when (or allow-other-keys-p #+cmu old-allowp) - '(&allow-other-keys))) - #-cmu - (append '(&key) - (make-list (length keywords) - :initial-element T)))) - #-(or cmu kcl) T - #+(or cmu kcl) *)))) - -(defun proclaim-function (name lambda-list - &optional (return-type #+(or cmu kcl) '* - #-(or cmu kcl) T)) - (unless (function-ftype-declaimed-p name) - (eval `(declaim (ftype (function - ,(mapcar #'(lambda (param) - (if (memq param lambda-list-keywords) - param - T)) - lambda-list) - ,return-type) - ,name))) - #+kcl (setf (get name 'compiler::proclaimed-closure) t))) - -(defun proclaim-defgeneric (spec lambda-list) - (when (consp spec) - (setq spec (get-setf-function-name (cadr spec)))) - (unless (function-ftype-declaimed-p spec) - (eval - `(declaim (ftype ,(ftype-declaration-from-lambda-list lambda-list #+cmu spec) - ,spec))) - #+kcl (setf (get spec 'compiler::proclaimed-closure) t))) - diff --git a/pcl/defcombin.lisp b/pcl/defcombin.lisp index 2e60df97e..7d1434526 100644 --- a/pcl/defcombin.lisp +++ b/pcl/defcombin.lisp @@ -107,19 +107,10 @@ :qualifiers () :specializers specializers :lambda-list '(generic-function type options) - :function - #'(lambda (args next-methods) - (declare (ignore next-methods)) - (apply #'(lambda (gf type options) - (declare (ignore gf)) - (do-short-method-combination - type options operator ioa new-method doc)) - args)) - :optimized-function - #'(lambda (gf type options) - (declare (ignore gf)) - (do-short-method-combination - type options operator ioa new-method doc)) + :function #'(lambda (gf type options) + (declare (ignore gf)) + (do-short-method-combination + type options operator ioa new-method doc)) :definition-source `((define-method-combination ,type) ,truename))) (when old-method (remove-method #'find-method-combination old-method)) @@ -231,23 +222,12 @@ :qualifiers () :specializers specializers :lambda-list '(generic-function type options) - :function - #'(lambda (args next-methods) - (declare (ignore next-methods)) - (apply #'(lambda (generic-function type options) - (declare (ignore generic-function)) - (make-instance 'long-method-combination - :type type - :documentation doc - :options options)) - args)) - :optimized-function - #'(lambda (generic-function type options) - (declare (ignore generic-function)) - (make-instance 'long-method-combination - :type type - :documentation doc - :options options)) + :function #'(lambda (generic-function type options) + (declare (ignore generic-function)) + (make-instance 'long-method-combination + :type type + :documentation doc + :options options)) :definition-source `((define-method-combination ,type) ,(load-truename))))) (setf (gethash type *long-method-combination-functions*) function) @@ -257,18 +237,18 @@ (defmethod compute-effective-method ((generic-function generic-function) (combin long-method-combination) applicable-methods) - (method-function-funcall (gethash (method-combination-type combin) - *long-method-combination-functions*) - generic-function - combin - applicable-methods)) + (funcall (gethash (method-combination-type combin) + *long-method-combination-functions*) + generic-function + combin + applicable-methods)) ;;; ;;; ;;; (defun make-long-method-combination-function (type ll method-group-specifiers arguments-option gf-var body) - (declare (values documentation function)) + ;;(declare (values documentation function)) (declare (ignore type)) (multiple-value-bind (documentation declarations real-body) (extract-declarations body) @@ -350,7 +330,7 @@ ,@real-body))) (defun parse-method-group-specifier (method-group-specifier) - (declare (values name tests description order required)) + ;;(declare (values name tests description order required)) (let* ((name (pop method-group-specifier)) (patterns ()) (tests diff --git a/pcl/defs.lisp b/pcl/defs.lisp index 692acdfee..d5489f1b9 100644 --- a/pcl/defs.lisp +++ b/pcl/defs.lisp @@ -38,6 +38,8 @@ ;EARLY ;BRAID ;COMPLETE +(defvar *fegf-started-p* nil) + ) @@ -99,7 +101,15 @@ (symbol-function symbol)) #+xerox (il:virginfn symbol) #+setf (fdefinition symbol) - #-(or Lispm Lucid excl Xerox setf) (symbol-function symbol)) + #+kcl (symbol-function + (let ((sym (get symbol 'si::traced)) first-form) + (if (and sym + (consp (symbol-function symbol)) + (consp (setq first-form (nth 3 (symbol-function symbol)))) + (eq (car first-form) 'si::trace-call)) + sym + symbol))) + #-(or Lispm Lucid excl Xerox setf kcl) (symbol-function symbol)) ;;; ;;; If symbol names a function which is traced or advised, redefine @@ -121,7 +131,16 @@ (when brokenp (xcl:rebreak-function symbol)) (when advisedp (xcl:readvise-function symbol))) #+setf (setf (fdefinition symbol) new-definition) - #-(or Lispm Lucid excl Xerox setf) + #+kcl (setf (symbol-function + (let ((sym (get symbol 'si::traced)) first-form) + (if (and sym + (consp (symbol-function symbol)) + (consp (setq first-form (nth 3 (symbol-function symbol)))) + (eq (car first-form) 'si::trace-call)) + sym + symbol))) + new-definition) + #-(or Lispm Lucid excl Xerox setf kcl) (setf (symbol-function symbol) new-definition) new-definition) @@ -147,9 +166,9 @@ (name (fdefine-carefully name new-value)) (name (fdefine-carefully (get-setf-function-name name) new-value)))) - + (proclaim '(special *the-class-t* - *the-class-vector* *the-class-symbol* + *the-class-vector* *the-class-symbol* *the-class-string* *the-class-sequence* *the-class-rational* *the-class-ratio* *the-class-number* *the-class-null* *the-class-list* @@ -161,17 +180,22 @@ *the-class-standard-object* *the-class-structure-object* *the-class-class* - *the-class-method* *the-class-generic-function* *the-class-built-in-class* *the-class-slot-class* *the-class-structure-class* *the-class-standard-class* *the-class-funcallable-standard-class* + *the-class-method* *the-class-standard-method* + *the-class-standard-reader-method* + *the-class-standard-writer-method* + *the-class-standard-boundp-method* *the-class-standard-generic-function* - *the-class-standard-direct-slot-definition* - *the-class-standard-effective-slot-definition*)) + *the-class-standard-effective-slot-definition* + + *the-eslotd-standard-class-slots* + *the-eslotd-funcallable-standard-class-slots*)) (proclaim '(special *the-wrapper-of-t* *the-wrapper-of-vector* *the-wrapper-of-symbol* @@ -184,7 +208,6 @@ *the-wrapper-of-bit-vector* *the-wrapper-of-array*)) (defun coerce-to-class (class &optional make-forward-referenced-class-p) - (declare (type boolean make-forward-referenced-class-p)) (if (symbolp class) (or (find-class class (not make-forward-referenced-class-p)) (ensure-class class)) @@ -197,19 +220,26 @@ (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)))))) ((specializerp type) type))) (defun type-from-specializer (specl) - (when (symbolp specl) - (setq specl (find-class specl))) ;(or (find-class specl nil) (ensure-class specl)) - (cond ((consp specl) - (unless (memq (car specl) '(class class-eq eql)) + (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)) specl) - ((specializerp specl) - (specializer-type specl)) + ((progn + (when (symbolp specl) + ;;maybe (or (find-class specl nil) (ensure-class specl)) instead? + (setq specl (find-class specl))) + (or (not (eq *boot-state* 'complete)) + (specializerp specl))) + (specializer-type specl)) (t (error "~s is neither a type nor a specializer" specl)))) @@ -217,9 +247,12 @@ (declare (special *the-class-t*)) (setq type (type-from-specializer type)) (if (atom type) - *the-class-t* + (if (eq type 't) + *the-class-t* + (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))))) @@ -234,7 +267,7 @@ (defun make-type-predicate (name) (let ((cell (find-class-cell name))) #'(lambda (x) - (funcall (the compiled-function (find-class-cell-predicate cell)) x)))) + (funcall (the function (find-class-cell-predicate cell)) x)))) ;This stuff isn't right. Good thing it isn't used. @@ -261,9 +294,12 @@ `(satisfies ,(make-class-eq-predicate class))) ||# +#-excl (deftype eql (type-object) `(member ,type-object)) + + ;;; ;;; These functions are a pale imitiation of their namesake. They accept ;;; class objects or types where they should. @@ -281,8 +317,9 @@ (let ((type (specializer-type class))) (if (listp type) type `(,type))) `(,type)))) - ((specializerp type) - (specializer-type type)) + ((or (not (eq *boot-state* 'complete)) + (specializerp type)) + (specializer-type type)) (t (error "~s is not a type" type)))) @@ -310,28 +347,31 @@ (car type) type)))) -(declaim (ftype (function (T T) boolean) *typep)) (defun *typep (object type) (setq type (*normalize-type type)) - (cond ((memq (car type) '(eql wrapper-eq class-eq class)) + (cond ((member (car type) '(eql wrapper-eq class-eq class)) (specializer-applicable-using-type-p type `(eql ,object))) ((eq (car type) 'not) (not (*typep object (cadr type)))) (t (typep object (convert-to-system-type type))))) -#-kcl -(declaim (ftype (function (T T) (values boolean boolean)) *subtypep)) (defun *subtypep (type1 type2) - (setq type1 (*normalize-type type1)) - (setq type2 (*normalize-type type2)) - (if (member (car type2) '(eql wrapper-eq class-eq class)) - (multiple-value-bind (app-p maybe-app-p) - (specializer-applicable-using-type-p type2 type1) - (declare (type boolean app-p maybe-app-p)) - (values app-p (or app-p (not maybe-app-p)))) - (subtypep (convert-to-system-type type1) - (convert-to-system-type type2)))) + (if (equal type1 type2) + (values t t) + (if (eq *boot-state* 'early) + (values (eq type1 type2) t) + (let ((*in-precompute-effective-methods-p* t)) ; not a descriptive name + (declare (special *in-precompute-effective-methods-p*)) + ;; This changes the way class-applicable-using-class-p works. + (setq type1 (*normalize-type type1)) + (setq type2 (*normalize-type type2)) + (if (member (car type2) '(eql wrapper-eq class-eq class)) + (multiple-value-bind (app-p maybe-app-p) + (specializer-applicable-using-type-p type2 type1) + (values app-p (or app-p (not maybe-app-p)))) + (subtypep (convert-to-system-type type1) + (convert-to-system-type type2))))))) (defun do-satisfies-deftype (name predicate) #+(or :Genera (and :Lucid (not :Prime)) ExCL :coral) @@ -358,7 +398,6 @@ (eval `(deftype ,name () '(satisfies ,predicate)))) (defun make-type-predicate-name (name &optional kind) - (when (null name) (error "This shouldn't happen.")) (if (symbol-package name) (intern (format nil "~@[~A ~]TYPE-PREDICATE ~A ~A" @@ -371,7 +410,6 @@ kind (symbol-name name))))) - (defvar *built-in-class-symbols* ()) @@ -404,7 +442,7 @@ (defun variable-class (var env) (caddr (variable-declaration 'class var env))) - +(defvar *name->class->slotd-table* (make-hash-table)) ;;; @@ -436,59 +474,62 @@ classes))) (defun make-class-predicate-name (name) - (intern (format nil "~A class predicate" (symbol-name name)) - (symbol-package name))) + (intern (format nil "~A::~A class predicate" + (package-name (symbol-package name)) + name) + *the-pcl-package*)) -(defun plist-value (object name &optional default) - (getf (object-plist object) name default)) +(defun plist-value (object name) + (getf (object-plist object) name)) (defun #-setf SETF\ PCL\ PLIST-VALUE #+setf (setf plist-value) (new-value object name) - (setf (getf (object-plist object) name) new-value)) + (if new-value + (setf (getf (object-plist object) name) new-value) + (progn + (remf (object-plist object) name) + nil))) (defvar *built-in-classes* ;; ;; name supers subs cdr of cpl - ;; prototype predicate-name + ;; prototype '(;(t () (number sequence array character symbol) ()) - (number (t) (complex float rational) (t) - 1 numberp) + (number (t) (complex float rational) (t)) (complex (number) () (number t) - #c(1 1) complexp) + #c(1 1)) (float (number) () (number t) - 1.0 floatp) - (rational (number) (integer ratio) (number t) - 1 rationalp) + 1.0) + (rational (number) (integer ratio) (number t)) (integer (rational) () (rational number t) - 1 integerp) + 1) (ratio (rational) () (rational number t) 1/2) - (sequence (t) (list vector) (t) - nil sequencep) - (list (sequence) (cons null) (sequence t) - () listp) + (sequence (t) (list vector) (t)) + (list (sequence) (cons null) (sequence t)) (cons (list) () (list sequence t) - (nil) consp) + (nil)) (array (t) (vector) (t) - #2A((NIL)) arrayp) + #2A((NIL))) (vector (array sequence) (string bit-vector) (array sequence t) - #() vectorp) + #()) (string (vector) () (vector array sequence t) - "" stringp) + "") (bit-vector (vector) () (vector array sequence t) - #*1 bit-vector-p) + #*1) (character (t) () (t) - #\c characterp) + #\c) (symbol (t) (null) (t) - symbol symbolp) - (null (symbol) () (symbol list sequence t) - nil null))) + symbol) + (null (symbol + list) () (symbol list sequence t) + nil))) ;;; @@ -526,95 +567,75 @@ :initform () :accessor object-plist))) -(defclass documentation-mixin () - ((documentation - :initform NIL - :initarg :documentation))) +(defclass documentation-mixin (plist-mixin) + ()) (defclass dependent-update-mixin (plist-mixin) ()) ;;; ;;; The class CLASS is a specified basic class. It is the common superclass -;;; of any kind of class. It holds all of the documented reader functions from -;;; the AMOP. Any class that can be a metaclass must have the class CLASS -;;; in its class precedence list. +;;; 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) - ((default-initargs - :reader class-default-initargs) - (direct-default-initargs - :initform nil - :reader class-direct-default-initargs) - (direct-slots - :initform nil - :reader class-direct-slots) - (direct-subclasses +(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-direct-subclasses) + :reader class-eq-specializer) (direct-superclasses - :initform nil + :initform () :reader class-direct-superclasses) - (finalized-p + (direct-subclasses + :initform () + :reader class-direct-subclasses) + (direct-methods + :initform (cons nil nil)) + (predicate-name :initform nil - :reader class-finalized-p) - (name - :initform nil - :initarg :name - :reader class-name) - (class-precedence-list - :reader class-precedence-list) - (prototype - :reader class-prototype) - (slots - :reader class-slots))) - + :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) - ((cached-in-generic-functions - :initform () - :reader class-cached-in-generic-functions) + ((class-precedence-list + :reader class-precedence-list) (can-precede-list :initform () :reader class-can-precede-list) - (class-eq-specializer - :initform nil - :reader class-eq-specializer) - (direct-methods - :initform (cons nil nil)) (incompatible-superclass-list :initform () :accessor class-incompatible-superclass-list) - (internal-slotds - :reader class-internal-slotds - :documentation - "List of internal-slotd structure copies of class-slots (for optimization).") (wrapper :initform nil :reader class-wrapper) - (predicate-name - :initform nil - :reader class-predicate-name)) - ) + (prototype + :initform nil + :reader class-prototype))) (defclass slot-class (pcl-class) - ((side-effect-internal-slotds - :reader class-side-effect-internal-slotds - :documentation - "List of internal-slotd structure copies of class-slots whose initfunctions - may have side-effects (for optimization)."))) + ((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 standard-class (std-class) ()) @@ -627,17 +648,16 @@ (defclass built-in-class (pcl-class) ()) (defclass structure-class (slot-class) - ((defstruct-conc-name - :initform nil - :reader class-defstruct-conc-name) + ((defstruct-form + :initform () + :accessor class-defstruct-form) (defstruct-constructor :initform nil - :reader class-defstruct-constructor) + :accessor class-defstruct-constructor) (from-defclass-p :initform nil - :initarg :from-defclass-p - :reader class-from-defclass-p))) - + :initarg :from-defclass-p))) + (defclass specializer-with-object (specializer) ()) @@ -646,6 +666,9 @@ (defclass class-eq-specializer (exact-class-specializer specializer-with-object) ((object :initarg :class :reader specializer-class :reader specializer-object))) +(defclass class-prototype-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))) @@ -661,9 +684,7 @@ ;;; ;;; Slot definitions. ;;; -;;; Note that throughout PCL, "SLOT-DEFINITION" is abbreviated as "SLOTD". -;;; -(defclass slot-definition (documentation-mixin metaobject) +(defclass slot-definition (metaobject) ((name :initform nil :initarg :name @@ -674,7 +695,6 @@ :accessor slot-definition-initform) (initfunction :initform nil - :type (or function null) :initarg :initfunction :accessor slot-definition-initfunction) (readers @@ -693,15 +713,13 @@ :initform t :initarg :type :accessor slot-definition-type) + (documentation + :initform "" + :initarg :documentation) (class :initform nil :initarg :class - :accessor slot-definition-class) - (initfunction-side-effect-free-p - :initform nil - :initarg :initfunction-side-effect-free-p - :accessor slot-definition-initfunction-side-effect-free-p))) - + :accessor slot-definition-class))) (defclass standard-slot-definition (slot-definition) ((allocation @@ -727,23 +745,14 @@ ()) (defclass effective-slot-definition (slot-definition) - ((location ; nil, a fixnum, a cons: (slot-name . value) - :initform nil - :accessor slot-definition-location) - (reader-function ; #'(lambda (object) ...) + ((reader-function ; #'(lambda (object) ...) :accessor slot-definition-reader-function) (writer-function ; #'(lambda (new-value object) ...) :accessor slot-definition-writer-function) (boundp-function ; #'(lambda (object) ...) :accessor slot-definition-boundp-function) (accessor-flags - :initform 0) - (internal-slotd - :initform NIL - :accessor slot-definition-internal-slotd - :documentation - "Internal-slotd structure with copies of slot-definition info - used for optimizations purposes."))) + :initform 0))) (defclass standard-direct-slot-definition (standard-slot-definition direct-slot-definition) @@ -751,7 +760,9 @@ (defclass standard-effective-slot-definition (standard-slot-definition effective-slot-definition) - ()) + ((location ; nil, a fixnum, a cons: (slot-name . value) + :initform nil + :accessor slot-definition-location))) (defclass structure-direct-slot-definition (structure-slot-definition direct-slot-definition) @@ -761,38 +772,96 @@ effective-slot-definition) ()) +(defclass method (metaobject) ()) + +(defclass standard-method (definition-source-mixin plist-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-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))) + +(defclass standard-reader-method (standard-accessor-method) ()) + +(defclass standard-writer-method (standard-accessor-method) ()) + +(defclass standard-boundp-method (standard-accessor-method) ()) + +(defclass generic-function (dependent-update-mixin + definition-source-mixin + documentation-mixin + metaobject) + () + (: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) + (arg-info + :initform (make-arg-info) + :reader gf-arg-info) + (dfun-state + :initform () + :accessor gf-dfun-state) + (pretty-arglist + :initform () + :accessor gf-pretty-arglist) + ) + (:metaclass funcallable-standard-class) + (:default-initargs :method-class *the-class-standard-method* + :method-combination *standard-method-combination*)) +(defclass method-combination (metaobject) ()) -(defun slot-reader-undefined (object) - (error "slot reader-function undefined for ~S" object)) - -(defun slot-writer-undefined (new-value object) - (declare (ignore new-value)) - (error "slot writer-function undefined for ~S" object)) - -(defun slot-boundp-undefined (object) - (error "slot boundp-function undefined for ~S" object)) - -(defstruct (internal-slotd - (:print-function print-internal-slotd)) - (name NIL :type symbol) - (slot-definition NIL) - (location NIL) - (initargs () :type list) - (initfunction () :type (or function null)) - (reader-function #'slot-reader-undefined :type compiled-function) - (writer-function #'slot-writer-undefined :type compiled-function) - (boundp-function #'slot-boundp-undefined :type compiled-function)) - -#+akcl -(si::freeze-defstruct 'internal-slotd) - -(defun print-internal-slotd (internal-slotd stream depth) - (declare (ignore depth)) - (printing-random-thing (internal-slotd stream) - (format stream "internal-slotd ~S" - (internal-slotd-slot-definition internal-slotd)))) - +(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))) (defparameter *early-class-predicates* '((specializer specializerp) @@ -800,8 +869,18 @@ (class-eq-specializer class-eq-specializer-p) (eql-specializer eql-specializer-p) (class classp) + (slot-class slot-class-p) (standard-class standard-class-p) (funcallable-standard-class funcallable-standard-class-p) (structure-class structure-class-p) - (forward-referenced-class forward-referenced-class-p))) + (forward-referenced-class forward-referenced-class-p) + (method method-p) + (standard-method standard-method-p) + (standard-accessor-method standard-accessor-method-p) + (standard-reader-method standard-reader-method-p) + (standard-writer-method standard-writer-method-p) + (standard-boundp-method standard-boundp-method-p) + (generic-function generic-function-p) + (standard-generic-function standard-generic-function-p) + (method-combination method-combination-p))) diff --git a/pcl/defsys.lisp b/pcl/defsys.lisp index fad393bbc..4a758c239 100644 --- a/pcl/defsys.lisp +++ b/pcl/defsys.lisp @@ -50,17 +50,160 @@ ;;; loaded into the same world it was compiled in. ;;; -#+pcl -(when (boundp 'pcl::*boot-state*) - (warn "Lisp heap already had PCL package. Renaming it to OLD-PCL.") - (rename-package "PCL" "OLD-PCL")) - -(in-package "PCL" :use (list (or (find-package :walker) - (make-package :walker :use '(:lisp))) - (or (find-package :iterate) - (make-package :iterate - :use '(:lisp :walker))) - (find-package :lisp))) +(in-package :user) + +#+excl +(eval-when (compile load eval) + (when (eq (find-package :lisp) (find-package :common-lisp)) + (let ((excl::*enable-package-locked-errors* nil)) + (rename-package :common-lisp :common-lisp '(:cl))) + (make-package :lisp :use nil) + ((lambda (symbols) + (import symbols :lisp) + (export symbols :lisp)) + '(&allow-other-keys &aux &body &environment &key &optional &rest &whole + * ** *** *applyhook* *break-on-warnings* *debug-io* + *default-pathname-defaults* *error-output* *evalhook* *features* + *load-verbose* *macroexpand-hook* *modules* *package* *print-array* + *print-base* *print-case* *print-circle* *print-escape* + *print-gensym* *print-length* *print-level* *print-pretty* + *print-radix* *query-io* *random-state* *read-base* + *read-default-float-format* *read-suppress* *readtable* + *standard-input* *standard-output* *terminal-io* *trace-output* + + ++ +++ - / // /// /= 1+ 1- < <= = > >= abs acons acos acosh adjoin + adjust-array adjustable-array-p akcl alpha-char-p alphanumericp and + append apply applyhook apropos apropos-list aref array + array-dimension array-dimension-limit array-dimensions + array-element-type array-has-fill-pointer-p array-in-bounds-p + array-rank array-rank-limit array-row-major-index array-total-size + array-total-size-limit arrayp ash asin asinh assert assoc assoc-if + assoc-if-not atan atanh atom bignum bit bit-and bit-andc1 bit-andc2 + bit-eqv bit-ior bit-nand bit-nor bit-not bit-orc1 bit-orc2 + bit-vector bit-vector-p bit-xor block boole boole-1 boole-2 + boole-and boole-andc1 boole-andc2 boole-c1 boole-c2 boole-clr + boole-eqv boole-ior boole-nand boole-nor boole-orc1 boole-orc2 + boole-set boole-xor both-case-p boundp break butlast byte + byte-position byte-size caaaar caaadr caaar caadar caaddr caadr + caar cadaar cadadr cadar caddar cadddr caddr cadr + call-arguments-limit car case catch ccase cdaaar cdaadr cdaar + cdadar cdaddr cdadr cdar cddaar cddadr cddar cdddar cddddr cdddr + cddr cdr ceiling cerror char char-bit char-bits char-bits-limit + char-code char-code-limit char-control-bit char-downcase char-equal + char-font char-font-limit char-greaterp char-hyper-bit char-int + char-lessp char-meta-bit char-name char-not-equal char-not-greaterp + char-not-lessp char-super-bit char-upcase char/= char< char<= char= + char> char>= character characterp check-type cis clear-input + clear-output close clrhash code-char coerce common commonp + compilation-speed compile compile-file compiled-function + compiled-function-p compiler-let complex complexp concatenate cond + conjugate cons consp constantp copy-alist copy-list copy-readtable + copy-seq copy-symbol copy-tree cos cosh count count-if count-if-not + ctypecase decf declaration declare decode-float + decode-universal-time defconstant define-modify-macro + define-setf-method defmacro defparameter defsetf defstruct deftype + defun defvar delete delete-duplicates delete-file delete-if + delete-if-not denominator deposit-field describe digit-char + digit-char-p directory directory-namestring disassemble do do* + do-all-symbols do-external-symbols do-symbols documentation dolist + dotimes double-float double-float-epsilon + double-float-negative-epsilon dpb dribble ecase ed eighth elt + encode-universal-time endp enough-namestring eq eql equal equalp + error etypecase eval eval-when evalhook evenp every exp export expt + fboundp fceiling ffloor fifth file-author file-length + file-namestring file-position file-write-date fill fill-pointer + find find-all-symbols find-if find-if-not find-package find-symbol + finish-output first fixnum flet float float-digits float-precision + float-radix float-sign floatp floor fmakunbound force-output format + fourth fresh-line fround ftruncate ftype funcall function functionp + gcd gensym gentemp get get-decoded-time + get-dispatch-macro-character get-internal-real-time + get-internal-run-time get-macro-character get-output-stream-string + get-properties get-setf-method get-setf-method-multiple-value + get-universal-time getf gethash gfun go graphic-char-p hash-table + hash-table-count hash-table-p host-namestring identity if ignore + imagpart import in-package incf inline input-stream-p inspect + int-char integer integer-decode-float integer-length integerp + intern internal-time-units-per-second intersection isqrt keyword + keywordp labels lambda lambda-list-keywords lambda-parameters-limit + last lcm ldb ldb-test ldiff least-negative-double-float + least-negative-long-float least-negative-short-float + least-negative-single-float least-positive-double-float + least-positive-long-float least-positive-short-float + least-positive-single-float length let let* + lisp-implementation-type lisp-implementation-version list list* + list-all-packages list-length listen listp load locally log logand + logandc1 logandc2 logbitp logcount logeqv logior lognand lognor + lognot logorc1 logorc2 logtest logxor long-float long-float-epsilon + long-float-negative-epsilon long-site-name loop lower-case-p + machine-instance machine-type machine-version macro-function + macroexpand macroexpand-1 macrolet make-array make-broadcast-stream + make-char make-concatenated-stream make-dispatch-macro-character + make-echo-stream make-hash-table make-list make-package + make-pathname make-random-state make-sequence make-string + make-string-input-stream make-string-output-stream make-symbol + make-synonym-stream make-two-way-stream makunbound map mapc mapcan + mapcar mapcon maphash mapl maplist mask-field max member member-if + member-if-not merge merge-pathnames min minusp mips mismatch mod + most-negative-double-float most-negative-fixnum + most-negative-long-float most-negative-short-float + most-negative-single-float most-positive-double-float + most-positive-fixnum most-positive-long-float + most-positive-short-float most-positive-single-float + multiple-value-bind multiple-value-call multiple-value-list + multiple-value-prog1 multiple-value-setq multiple-values-limit + name-char namestring nbutlast nconc nil nintersection ninth not + notany notevery notinline nreconc nreverse nset-difference + nset-exclusive-or nstring-capitalize nstring-downcase + nstring-upcase nsublis nsubst nsubst-if nsubst-if-not nsubstitute + nsubstitute-if nsubstitute-if-not nth nthcdr null number numberp + numerator nunion oddp open optimize or otherwise output-stream-p + package package-name package-nicknames package-shadowing-symbols + package-use-list package-used-by-list packagep pairlis + parse-integer parse-namestring pathname pathname-device + pathname-directory pathname-host pathname-name pathname-type + pathname-version pathnamep peek-char phase pi plusp pop position + position-if position-if-not pprint prin1 prin1-to-string princ + princ-to-string print probe-file proclaim prog prog* prog1 prog2 + progn progv provide psetf psetq push pushnew quote random + random-state random-state-p rassoc rassoc-if rassoc-if-not ratio + rational rationalize rationalp read read-byte read-char + read-char-no-hang read-delimited-list read-from-string read-line + read-preserving-whitespace readtable readtablep realpart reduce rem + remf remhash remove remove-duplicates remove-if remove-if-not + remprop rename-file rename-package replace require rest return + return-from revappend reverse room rotatef round rplaca rplacd + safety satisfies sbit scale-float schar search second sequence set + set-char-bit set-difference set-dispatch-macro-character + set-exclusive-or set-macro-character set-syntax-from-char setf setq + seventh sfun shadow shadowing-import shiftf short-float + short-float-epsilon short-float-negative-epsilon short-site-name + signed-byte signum simple-array simple-bit-vector + simple-bit-vector-p simple-string simple-string-p simple-vector + simple-vector-p sin single-float single-float-epsilon + single-float-negative-epsilon sinh sixth sleep software-type + software-version some sort space special special-form-p speed sqrt + stable-sort standard-char standard-char-p step stream + stream-element-type streamp string string-capitalize string-char + string-char-p string-downcase string-equal string-greaterp + string-left-trim string-lessp string-not-equal string-not-greaterp + string-not-lessp string-right-trim string-trim string-upcase + string/= string< string<= string= string> string>= stringp + structure sublis subseq subsetp subst subst-if subst-if-not + substitute substitute-if substitute-if-not subtypep svref sxhash + symbol symbol-function symbol-name symbol-package symbol-plist + symbol-value symbolp t tagbody tailp tan tanh tenth terpri the + third throw time trace tree-equal truename truncate type type-of + typecase typep unexport unintern union unless unread-char + unsigned-byte untrace unuse-package unwind-protect upper-case-p + use-package user-homedir-pathname values values-list variable + vector vector-pop vector-push vector-push-extend vectorp warn when + with-input-from-string with-open-file with-open-stream + with-output-to-string write write-byte write-char write-line + write-string write-to-string y-or-n-p yes-or-no-p zerop)))) + +(in-package :walker :use '(:lisp)) +(in-package :iterate :use '(:lisp :walker)) +(in-package :pcl :use '(:walker :iterate :lisp)) (export (intern (symbol-name :iterate) ;Have to do this here, (find-package :iterate)) ;because in the defsystem @@ -75,18 +218,16 @@ ;;; (defvar *the-pcl-package* (find-package :pcl)) -(defvar *pcl-system-date* "July 92 PCL (beta)") +(defvar *pcl-system-date* "September 16 PCL") #+cmu -(when (boundp 'ext::*herald-items*) - (setf (getf ext::*herald-items* :pcl) - `(" CLOS based on PCL version: " ,*pcl-system-date*))) - +(setf (getf ext:*herald-items* :pcl) + `(" CLOS based on PCL version: " ,*pcl-system-date*)) + ;;; ;;; Various hacks to get people's *features* into better shape. ;;; (eval-when (compile load eval) - #+(and Symbolics Lispm) (multiple-value-bind (major minor) (sct:get-release-version) (etypecase minor @@ -155,8 +296,11 @@ ) +#+(and excl sun4) +(eval-when (eval compile load) + (pushnew :excl-sun4 *features*)) - + ;;; Yet Another Sort Of General System Facility and friends. ;;; ;;; The entry points are defsystem and operate-on-system. defsystem is used @@ -289,7 +433,7 @@ and load your system with: #+(and Lucid PRISM) ("lisp" . "abin") #+(and Lucid PA) ("lisp" . "hbin") #+(and excl SPARC) ("cl" . "sparc") - #+(and excl m68k (not next)) ("cl" . "m68k") + #+(and excl m68k) ("cl" . "m68k") #+excl ("cl" . "fasl") #+cmu ("lisp" . #.(c:backend-fasl-file-type c:*backend*)) #+HP-HPLabs ("l" . "b") @@ -484,14 +628,7 @@ and load your system with: #'(lambda (m transforms) (declare (ignore transforms)) (y-or-n-p "Load ~A?" (module-name m))) - #'make-load-without-dependencies-transformation)) - (:compile-load - ;; Compile any files that have changed and any other files - ;; that require recompilation when another file has been - ;; recompiled. But if nothing requires compilation, - ;; then load the whole system. - (make-compile-load-transformations - modules)))))) + #'make-load-without-dependencies-transformation)))))) (defun true (&rest ignore) (declare (ignore ignore)) @@ -562,18 +699,6 @@ and load your system with: pathname)) -(defun make-compile-load-transformations (modules) - (let ((transforms (list nil))) - (dolist (m modules) - (when (compile-filter m transforms) - (make-compile-transformation m transforms))) - (if (cdr transforms) - (reverse (cdr transforms)) - (make-transformations - modules - #'true - #'make-load-transformation)))) - (defun system-source-files (name) (let ((system (get-system name))) (unless system (error "Can't find system with name ~S." name)) @@ -591,7 +716,7 @@ and load your system with: (mapcar #'(lambda (module) (make-binary-pathname (module-name module))) modules)))) - + ;;; *** SITE SPECIFIC PCL DIRECTORY *** ;;; ;;; *pcl-directory* is a variable which specifies the directory pcl is stored @@ -613,10 +738,6 @@ and load your system with: ;;; *** *** (defun load-truename (&optional (errorp nil)) - #-(or Lispm excl Xerox (and dec vax common) LUCID akcl) - (declare (ignore errorp)) - #-(or Lispm excl Xerox (and dec vax common) LUCID akcl) nil - #+(or Lispm excl Xerox (and dec vax common) LUCID akcl) (flet ((bad-time () (when errorp (error "LOAD-TRUENAME called but a file isn't being loaded.")))) @@ -630,8 +751,8 @@ and load your system with: ;; 3.0 it's in the LUCID-COMMON-LISP package. ;; #+LUCID (or lucid::*source-pathname* (bad-time)) - #+akcl si:*load-pathname*)) - + #+akcl si:*load-pathname* + #-(or Lispm excl Xerox (and dec vax common) LUCID akcl) nil)) #-(or cmu Symbolics) (defvar *pcl-directory* @@ -708,34 +829,39 @@ and load your system with: (defclass t t (low)) (defs t t (defclass macros iterate)) (fngen t t (low)) - (lap t t (low)) - (plap t t (low)) - (cpatch t t (low) excl-sun4) - (quadlap t t (low) excl-sun4) (cache t t (low defs)) - (dlap t t (defs low fin cache lap)) + ;;(lap t t (low) excl-sun4) + ;;(plap t t (low) excl-sun4) + ;;(cpatch t t (low) excl-sun4) + ;;(quadlap t t (low) excl-sun4) + ;;(dlap t t (defs low fin cache lap) + ;; excl-sun4) + ;;#-excl-sun4 + (dlisp t t (defs low fin cache)) + (dlisp2 t t (low fin cache dlisp)) (boot t t (defs fin)) - (generic-functions t t (boot)) (vector t t (boot defs cache fin)) + (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)) + (generic-functions t t (boot)) (slots t t (vector boot defs low cache fin)) - (init 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)) - (structure-class t t (vector boot defs low cache fin slots)) (cpl t t (vector boot defs low cache fin slots)) - (braid t t (boot defs low fin cache)) (fsc t t (defclass boot defs low fin cache)) (methods t t (defclass boot defs low fin cache)) - (combin t t (defclass boot defs low fin cache)) - (dfun t t (dlap)) - (fixup (+ precom1 precom2) t (boot defs low fin)) + (fixup t t (boot defs low fin)) (defcombin t t (defclass boot defs low fin)) (ctypes t t (defclass defcombin)) + #+ignore (construct t t (defclass boot defs low)) (env t t (defclass boot defs low fin)) (compat t t ()) - (extensions t t ()) - (precom1 (dlap) t (defs low cache fin dfun)) - (precom2 (dlap) t (defs low cache fin dfun)) + (precom1 (dlisp) t (defs low cache fin dfun)) + (precom2 (dlisp) t (defs low cache fin dfun)) )) (defun compile-pcl (&optional m) @@ -788,8 +914,8 @@ and load your system with: (lisp-implementation-version) *features*)) - - + + ;;;; ;;; ;;; This stuff is not intended for external use. @@ -868,5 +994,42 @@ and load your system with: (zwei:kill-buffer mail-buffer))) (zwei:make-buffer-current original-buffer)))) +(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*)) + (let ((pkg (find-package "PCL"))) + (do-symbols (sym pkg) + (when (eq pkg (symbol-package sym)) + (if (or (constantp sym) + (eq sym 'wrapper) + (eq sym 'arg-info)) + (unintern sym pkg) + (progn + (makunbound sym) + (unless (eq sym 'reset-pcl-package) + (fmakunbound sym)) + #+cmu (fmakunbound `(setf ,sym)) + (setf (symbol-plist sym) nil)))))) + (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)) + diff --git a/pcl/dfun.lisp b/pcl/dfun.lisp index d9c6b02ca..0972ec87a 100644 --- a/pcl/dfun.lisp +++ b/pcl/dfun.lisp @@ -81,7 +81,6 @@ have to do any method lookup to implement itself. And so, we are saved. |# - ;An alist in which each entry is of the form : @@ -106,32 +105,61 @@ And so, we are saved. (cons (car generator-entry) (caar args-entry)) (caddr args-entry))))) +(defvar *raise-metatypes-to-class-p* t) -(declaim (ftype (function (T &rest T) real-function) get-dfun-constructor)) (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)))) (let* ((generator-entry (assq generator *dfun-constructors*)) (args-entry (assoc args (cdr generator-entry) :test #'equal))) (if (null *enable-dfun-constructor-caching*) - (apply-function (symbol-function generator) args) + (apply (symbol-function generator) args) (or (cadr args-entry) - (let ((new (apply-function (symbol-function generator) args))) - (if generator-entry - (push (list (copy-list args) new nil) (cdr generator-entry)) - (push (list generator (list (copy-list args) new nil)) *dfun-constructors*)) - new))))) + (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)))))) (defun load-precompiled-dfun-constructor (generator args system constructor) (let* ((generator-entry (assq generator *dfun-constructors*)) (args-entry (assoc args (cdr generator-entry) :test #'equal))) - (unless args-entry - (if generator-entry - (push (list args constructor system) (cdr generator-entry)) - (push (list generator (list args constructor system)) *dfun-constructors*))))) + (if args-entry + (when (fourth args-entry) + (let* ((dfun-type (case generator + (emit-checking 'checking) + (emit-caching 'caching) + (emit-constant-value 'constant-value) + (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))) + (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 (eq gf-name 'slot-boundp-using-class))))) + (update-dfun gf))) + (setf (second args-entry) constructor) + (setf (third args-entry) system) + (setf (fourth args-entry) nil))) + (let ((entry (list args constructor system nil))) + (if generator-entry + (push entry (cdr generator-entry)) + (push (list generator entry) *dfun-constructors*)))))) (defmacro precompile-dfun-constructors (&optional system) - #+excl (declare (ignore system)) - #+excl () - #-excl (let ((*precompiling-lap* t)) `(progn ,@(gathering1 (collecting) @@ -140,25 +168,16 @@ And so, we are saved. (when (or (null (caddr args-entry)) (eq (caddr args-entry) system)) (when system (setf (caddr args-entry) system)) - (multiple-value-bind (closure-variables arguments - iregs vregs fvregs tregs lap) - (apply-function (symbol-function (car generator-entry)) - (car args-entry)) - (gather1 - (make-top-level-form `(precompile-dfun-constructor - ,(car generator-entry)) - '(load) - `(load-precompiled-dfun-constructor - ',(car generator-entry) - ',(car args-entry) - ',system - (precompile-lap-closure-generator ,closure-variables - ,arguments - ,iregs - ,vregs - ,fvregs - ,tregs - ,lap)))))))))))) + (gather1 + (make-top-level-form `(precompile-dfun-constructor + ,(car generator-entry)) + '(load) + `(load-precompiled-dfun-constructor + ',(car generator-entry) + ',(car args-entry) + ',system + ,(apply (symbol-function (car generator-entry)) + (car args-entry)))))))))))) ;;; @@ -210,6 +229,10 @@ And so, we are saved. (:constructor no-methods-dfun-info ()) (:include dfun-info))) +(defstruct (initial + (:constructor initial-dfun-info ()) + (:include dfun-info))) + (defstruct (initial-dispatch (:constructor initial-dispatch-dfun-info ()) (:include dfun-info))) @@ -289,7 +312,7 @@ And so, we are saved. (defmacro dfun-update (generic-function function &rest args) `(multiple-value-bind (dfun cache info) - (funcall-function ,function ,generic-function ,@args) + (funcall ,function ,generic-function ,@args) (update-dfun ,generic-function dfun cache info))) (defun accessor-miss-function (gf dfun-info) @@ -302,47 +325,10 @@ And so, we are saved. #'(lambda (new arg) (declare (pcl-fast-call)) (accessor-miss gf new arg dfun-info))))) - - -(declaim (ftype (function (T T T T) (values function null T)) - make-one-class-accessor-dfun)) -(declaim (ftype (function (T T T T T) (values function null T)) - make-two-class-accessor-dfun)) -(declaim (ftype (function (T T T &optional T) (values function cache T)) - make-one-index-accessor-dfun)) -(declaim (ftype (function (T T T T) (values function cache T)) - make-final-one-index-accessor-dfun)) -(declaim (ftype (function (T T &optional T) (values function cache T)) - make-n-n-accessor-dfun)) -(declaim (ftype (function (T T T) (values function cache T)) - make-final-n-n-accessor-dfun)) -(declaim (ftype (function (T T &optional T) (values function (or cache null) T)) - make-checking-dfun)) -(declaim (ftype (function (T T T T) (values function (or cache null) T)) - make-final-checking-dfun)) -(declaim (ftype (function (T &optional T) (values function (or cache null) T)) - make-caching-dfun)) -(declaim (ftype (function (T T T) (values function (or cache null) T)) - make-final-caching-dfun)) -(declaim (ftype (function (T &optional T) (values function cache T)) - make-constant-value-dfun)) -(declaim (ftype (function (T T T) (values function cache T)) - make-final-constant-value-dfun)) -(declaim (ftype (function (T) (values function null T)) - make-dispatch-dfun - make-final-dispatch-dfun)) -(declaim (ftype (function (T &optional T) (values function (or cache null) T)) - make-final-dfun-internal)) - -(declaim (ftype (function (T) boolean) - use-caching-dfun-p - use-dispatch-dfun-p)) - + ;;; ;;; ONE-CLASS-ACCESSOR ;;; -(declaim (ftype (function (T T T T) (values function null T)) - make-one-class-accessor-dfun)) (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))) @@ -356,8 +342,6 @@ And so, we are saved. ;;; ;;; TWO-CLASS-ACCESSOR ;;; -(declaim (ftype (function (T T T T T) (values function null T)) - make-two-class-accessor-dfun)) (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))) @@ -371,8 +355,6 @@ And so, we are saved. ;;; ;;; std accessors same index dfun ;;; -(declaim (ftype (function (T T T &optional T) (values function cache T)) - make-one-index-accessor-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))) @@ -380,25 +362,20 @@ And so, we are saved. (declare (type cache cache)) (values (funcall (get-dfun-constructor emit (consp index)) - (cache-field cache) (cache-vector cache) - (cache-mask cache) (cache-size cache) + cache index (accessor-miss-function gf dfun-info)) cache dfun-info))) -(declaim (ftype (function (T T T T) (values function cache T)) - make-final-one-index-accessor-dfun)) (defun make-final-one-index-accessor-dfun (gf type index table) (let ((cache (fill-dfun-cache table nil 1 #'one-index-limit-fn))) - (make-one-index-accessor-dfun gf type index cache))) + (make-one-index-accessor-dfun gf type index cache))) (defun one-index-limit-fn (nlines) (default-limit-fn nlines)) -(declaim (ftype (function (T T &optional T) (values function cache T)) - make-n-n-accessor-dfun)) (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))) @@ -406,14 +383,11 @@ And so, we are saved. (declare (type cache cache)) (values (funcall (get-dfun-constructor emit) - (cache-field cache) (cache-vector cache) - (cache-mask cache) (cache-size cache) + cache (accessor-miss-function gf dfun-info)) cache dfun-info))) -(declaim (ftype (function (T T T) (values function cache T)) - make-final-n-n-accessor-dfun)) (defun make-final-n-n-accessor-dfun (gf type table) (let ((cache (fill-dfun-cache table t 1 #'n-n-accessors-limit-fn))) (make-n-n-accessor-dfun gf type cache))) @@ -421,47 +395,27 @@ And so, we are saved. (defun n-n-accessors-limit-fn (nlines) (default-limit-fn nlines)) -(defun fill-dfun-cache (table valuep nkeys limit-fn &optional cache) - (let ((cache - (or cache - (get-cache - nkeys valuep limit-fn - (the index (+ (the index (hash-table-count table)) 3)))))) - (maphash #'(lambda (classes value) - (setq cache (fill-cache cache - (class-wrapper classes) - value - t))) - table) - cache)) - - -;;; -;;; -;;; - - (defun make-checking-dfun (generic-function function &optional cache) (unless cache - (when (some #'(lambda (method) - (method-closure-generator method)) - (generic-function-methods generic-function)) + (when (use-caching-dfun-p generic-function) (return-from make-checking-dfun (make-caching-dfun generic-function))) (when (use-dispatch-dfun-p generic-function) (return-from make-checking-dfun (make-dispatch-dfun generic-function)))) - (let* ((arg-info (gf-arg-info generic-function)) - (metatypes (arg-info-metatypes arg-info)) - (applyp (arg-info-applyp arg-info)) - (nkeys (arg-info-nkeys arg-info))) - (declare (type boolean applyp) (type index nkeys)) + (multiple-value-bind (nreq applyp metatypes nkeys) + (get-generic-function-info generic-function) + (declare (ignore nreq)) (if (every #'(lambda (mt) (eq mt 't)) metatypes) - (values function nil (default-method-only-dfun-info)) + (let ((dfun-info (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))) (values (funcall (get-dfun-constructor 'emit-checking metatypes applyp) - (cache-field cache) (cache-vector cache) - (cache-mask cache) (cache-size cache) + cache function #'(lambda (&rest args) (declare (pcl-fast-call)) @@ -473,12 +427,30 @@ And so, we are saved. classes-list new-class) (let ((metatypes (arg-info-metatypes (gf-arg-info generic-function)))) (if (every #'(lambda (mt) (eq mt 't)) metatypes) - (values function nil (default-method-only-dfun-info)) + (values #'(lambda (&rest args) + (invoke-emf function args)) + nil (default-method-only-dfun-info)) (let ((cache (make-final-ordinary-dfun-internal generic-function nil #'checking-limit-fn 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) + (third method) + (method-fast-function method)))) + (method-function-get fmf ':slot-name-lists))) + (if (early-gf-p generic-function) + (early-gf-methods generic-function) + (generic-function-methods generic-function)))) + (defun checking-limit-fn (nlines) (default-limit-fn nlines)) @@ -492,22 +464,19 @@ And so, we are saved. (return-from make-caching-dfun (make-constant-value-dfun generic-function))) (when (use-dispatch-dfun-p generic-function) (return-from make-caching-dfun (make-dispatch-dfun generic-function)))) - (let* ((arg-info (gf-arg-info generic-function)) - (metatypes (arg-info-metatypes arg-info)) - (applyp (arg-info-applyp arg-info)) - (nkeys (arg-info-nkeys arg-info)) - (cache (or cache (get-cache nkeys t #'caching-limit-fn 2))) - (dfun-info (caching-dfun-info cache))) - (declare (type boolean applyp) (type index nkeys)) - (values - (funcall (get-dfun-constructor 'emit-caching metatypes applyp) - (cache-field cache) (cache-vector cache) - (cache-mask cache) (cache-size cache) - #'(lambda (&rest args) - (declare (pcl-fast-call)) - (caching-miss generic-function args dfun-info))) - cache - dfun-info))) + (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))) + (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 @@ -518,39 +487,57 @@ And so, we are saved. (defun caching-limit-fn (nlines) (default-limit-fn nlines)) -(defun use-constant-value-dfun-p (gf) - (let ((methods (generic-function-methods gf)) - (default '(unknown))) - (declare (type list methods)) - (and (null (arg-info-applyp (gf-arg-info gf))) - (compute-applicable-methods-emf-std-p gf) - (< 1 (length methods)) - (some #'(lambda (method) - (every #'(lambda (specl) (eq specl *the-class-t*)) - (method-specializers method))) - methods) - (notany #'(lambda (method) - (or (some #'eql-specializer-p - (method-specializers method)) - (eq (plist-value method :constant-value default) - default))) - methods)))) +(defun insure-caching-dfun (gf) + (multiple-value-bind (nreq applyp metatypes nkeys) + (get-generic-function-info gf) + (declare (ignore nreq nkeys)) + (when (and metatypes + (not (null (car metatypes))) + (dolist (mt metatypes nil) + (unless (eq mt 't) (return t)))) + (get-dfun-constructor 'emit-caching metatypes applyp)))) + +(defun use-constant-value-dfun-p (gf &optional boolean-values-p) + (multiple-value-bind (nreq applyp metatypes nkeys) + (get-generic-function-info gf) + (declare (ignore nreq metatypes nkeys)) + (let* ((early-p (early-gf-p gf)) + (methods (if early-p + (early-gf-methods gf) + (generic-function-methods gf))) + (default '(unknown))) + (and (null applyp) + (or (not (eq *boot-state* 'complete)) + (compute-applicable-methods-emf-std-p gf)) + (notany #'(lambda (method) + (or (and (eq *boot-state* 'complete) + (some #'eql-specializer-p + (method-specializers method))) + (let ((value (method-function-get + (if early-p + (or (third method) (second method)) + (or (method-fast-function method) + (method-function method))) + :constant-value default))) + (if boolean-values-p + (not (or (eq value 't) (eq value nil))) + (eq value default))))) + methods))))) (defun make-constant-value-dfun (generic-function &optional cache) - (let* ((arg-info (gf-arg-info generic-function)) - (metatypes (arg-info-metatypes arg-info)) - (nkeys (arg-info-nkeys arg-info)) - (cache (or cache (get-cache nkeys t #'caching-limit-fn 2))) - (dfun-info (constant-value-dfun-info cache))) - (values - (funcall (get-dfun-constructor 'emit-constant-value metatypes) - (cache-field cache) (cache-vector cache) - (cache-mask cache) (cache-size cache) - #'(lambda (&rest args) - (declare (pcl-fast-call)) - (constant-value-miss generic-function args dfun-info))) - cache - dfun-info))) + (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))) + (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 @@ -558,8 +545,57 @@ And so, we are saved. classes-list new-class))) (make-constant-value-dfun generic-function cache))) +(defun use-dispatch-dfun-p (gf &optional (caching-p (use-caching-dfun-p gf))) + (when (eq *boot-state* 'complete) + (unless caching-p + (let* ((methods (generic-function-methods gf)) + (arg-info (gf-arg-info gf)) + (mt (arg-info-metatypes arg-info)) + (nreq (length mt))) + ;;Is there a position at which every specializer is eql or non-standard? + (dotimes (i nreq nil) + (when (not (eq 't (nth i mt))) + (let ((some-std-class-specl-p nil)) + (dolist (method methods) + (let ((specl (nth i (method-specializers method)))) + (when (and (not (eql-specializer-p specl)) + (let ((sclass (specializer-class specl))) + (or (null (class-finalized-p sclass)) + (member *the-class-standard-object* + (class-precedence-list sclass))))) + (setq some-std-class-specl-p t)))) + (unless some-std-class-specl-p + (return-from use-dispatch-dfun-p t))))))))) + +(defun make-dispatch-dfun (gf) + (values (get-dispatch-function gf) nil (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))) + +(defun make-final-dispatch-dfun (gf) + (make-dispatch-dfun gf)) + +(defun update-dispatch-dfuns () + (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 + (+ (hash-table-count table) 3))))) + (maphash #'(lambda (classes value) + (setq cache (fill-cache cache + (class-wrapper classes) + value + t))) + table) + cache)) + (defun make-final-ordinary-dfun-internal (generic-function valuep limit-fn - classes-list new-class) + classes-list new-class) (let* ((arg-info (gf-arg-info generic-function)) (nkeys (arg-info-nkeys arg-info)) (new-class (and new-class @@ -571,64 +607,23 @@ And so, we are saved. (cache (if new-class (copy-cache (gf-dfun-cache generic-function)) (get-cache nkeys (not (null valuep)) limit-fn 4)))) - (declare (type index nkeys)) (make-emf-cache generic-function valuep cache classes-list new-class))) - -(defun use-caching-dfun-p (gf) - (some #'method-function-for-caching-p (generic-function-methods gf))) - -(defun use-dispatch-dfun-p (gf) - (unless (use-caching-dfun-p gf) - (let* ((methods (generic-function-methods gf)) - (arg-info (gf-arg-info gf)) - (mt (arg-info-metatypes arg-info)) - (nreq (length mt))) - (declare (type list methods mt) (type index nreq)) - ;;Is there a position at which every specializer is eql or non-standard? - (dotimes (i nreq nil) - (when (not (eq 't (nth i mt))) - (let ((some-std-class-specl-p nil)) - (dolist (method methods) - (let ((specl (nth i (method-specializers method)))) - (when (and (not (eql-specializer-p specl)) - (class-standard-p (specializer-class specl))) - (setq some-std-class-specl-p t)))) - (unless some-std-class-specl-p - (return-from use-dispatch-dfun-p t)))))))) - -(defvar *lazy-dispatch-dfun-compute-p* t) -(defvar *lazy-dfun-compute-p* nil) - -(defun make-dispatch-dfun (gf) - (values (get-dispatch-function gf) nil (dispatch-dfun-info))) - -(defun make-final-dispatch-dfun (gf) - (if *lazy-dispatch-dfun-compute-p* - (values (let ((*lazy-dfun-compute-p* t)) - (make-initial-dfun gf)) - nil (initial-dispatch-dfun-info)) - (make-dispatch-dfun gf))) - -(defun before-precompile-random-code-segments () - (dolist (gf (gfs-of-type '(dispatch initial-dispatch))) - (dfun-update gf #'make-dispatch-dfun))) (defvar *dfun-miss-gfs-on-stack* ()) -(defmacro dfun-miss ((gf args wrappers invalidp nfunction +(defmacro dfun-miss ((gf args wrappers invalidp nemf &optional type index caching-p applicable) &body body) (unless applicable (setq applicable (gensym))) - `(multiple-value-bind (,wrappers ,invalidp ,nfunction ,applicable - ,@(when type `(,type ,index))) - (cache-miss-values ,gf ,args ',(cond (type 'accessor) - (caching-p 'caching) + `(multiple-value-bind (,nemf ,applicable ,wrappers ,invalidp + ,@(when type `(,type ,index))) + (cache-miss-values ,gf ,args ',(cond (caching-p 'caching) + (type 'accessor) (t 'checking))) - (declare (type boolean ,invalidp)) (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)) - (method-function-apply ,nfunction ,args))) + (invoke-emf ,nemf ,args))) ;;; ;;; The dynamically adaptive method lookup algorithm is implemented is @@ -643,78 +638,156 @@ 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) + (defun make-initial-dfun (gf) - (if (or *lazy-dfun-compute-p* (not (compute-applicable-methods-emf-std-p gf))) - #'(lambda (&rest args) - #+Genera (declare (dbg:invisible-frame :pcl-internals)) - (initial-dfun args gf)) - (make-final-dfun gf (precompute-effective-methods gf t)))) - -(defun initial-dfun (args generic-function) - #+Genera (declare (dbg:invisible-frame :pcl-internals)) - (dfun-miss (generic-function args wrappers invalidp nfunction ntype nindex) + (let ((initial-dfun + #'(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))))) + (set-dfun gf dfun cache info)))) + +(defun make-early-accessor (gf type) + (let* ((methods (early-gf-methods gf)) + (slot-name (early-method-standard-accessor-slot-name (car methods)))) + (ecase type + (reader #'(lambda (instance) + (let* ((class (class-of instance)) + (class-name (bootstrap-get-slot 'class class 'name))) + (bootstrap-get-slot class-name instance slot-name)))) + (writer #'(lambda (new-value instance) + (let* ((class (class-of instance)) + (class-name (bootstrap-get-slot 'class class 'name))) + (bootstrap-set-slot class-name instance slot-name new-value))))))) + +(defun initial-dfun (gf args) + (dfun-miss (gf args wrappers invalidp nemf ntype nindex) (cond (invalidp) ((and ntype nindex) - (dfun-update generic-function - #'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 generic-function #'make-checking-dfun - ;; nfunction is suitable only for caching, have to do this: - (multiple-value-bind (w i function) - (cache-miss-values generic-function args 'checking) - (declare (ignore w i)) - function)))))) + (dfun-update + gf #'make-checking-dfun + ;; nemf is suitable only for caching, have to do this: + (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))) +(defvar *new-class* nil) + +(defvar *free-hash-tables* (mapcar #'list '(eq equal eql))) + +(defmacro with-hash-table ((table test) &body forms) + `(let* ((.free. (assoc ',test *free-hash-tables*)) + (,table (if (cdr .free.) + (pop (cdr .free.)) + (make-hash-table :test ',test)))) + (multiple-value-prog1 + (progn ,@forms) + (clrhash ,table) + (push ,table (cdr .free.))))) + +(defmacro with-eq-hash-table ((table) &body forms) + `(with-hash-table (,table eq) ,@forms)) + +(defun final-accessor-dfun-type (gf) + (let ((methods (if (early-gf-p gf) + (early-gf-methods gf) + (generic-function-methods gf)))) + (cond ((every #'(lambda (method) + (if (consp method) + (eq *the-class-standard-reader-method* + (early-method-class method)) + (standard-reader-method-p method))) + methods) + 'reader) + ((every #'(lambda (method) + (if (consp method) + (eq *the-class-standard-writer-method* + (early-method-class method)) + (standard-writer-method-p method))) + methods) + 'writer)))) + +(defun make-final-accessor-dfun (gf type &optional classes-list new-class) + (with-eq-hash-table (table) + (multiple-value-bind (table all-index first second size no-class-slots-p) + (make-accessor-table gf type table) + (if table + (cond ((= size 1) + (let ((w (class-wrapper first))) + (make-one-class-accessor-dfun gf type w all-index))) + ((and (= size 2) (or (integerp all-index) (consp all-index))) + (let ((w0 (class-wrapper first)) + (w1 (class-wrapper second))) + (make-two-class-accessor-dfun gf type w0 w1 all-index))) + ((or (integerp all-index) (consp all-index)) + (make-final-one-index-accessor-dfun + gf type all-index table)) + (no-class-slots-p + (make-final-n-n-accessor-dfun gf type table)) + (t + (make-final-caching-dfun gf classes-list new-class))) + (make-final-caching-dfun gf classes-list new-class))))) + (defun make-final-dfun-internal (gf &optional classes-list) (let ((methods (generic-function-methods gf)) type - (new-class *new-class*) (*new-class* nil)) + (new-class *new-class*) (*new-class* nil) + specls all-same-p) (cond ((null methods) (values #'(lambda (&rest args) (apply #'no-applicable-method gf args)) nil (no-methods-dfun-info))) - ((setq type (cond ((every #'standard-reader-method-p methods) - 'reader) - ((every #'standard-writer-method-p methods) - 'writer))) - (with-eq-hash-table (table) - (multiple-value-bind (table all-index first second size no-class-slots-p) - (make-accessor-table gf type table) - (declare (type boolean no-class-slots-p)) - (if table - (cond ((= (the index size) 1) - (let ((w (class-wrapper first))) - (make-one-class-accessor-dfun gf type w all-index))) - ((and (= (the index size) 2) - (or (integerp all-index) (consp all-index))) - (let ((w0 (class-wrapper first)) - (w1 (class-wrapper second))) - (make-two-class-accessor-dfun gf type w0 w1 all-index))) - ((or (integerp all-index) (consp all-index)) - (make-final-one-index-accessor-dfun - gf type all-index table)) - (no-class-slots-p - (make-final-n-n-accessor-dfun gf type table)) - (t - (make-final-caching-dfun gf classes-list new-class))) - (make-final-caching-dfun gf classes-list new-class))))) - ((use-constant-value-dfun-p gf) + ((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*)) + (setq specls (method-specializers (car methods)))) + (setq all-same-p + (every #'(lambda (method) + (and (equal specls + (method-specializers method)))) + methods)))) + (use-constant-value-dfun-p gf)) (make-final-constant-value-dfun gf classes-list new-class)) ((use-dispatch-dfun-p gf) (make-final-dispatch-dfun gf)) - ((let ((specls (method-specializers (car methods)))) - (and (every #'(lambda (method) - (and (equal specls (method-specializers method)))) - methods) - (not (use-caching-dfun-p gf)))) - (let ((function (get-secondary-dispatch-function gf methods nil))) - (make-final-checking-dfun gf function classes-list new-class))) + ((and all-same-p (not (use-caching-dfun-p gf))) + (let ((emf (get-secondary-dispatch-function gf methods nil))) + (make-final-checking-dfun gf emf classes-list new-class))) (t (make-final-caching-dfun gf classes-list new-class))))) @@ -725,7 +798,7 @@ And so, we are saved. (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. - (dfun-miss (gf args wrappers invalidp nfunction ntype nindex) + (dfun-miss (gf args wrappers invalidp nemf ntype nindex) ;; ;; The following lexical functions change the state of the ;; dfun to that which is their name. They accept arguments @@ -733,13 +806,13 @@ And so, we are saved. ;; information from the lexical variables bound above. ;; (flet ((two-class (index w0 w1) - (when (zerop (the index (random 2))) (psetf w0 w1 w1 w0)) + (when (zerop (random 2)) (psetf w0 w1 w1 w0)) (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)) (n-n (&optional cache) (if (consp nindex) - (dfun-update gf #'make-checking-dfun nfunction) + (dfun-update gf #'make-checking-dfun nemf) (dfun-update gf #'make-n-n-accessor-dfun ntype cache))) (caching () ; because cached accessor emfs are much faster for accessors (dfun-update gf #'make-caching-dfun)) @@ -747,15 +820,13 @@ And so, we are saved. (do-fill (update-fn) (let ((ncache (fill-cache cache wrappers nindex))) (unless (eq ncache cache) - (funcall-function update-fn ncache))))) + (funcall update-fn ncache))))) (cond ((null ntype) (caching)) ((or invalidp (null nindex))) ((not (or (std-instance-p object) - (fsc-instance-p object) - #+pcl-user-instances - (user-instance-p object))) + (fsc-instance-p object))) (caching)) ((or (neq ntype otype) (listp wrappers)) (caching)) @@ -790,41 +861,594 @@ And so, we are saved. (do-fill #'n-n)))))))))) (defun checking-miss (generic-function args dfun-info) - (let ((ofunction (dfun-info-function dfun-info)) + (let ((oemf (dfun-info-function dfun-info)) (cache (dfun-info-cache dfun-info))) - (dfun-miss (generic-function args wrappers invalidp nfunction) + (dfun-miss (generic-function args wrappers invalidp nemf) (cond (invalidp) - ((eq ofunction nfunction) + ((eq oemf nemf) (let ((ncache (fill-cache cache wrappers nil))) (unless (eq ncache cache) (dfun-update generic-function #'make-checking-dfun - nfunction ncache)))) + nemf ncache)))) (t (dfun-update generic-function #'make-caching-dfun)))))) (defun caching-miss (generic-function args dfun-info) (let ((ocache (dfun-info-cache dfun-info))) - (dfun-miss (generic-function args wrappers invalidp function nil nil t) + (dfun-miss (generic-function args wrappers invalidp emf nil nil t) (cond (invalidp) (t - (let ((ncache (fill-cache ocache wrappers function))) + (let ((ncache (fill-cache ocache wrappers emf))) (unless (eq ncache ocache) (dfun-update generic-function #'make-caching-dfun ncache)))))))) (defun constant-value-miss (generic-function args dfun-info) (let ((ocache (dfun-info-cache dfun-info))) - (dfun-miss (generic-function args wrappers invalidp function nil nil t) + (dfun-miss (generic-function args wrappers invalidp emf nil nil t) (cond (invalidp) (t - (let* ((value (method-constant-value (method-function-method function))) + (let* ((function (typecase emf + (fast-method-call (fast-method-call-function emf)) + (method-call (method-call-function emf)))) + (value (method-function-get function :constant-value)) (ncache (fill-cache ocache wrappers value))) (unless (eq ncache ocache) (dfun-update generic-function #'make-constant-value-dfun ncache)))))))) - +;;; Given a generic function and a set of arguments to that generic function, +;;; returns a mess of values. +;;; +;;; <function> The compiled effective method function for this set of +;;; arguments. +;;; +;;; <applicable> Sorted list of applicable methods. +;;; +;;; <wrappers> Is a single wrapper if the generic function has only +;;; one key, that is arg-info-nkeys of the arg-info is 1. +;;; Otherwise a list of the wrappers of the specialized +;;; arguments to the generic function. +;;; +;;; Note that all these wrappers are valid. This function +;;; does invalid wrapper traps when it finds an invalid +;;; wrapper and then returns the new, valid wrapper. +;;; +;;; <invalidp> True if any of the specialized arguments had an invalid +;;; wrapper, false otherwise. +;;; +;;; <type> READER or WRITER when the only method that would be run +;;; is a standard reader or writer method. To be specific, +;;; the value is READER when the method combination is eq to +;;; *standard-method-combination*; there are no applicable +;;; :before, :after or :around methods; and the most specific +;;; primary method is a standard reader method. +;;; +;;; <index> If <type> is READER or WRITER, and the slot accessed is +;;; an :instance slot, this is the index number of that slot +;;; in the object argument. +;;; +(defun cache-miss-values (gf args state) + (if (null (if (early-gf-p gf) + (early-gf-methods gf) + (generic-function-methods gf))) + (apply #'no-applicable-method gf args) + (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" + gf (length metatypes)) + (multiple-value-bind (emf methods accessor-type index) + (cache-miss-values-internal gf arg-info wrappers classes types state) + (values emf methods + dfun-wrappers + invalid-wrapper-p + accessor-type index)))))) + +(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))) + (cam-std-p (or (null arg-info) + (gf-info-c-a-m-emf-std-p arg-info)))) + (multiple-value-bind (methods all-applicable-and-sorted-p) + (if cam-std-p + (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)))) + (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)))))) + +(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))))) + (accessor-values-internal accessor-type accessor-class methods))) + +(defun accessor-values1 (gf accessor-type accessor-class) + (let* ((type `(class-eq ,accessor-class)) + (types (if (eq accessor-type 'writer) `(t ,type) `(,type))) + (methods (compute-applicable-methods-using-types gf types))) + (accessor-values-internal accessor-type accessor-class methods))) + +(defun accessor-values-internal (accessor-type accessor-class methods) + (let* ((meth (car methods)) + (early-p (not (eq *boot-state* 'complete))) + (slot-name (when accessor-class + (if (consp meth) + (and (early-method-standard-accessor-p meth) + (early-method-standard-accessor-slot-name meth)) + (and (member *the-class-standard-object* + (if early-p + (early-class-precedence-list accessor-class) + (class-precedence-list accessor-class))) + (if early-p + (not (eq *the-class-standard-method* + (early-method-class meth))) + (standard-accessor-method-p meth)) + (if early-p + (early-accessor-method-slot-name meth) + (accessor-method-slot-name meth)))))) + (slotd (and accessor-class + (if early-p + (dolist (slot (early-class-slotds accessor-class) nil) + (when (eql slot-name (early-slot-definition-name slot)) + (return slot))) + (find-slot-definition accessor-class slot-name))))) + (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)) + 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) + (early-gf-methods gf) + (generic-function-methods gf))) + (all-index nil) + (no-class-slots-p t) + (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-standard-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-standard-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))) + +(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))) + (let ((specls (if (consp method) + (early-method-specializers method t) + (method-specializers method))) + (types types) + (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)) + (unless specl-applicable-p + (setq applicable-p nil)) + (unless specl-possibly-applicable-p + (setq possibly-applicable-p nil) + (return nil)))) + (when possibly-applicable-p + (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) + definite-p)))) + +(defun sort-applicable-methods (precedence methods types) + (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)))) + (if (memq class2 (memq class1 cpl)) + class1 class2))))) + +(defun sort-methods (methods precedence compare-classes-function) + (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))))))) + (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)))))))) + +(defun map-all-orders (methods precedence function) + (let ((choices nil)) + (flet ((compare-classes-function (class1 class2 index) + (declare (ignore index)) + (let ((choice nil)) + (dolist (c choices nil) + (when (or (and (eq (first c) class1) + (eq (second c) class2)) + (and (eq (first c) class2) + (eq (second c) class1))) + (return (setq choice c)))) + (unless choice + (setq choice + (if (class-might-precede-p class1 class2) + (if (class-might-precede-p class2 class1) + (list class1 class2 nil t) + (list class1 class2 t)) + (if (class-might-precede-p class2 class1) + (list class2 class1 t) + (let ((name1 (class-name class1)) + (name2 (class-name class2))) + (if (and name1 name2 (symbolp name1) (symbolp name2) + (string< (symbol-name name1) + (symbol-name name2))) + (list class1 class2 t) + (list class2 class1 t)))))) + (push choice choices)) + (car choice)))) + (loop (funcall function + (sort-methods methods precedence #'compare-classes-function)) + (unless (dolist (c choices nil) + (unless (third c) + (rotatef (car c) (cadr c)) + (return (setf (third c) t)))) + (return nil)))))) + +(defvar *in-precompute-effective-methods-p* nil) + +;used only in map-all-orders +(defun class-might-precede-p (class1 class2) + (if (not *in-precompute-effective-methods-p*) + (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) (push (- (1- nreq) i) list))) + (mapcar #'(lambda (x) (position x lambda-list)) argument-precedence-order))) + +(defun saut-and (specl type) + (let ((applicable nil) + (possibly-applicable t)) + (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))))) + (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" + '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 classes-have-common-subclass-p (class1 class2) + (or (eq class1 class2) + (let ((class1-subs (class-direct-subclasses class1))) + (or (memq class2 class1-subs) + (dolist (class1-sub class1-subs nil) + (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))) + (let ((pred (case (car specl) + (class-eq + (eq (cadr specl) (cadr type))) + (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))))))))) + (values pred pred)))) + +(defun saut-prototype (specl type) + (declare (ignore specl type)) + (values nil nil)) ; fix this someday + +(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)))))))) + (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 +;;; combination must not change once it is connected to the +;;; generic function. +;;; +;;; This has to be legal, because otherwise any kind of method +;;; lookup caching couldn't work. See this by saying that this +;;; 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! +(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)) + +(defun get-secondary-dispatch-function1 (gf methods types method-alist-p wrappers-p + &optional all-applicable-p + (all-sorted-p t) function-p) + (if (null methods) + #'(lambda (method-alist wrappers) + (declare (ignore method-alist wrappers)) + #'(lambda (&rest args) + (apply #'no-applicable-method gf args))) + (let* ((key (car methods)) + (ht-value (or (gethash key *effective-method-table*) + (setf (gethash key *effective-method-table*) + (cons nil nil))))) + (if (and (null (cdr methods)) all-applicable-p ; the most common case + (null method-alist-p) wrappers-p (not function-p)) + (or (car ht-value) + (setf (car ht-value) + (get-secondary-dispatch-function2 + gf methods types method-alist-p wrappers-p + all-applicable-p all-sorted-p function-p))) + (let ((akey (list methods + (if all-applicable-p 'all-applicable types) + method-alist-p wrappers-p function-p))) + (or (cdr (assoc akey (cdr ht-value) :test #'equal)) + (let ((value (get-secondary-dispatch-function2 + gf methods types method-alist-p wrappers-p + all-applicable-p all-sorted-p function-p))) + (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) + (if (and all-applicable-p all-sorted-p (not function-p)) + (if (eq *boot-state* 'complete) + (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))) + (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-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))) + (ocache (gf-dfun-cache 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))) + (info (gf-dfun-info generic-function))) + (unless (eq 'default-method-only (type-of info)) + (setq dfun (doctor-dfun-for-the-debugger + generic-function + #+cmu dfun #-cmu (set-function-name dfun gf-name)))) + (set-funcallable-instance-function generic-function dfun) + #+cmu (set-function-name generic-function gf-name) + (when (and ocache (not (eq ocache cache))) (free-cache ocache)) + dfun))) + (defvar dfun-count nil) (defvar dfun-list nil) (defvar *minimum-cache-size-to-list*) @@ -846,8 +1470,7 @@ And so, we are saved. (cache (gf-dfun-cache gf))) (when cache (let ((size (cache-size cache))) - (declare (type index size)) - (when (>= size (the index *minimum-cache-size-to-list*)) + (when (>= size *minimum-cache-size-to-list*) (let ((a (assoc size dfun-list))) (unless a (push (setq a (list size)) dfun-list)) @@ -869,13 +1492,13 @@ And so, we are saved. (a (assq sym dfun-count))) (unless a (push (setq a (list sym 0 nil)) dfun-count)) - (setf (cadr a) (the index (1+ (the index (cadr a))))) + (incf (cadr a)) (when cache (let* ((size (cache-size cache)) (b (assoc size (third a)))) (unless b (push (setq b (cons size 0)) (third a))) - (setf (cdr b) (the index (1+ (the index (cdr b))))))))) + (incf (cdr b)))))) (defun count-all-dfuns () (setq dfun-count (mapcar #'(lambda (type) (list type 0 nil)) diff --git a/pcl/dlap.lisp b/pcl/dlap.lisp index 2627efef8..adb1f4abe 100644 --- a/pcl/dlap.lisp +++ b/pcl/dlap.lisp @@ -29,22 +29,26 @@ -(defun emit-one-class-reader (class-slot-p) (emit-reader/writer :reader 1 class-slot-p)) -(defun emit-one-class-writer (class-slot-p) (emit-reader/writer :writer 1 class-slot-p)) +(defun emit-one-class-reader (class-slot-p) + (emit-reader/writer :reader 1 class-slot-p)) -(defun emit-two-class-reader (class-slot-p) (emit-reader/writer :reader 2 class-slot-p)) -(defun emit-two-class-writer (class-slot-p) (emit-reader/writer :writer 2 class-slot-p)) +(defun emit-one-class-writer (class-slot-p) + (emit-reader/writer :writer 1 class-slot-p)) + +(defun emit-two-class-reader (class-slot-p) + (emit-reader/writer :reader 2 class-slot-p)) + +(defun emit-two-class-writer (class-slot-p) + (emit-reader/writer :writer 2 class-slot-p)) (defun emit-reader/writer (reader/writer 1-or-2-class class-slot-p) - (declare (type index 1-or-2-class) - (type boolean class-slot-p)) (let ((instance nil) (arglist ()) (closure-variables ()) - (field (first-wrapper-cache-number-index))) ;we need some field to do - ;the fast obsolete check + (field (first-wrapper-cache-number-index))) + ;;we need some field to do the fast obsolete check (ecase reader/writer (:reader (setq instance (dfun-arg-symbol 0) arglist (list instance))) @@ -64,27 +68,16 @@ ;for different values at ;different times. (slots (and (null class-slot-p) - (allocate-register 'vector))) + (allocate-register #-new-kcl-wrapper 'vector + #+new-kcl-wrapper t))) (csv (and class-slot-p (allocate-register t)))) (prog1 (flatten-lap (opcode :move (operand :arg instance) inst) ;get the instance (opcode :std-instance-p inst 'std-instance) ;if not either std-inst (opcode :fsc-instance-p inst 'fsc-instance) ;or fsc-instance then - #+pcl-user-instances - (opcode :user-instance-p inst 'user-instance) ;if not either std-inst (opcode :go 'trap) ;we lose - #+pcl-user-instances - (opcode :label 'user-instance) - #+pcl-user-instances - (opcode :move (operand :user-wrapper inst) wrapper) - #+pcl-user-instances - (and slots - (opcode :move (operand :user-slots inst) slots)) - #+pcl-user-instances - (opcode :go 'have-wrapper) - (opcode :label 'fsc-instance) (opcode :move (operand :fsc-wrapper inst) wrapper) (and slots @@ -129,11 +122,10 @@ (defun emit-one-index-readers (class-slot-p) - (declare (type boolean class-slot-p)) (let ((arglist (list (dfun-arg-symbol 0)))) (generating-lap '(field cache-vector mask size index miss-fn) arglist - (with-lap-registers ((slots vector)) + (with-lap-registers ((slots #-new-kcl-wrapper vector #+new-kcl-wrapper t)) (emit-dlap arglist '(standard-instance) 'trap @@ -150,11 +142,10 @@ (and (null class-slot-p) (list slots))))))) (defun emit-one-index-writers (class-slot-p) - (declare (type boolean class-slot-p)) (let ((arglist (list (dfun-arg-symbol 0) (dfun-arg-symbol 1)))) (generating-lap '(field cache-vector mask size index miss-fn) arglist - (with-lap-registers ((slots vector)) + (with-lap-registers ((slots #-new-kcl-wrapper vector #+new-kcl-wrapper t)) (emit-dlap arglist '(t standard-instance) 'trap @@ -176,7 +167,7 @@ (let ((arglist (list (dfun-arg-symbol 0)))) (generating-lap '(field cache-vector mask size miss-fn) arglist - (with-lap-registers ((slots vector) + (with-lap-registers ((slots #-new-kcl-wrapper vector #+new-kcl-wrapper t) (index index)) (emit-dlap arglist '(standard-instance) @@ -192,7 +183,7 @@ (let ((arglist (list (dfun-arg-symbol 0) (dfun-arg-symbol 1)))) (generating-lap '(field cache-vector mask size miss-fn) arglist - (with-lap-registers ((slots vector) + (with-lap-registers ((slots #-new-kcl-wrapper vector #+new-kcl-wrapper t) (index index)) (flatten-lap (emit-dlap arglist @@ -209,15 +200,21 @@ (defun emit-checking (metatypes applyp) (let ((dlap-lambda-list (make-dlap-lambda-list metatypes applyp))) - (generating-lap '(field cache-vector mask size function miss-fn) + (generating-lap '(field cache-vector mask size + #-excl-sun4 emf #+excl-sun4 function + miss-fn) dlap-lambda-list (emit-dlap (remove '&rest dlap-lambda-list) metatypes 'trap - (with-lap-registers ((function t)) + (with-lap-registers ((#-excl-sun4 emf #+excl-sun4 function t)) (flatten-lap - (opcode :move (operand :cvar 'function) function) - (opcode :jmp function))) + (opcode :move (operand :cvar + #-excl-sun4 'emf #+excl-sun4 'function) + #-excl-sun4 emf + #+excl-sun4 function) + #-excl-sun4 (opcode :emf-call emf) + #+excl-sun4 (opcode :jmp function))) (with-lap-registers ((miss-function t)) (flatten-lap (opcode :label 'trap) @@ -229,17 +226,19 @@ (let ((dlap-lambda-list (make-dlap-lambda-list metatypes applyp))) (generating-lap '(field cache-vector mask size miss-fn) dlap-lambda-list - (with-lap-registers ((function t)) + (with-lap-registers ((#-excl-sun4 emf #+excl-sun4 function t)) (emit-dlap (remove '&rest dlap-lambda-list) metatypes 'trap - (flatten-lap (opcode :jmp function)) + (flatten-lap + #-excl-sun4 (opcode :emf-call emf) + #+excl-sun4 (opcode :jmp function)) (with-lap-registers ((miss-function t)) (flatten-lap (opcode :label 'trap) (opcode :move (operand :cvar 'miss-fn) miss-function) (opcode :jmp miss-function))) - function))))) + #-excl-sun4 emf #+excl-sun4 function))))) (defun emit-constant-value (metatypes) (let ((dlap-lambda-list (make-dlap-lambda-list metatypes nil))) @@ -249,7 +248,7 @@ (emit-dlap dlap-lambda-list metatypes 'trap - (flatten-lap + (flatten-lap (opcode :return value)) (with-lap-registers ((miss-function t)) (flatten-lap @@ -281,7 +280,7 @@ (let ((slot-unbound (operand :constant *slot-unbound*))) (with-lap-registers ((val t :reuse temp)) (flatten-lap - (opcode :move (operand :iref slots index) val) ;get slot value + (opcode :move (operand :instance-ref slots index) val) ;get slot value (opcode :eq val slot-unbound trap-label) ;is the slot unbound? (opcode :return val))))) ;return the slot value @@ -289,7 +288,7 @@ (with-lap-registers ((new-val t :reuse temp)) (flatten-lap (opcode :move (operand :arg new-value-arg) new-val) ;get new value into a reg - (opcode :move new-val (operand :iref slots index)) ;set slot value + (opcode :move new-val (operand :instance-ref slots index));set slot value (opcode :return new-val)))) (defun emit-get-class-slot (index trap-label &optional temp) @@ -430,12 +429,7 @@ hit))) (defun emit-greater-than-1-dlap (wrappers wrapper-moves hit miss miss-label value) - (declare (list wrappers)) - (let ((cache-line-size (compute-line-size - (if value - (the index (1+ (the index (length wrappers)))) - (length wrappers))))) - (declare (type index cache-line-size)) + (let ((cache-line-size (compute-line-size (+ (length wrappers) (if value 1 0))))) (with-lap-registers ((location index) (primary index) (cache-vector vector) @@ -530,6 +524,116 @@ (opcode :move (operand :constant (index-value->index 1)) location) (opcode :go cont-label))) + +;; From cache.lisp +(defun emit-cache-vector-ref (cache-vector-operand location-operand) + (operand :iref cache-vector-operand location-operand)) + +(defun emit-wrapper-ref (wrapper-operand field-operand) + (operand :iref wrapper-operand field-operand)) +(defun emit-wrapper-cache-number-vector (wrapper-operand) + (operand :wrapper-cache-number-vector wrapper-operand)) +(defun emit-cache-number-vector-ref (cnv-operand field-operand) + (operand :iref cnv-operand field-operand)) + +(defun emit-1-wrapper-compute-primary-cache-location (wrapper primary wrapper-cache-no) + (with-lap-registers ((mask index) + #+structure-wrapper (cnv fixnum-vector)) + (let ((field wrapper-cache-no)) + (flatten-lap + (opcode :move (operand :cvar 'mask) mask) + (opcode :move (operand :cvar 'field) field) + #-structure-wrapper + (opcode :move (emit-wrapper-ref wrapper field) wrapper-cache-no) + #+structure-wrapper + (opcode :move (emit-wrapper-cache-number-vector wrapper) cnv) + #+structure-wrapper + (opcode :move (emit-cache-number-vector-ref cnv field) wrapper-cache-no) + (opcode :move (operand :ilogand wrapper-cache-no mask) primary))))) + +(defun emit-n-wrapper-compute-primary-cache-location (wrappers primary miss-label) + (with-lap-registers ((field index) + (mask index)) + (let ((add-wrapper-cache-numbers + (flatten-lap + (gathering1 (flattening-lap) + (iterate ((wrapper (list-elements wrappers)) + (i (interval :from 1))) + (gather1 + (with-lap-registers ((wrapper-cache-no index) + #+structure-wrapper (cnv fixnum-vector)) + (flatten-lap + #-structure-wrapper + (opcode :move (emit-wrapper-ref wrapper field) wrapper-cache-no) + #+structure-wrapper + (opcode :move (emit-wrapper-cache-number-vector wrapper) cnv) + #+structure-wrapper + (opcode :move (emit-cache-number-vector-ref cnv field) + wrapper-cache-no) + (opcode :izerop wrapper-cache-no miss-label) + (opcode :move (operand :i+ primary wrapper-cache-no) primary) + (when (zerop (mod i wrapper-cache-number-adds-ok)) + (opcode :move (operand :ilogand primary mask) primary)))))))))) + (flatten-lap + (opcode :move (operand :constant 0) primary) + (opcode :move (operand :cvar 'field) field) + (opcode :move (operand :cvar 'mask) mask) + add-wrapper-cache-numbers + (opcode :move (operand :ilogand primary mask) primary) + (opcode :move (operand :i1+ primary) primary))))) + +(defun emit-fetch-wrapper (metatype argument dest miss-label &optional slot) + (let ((exit-emit-fetch-wrapper (make-symbol "exit-emit-fetch-wrapper"))) + (with-lap-registers ((arg t)) + (ecase metatype + ((standard-instance #+new-kcl-wrapper structure-instance) + (let ((get-std-inst-wrapper (make-symbol "get-std-inst-wrapper")) + (get-fsc-inst-wrapper (make-symbol "get-fsc-inst-wrapper"))) + (flatten-lap + (opcode :move (operand :arg argument) arg) + (opcode :std-instance-p arg get-std-inst-wrapper) ;is it a std wrapper? + (opcode :fsc-instance-p arg get-fsc-inst-wrapper) ;is it a fsc wrapper? + (opcode :go miss-label) + (opcode :label get-fsc-inst-wrapper) + (opcode :move (operand :fsc-wrapper arg) dest) ;get fsc wrapper + (and slot + (opcode :move (operand :fsc-slots arg) slot)) + (opcode :go exit-emit-fetch-wrapper) + (opcode :label get-std-inst-wrapper) + (opcode :move (operand :std-wrapper arg) dest) ;get std wrapper + (and slot + (opcode :move (operand :std-slots arg) slot)) + (opcode :label exit-emit-fetch-wrapper)))) + (class + (when slot (error "Can't do a slot reg for this metatype.")) + (let ((get-std-inst-wrapper (make-symbol "get-std-inst-wrapper")) + (get-fsc-inst-wrapper (make-symbol "get-fsc-inst-wrapper"))) + (flatten-lap + (opcode :move (operand :arg argument) arg) + (opcode :std-instance-p arg get-std-inst-wrapper) + (opcode :fsc-instance-p arg get-fsc-inst-wrapper) + #-new-kcl-wrapper + (opcode :move (operand :built-in-or-structure-wrapper arg) dest) + #+new-kcl-wrapper + (opcode :move (operand :built-in-wrapper arg) dest) + (opcode :go exit-emit-fetch-wrapper) + (opcode :label get-fsc-inst-wrapper) + (opcode :move (operand :fsc-wrapper arg) dest) + (opcode :go exit-emit-fetch-wrapper) + (opcode :label get-std-inst-wrapper) + (opcode :move (operand :std-wrapper arg) dest) + (opcode :label exit-emit-fetch-wrapper)))) + ((built-in-instance #-new-kcl-wrapper structure-instance) + (when slot (error "Can't do a slot reg for this metatype.")) + (let () + (flatten-lap + (opcode :move (operand :arg argument) arg) + (opcode :std-instance-p arg miss-label) + (opcode :fsc-instance-p arg miss-label) + #-new-kcl-wrapper + (opcode :move (operand :built-in-or-structure-wrapper arg) dest) + #+new-kcl-wrapper + (opcode :move (operand :built-in-wrapper arg) dest)))))))) diff --git a/pcl/env.lisp b/pcl/env.lisp index 336fd6893..524055f73 100644 --- a/pcl/env.lisp +++ b/pcl/env.lisp @@ -35,16 +35,16 @@ (defun pcl-arglist (function &rest other-args) (let ((defn nil)) (cond ((and (fsc-instance-p function) - (generic-function-p function)) - (generic-function-pretty-arglist function)) - ((and (symbolp function) - (fboundp function) - (setq defn (symbol-function function)) - (fsc-instance-p defn) - (generic-function-p defn)) - (generic-function-pretty-arglist defn)) - (t (apply (original-definition 'sys::arglist) - function other-args))))) + (generic-function-p function)) + (generic-function-pretty-arglist function)) + ((and (symbolp function) + (fboundp function) + (setq defn (symbol-function function)) + (fsc-instance-p defn) + (generic-function-p defn)) + (generic-function-pretty-arglist defn)) + (t (apply (original-definition 'sys::arglist) + function other-args))))) (redefine-function 'sys::arglist 'pcl-arglist) @@ -68,176 +68,157 @@ (defmethod describe-object (object stream) (let ((*standard-output* stream)) - (funcall-compiled (original-definition 'describe) object))) + (cond ((or #+kcl (packagep object)) + (describe-package object stream)) + (t + (funcall (original-definition 'describe) object))))) (redefine-function 'describe 'pcl-describe) ) (defmethod describe-object ((object slot-object) stream) - (format stream "~%~S is an instance of class ~S:" object (class-of object)) - (describe-object-slots object stream)) - -(defmethod describe-object-slots - ((object slot-object) - stream - &key - (slots-to-inspect (slots-to-inspect (class-of object) object)) - &allow-other-keys) - "Display the value of all the slots-to-inspect on this object." - (let* ((max-slot-name-length 0) - (instance-slotds ()) - (class-slotds ()) - (other-slotds ())) - (declare (type index max-slot-name-length)) + (let* ((class (class-of object)) + (slotds (slots-to-inspect class object)) + (max-slot-name-length 0) + (instance-slotds ()) + (class-slotds ()) + (other-slotds ())) (flet ((adjust-slot-name-length (name) - (setq max-slot-name-length - (the index - (max max-slot-name-length - (length (the simple-string - (symbol-name name))))))) - (describe-slot (name value &optional (allocation () alloc-p)) - (if alloc-p - (format stream - "~% ~A ~S ~VT " - name allocation (+ max-slot-name-length 7)) - (format stream - "~% ~A~VT " - name max-slot-name-length)) - (prin1 value stream))) - + (setq max-slot-name-length + (max max-slot-name-length + (length (the string (symbol-name name)))))) + (describe-slot (name value &optional (allocation () alloc-p)) + (if alloc-p + (format stream + "~% ~A ~S ~VT ~S" + name allocation (+ max-slot-name-length 7) value) + (format stream + "~% ~A~VT ~S" + name max-slot-name-length value)))) ;; Figure out a good width for the slot-name column. - (dolist (slotd slots-to-inspect) - (adjust-slot-name-length (slot-definition-name slotd)) - (case (slot-definition-allocation slotd) - (:instance (push slotd instance-slotds)) - (:class (push slotd class-slotds)) - (otherwise (push slotd other-slotds)))) - (setq max-slot-name-length - (the index (min (the index (+ max-slot-name-length 3)) 30))) + (dolist (slotd slotds) + (adjust-slot-name-length (slot-definition-name slotd)) + (case (slot-definition-allocation slotd) + (:instance (push slotd instance-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) (when instance-slotds - (format stream "~% The following slots have :INSTANCE allocation:") - (dolist (slotd (nreverse instance-slotds)) - (describe-slot (slot-definition-name slotd) - (slot-value-or-default - object (slot-definition-name slotd))))) + (format stream "~% The following slots have :INSTANCE allocation:") + (dolist (slotd (nreverse instance-slotds)) + (describe-slot (slot-definition-name slotd) + (slot-value-or-default object (slot-definition-name slotd))))) (when class-slotds - (format stream "~% The following slots have :CLASS allocation:") - (dolist (slotd (nreverse class-slotds)) - (describe-slot (slot-definition-name slotd) - (slot-value-or-default - object (slot-definition-name slotd))))) - - (when other-slotds - (format stream "~% The following slots have allocation as shown:") - (dolist (slotd (nreverse other-slotds)) - (describe-slot (slot-definition-name slotd) - (slot-value-or-default - object (slot-definition-name slotd)) - (slot-definition-allocation slotd)))) + (format stream "~% The following slots have :CLASS allocation:") + (dolist (slotd (nreverse class-slotds)) + (describe-slot (slot-definition-name slotd) + (slot-value-or-default object (slot-definition-name slotd))))) + + (when other-slotds + (format stream "~% The following slots have allocation as shown:") + (dolist (slotd (nreverse other-slotds)) + (describe-slot (slot-definition-name slotd) + (slot-value-or-default object (slot-definition-name slotd)) + (slot-definition-allocation slotd)))) (values)))) (defmethod slots-to-inspect ((class slot-class) (object slot-object)) (class-slots class)) -(defvar *describe-generic-functions-as-objects-p* nil) +(defvar *describe-metaobjects-as-objects-p* nil) (defmethod describe-object ((fun standard-generic-function) stream) (format stream "~A is a generic function.~%" fun) (format stream "Its arguments are:~% ~S~%" (generic-function-pretty-arglist fun)) - (if *describe-generic-functions-as-objects-p* - (describe-object-slots fun stream) - (progn - (format stream "Its methods are:") - (dolist (meth (generic-function-methods fun)) - (format stream "~2%**** ~{~S ~}~:S =>~%" - (method-qualifiers meth) - (unparse-specializers meth)) - (describe-object meth stream))))) + (format stream "Its methods are:") + (dolist (meth (generic-function-methods fun)) + (format stream "~2% ~{~S ~}~:S =>~%" + (method-qualifiers meth) + (unparse-specializers meth)) + (describe-object (or (method-fast-function meth) + (method-function meth)) + stream)) + (when *describe-metaobjects-as-objects-p* + (call-next-method))) ;;; ;;; ;;; -(defvar *describe-classes-as-objects-p* nil) - (defmethod describe-object ((class class) stream) (flet ((pretty-class (c) (or (class-name c) c))) (macrolet ((ft (string &rest args) `(format stream ,string ,@args))) (ft "~&~S is a class, it is an instance of ~S.~%" - class (pretty-class (class-of class))) + class (pretty-class (class-of class))) (let ((name (class-name class))) - (if name - (if (eq class (find-class name nil)) - (ft "Its proper name is ~S.~%" name) - (ft "Its name is ~S, but this is not a proper name.~%" name)) - (ft "It has no name (the name is NIL).~%"))) + (if name + (if (eq class (find-class name nil)) + (ft "Its proper name is ~S.~%" name) + (ft "Its name is ~S, but this is not a proper name.~%" name)) + (ft "It has no name (the name is NIL).~%"))) (ft "The direct superclasses are: ~:S, and the direct~%~ - subclasses are: ~:S. " - (mapcar #'pretty-class (class-direct-superclasses class)) - (mapcar #'pretty-class (class-direct-subclasses class))) - (if (class-finalized-p class) - (ft "The class precedence list is:~%~S~%" - (mapcar #'pretty-class (class-precedence-list class))) - (ft "The class is not finalized.~%")) - (ft "There are ~D methods specialized for this class." - (length (the list (specializer-direct-methods class)))))) - (when *describe-classes-as-objects-p* - (describe-object-slots class stream))) - - -(declaim (ftype (function (T &optional T) (values T T symbol)) - parse-method-or-spec)) -(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-symbol (format nil "~S" method)))) - (multiple-value-bind (gf-spec quals specls) - (parse-defmethod spec) - (declare (list quals specls)) - (and (setq gf (and (or errorp (gboundp gf-spec)) - (gdefinition gf-spec))) - (let ((nreq (compute-discriminating-function-arglist-info gf))) - (declare (type index nreq)) - (setq specls (append (parse-specializers specls) - (make-list (the index (- 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)))))))) - (values gf method name))) - -(defmethod copy-instance-slots ((object1 slot-object) - (object2 slot-object) - &key - (exclude-slot-names NIL)) - (let ((obj1-slot-names - (mapcar #'slot-definition-name (class-slots (class-of object1)))) - (obj2-slot-names - (mapcar #'slot-definition-name (class-slots (class-of object2))))) - (declare (type list obj1-slot-names obj2-slot-names)) - (dolist (slot-name obj1-slot-names) - (when (and (not (memq slot-name exclude-slot-names)) - (memq slot-name obj2-slot-names)) - (setf (slot-value object2 slot-name) - (slot-value object1 slot-name)))))) + subclasses are: ~:S. The class precedence list is:~%~S~%~ + There are ~D methods specialized for this class." + (mapcar #'pretty-class (class-direct-superclasses class)) + (mapcar #'pretty-class (class-direct-subclasses class)) + (mapcar #'pretty-class (class-precedence-list class)) + (length (specializer-direct-methods class))))) + (when *describe-metaobjects-as-objects-p* + (call-next-method))) + +(defun describe-package (object stream) + (unless (packagep object) (setq object (find-package object))) + (format stream "~&~S is a ~S.~%" object (type-of object)) + (let ((nick (package-nicknames object))) + (when nick + (format stream "You can also call it~@[ ~{~S~^, ~} or~] ~S.~%" + (butlast nick) (first (last nick))))) + (let* (#+cmu (internal (lisp::package-internal-symbols object)) + (internal-count #+cmu (- (lisp::package-hashtable-size internal) + (lisp::package-hashtable-free internal)) + #-cmu 0) + #+cmu (external (lisp::package-external-symbols object)) + (external-count #+cmu (- (lisp::package-hashtable-size external) + (lisp::package-hashtable-free external)) + #-cmu 0)) + #-cmu (do-external-symbols (sym object) + (declare (ignore sym)) + (incf external-count)) + #-cmu (do-symbols (sym object) + (declare (ignore sym)) + (incf internal-count)) + #-cmu (decf internal-count external-count) + (format stream "It has ~D internal and ~D external symbols (~D total).~%" + internal-count external-count (+ internal-count external-count))) + (let ((used (package-use-list object))) + (when used + (format stream "It uses the packages ~{~S~^, ~}.~%" + (mapcar #'package-name used)))) + (let ((users (package-use-list object))) + (when users + (format stream "It is used by the packages ~{~S~^, ~}.~%" + (mapcar #'package-name users))))) + +#+cmu +(defmethod describe-object ((object package) stream) + (describe-package object stream)) +#+cmu +(defmethod describe-object ((object hash-table) stream) + (format stream "~&~S is an ~a hash table." object (lisp::hash-table-kind object)) + (format stream "~&Its size is ~d buckets." (lisp::hash-table-size object)) + (format stream "~&Its rehash-size is ~d." (lisp::hash-table-rehash-size object)) + (format stream "~&Its rehash-threshold is ~d." + (lisp::hash-table-rehash-threshold object)) + (format stream "~&It currently holds ~d entries." + (lisp::hash-table-number-entries object))) + + + ;;; ;;; trace-method and untrace-method accept method specs as arguments. A ;;; method-spec should be a list like: @@ -259,119 +240,63 @@ ;;; For untrace-method, if an argument is given, that method is untraced. ;;; If no argument is given, all traced methods are untraced. ;;; +(defclass traced-method (method) + ((method :initarg :method) + (function :initarg :function + :reader method-function) + (generic-function :initform nil + :accessor method-generic-function))) -(defclass traced-method (standard-method) - ((method :initarg :method))) +(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* ()) -(defmethod trace-method ((spec cons) &rest options) - (multiple-value-bind (gf method name) +(defun trace-method (spec &rest options) + (multiple-value-bind (gf omethod name) (parse-method-or-spec spec) - (declare (ignore gf name)) - (apply #'trace-method method options))) - -(defmethod trace-method ((tmethod traced-method) &rest options) - (untrace-method tmethod) - (apply #'trace-method (slot-value tmethod 'method) options)) - -(defmethod trace-method ((method standard-method) &rest options) - (let* ((gf (method-generic-function method)) - (base-name (symbol-name (method-function-name method))) - (tmethod (make-instance 'traced-method :method method)) - (function (method-function method)) - (t-function - (if function - (trace-function-internal - function (gentemp base-name) options))) - (optimized-fn (method-optimized-function method)) - (t-optimized-fn - (if optimized-fn - (trace-function-internal - optimized-fn (gentemp base-name) options))) - (traced-function-names - (append (if function (list t-function)) - (if optimized-fn (list t-optimized-fn))))) - (declare (type simple-string base-name) - (type symbol t-function t-optimized-fn)) - (copy-instance-slots method tmethod - :exclude-slot-names - '(function optimized-function cached-functions-alist - generic-function)) - (when function - (setf (slot-value tmethod 'function) - (symbol-function t-function))) - (when optimized-fn - (setf (slot-value tmethod 'optimized-function) - (symbol-function t-optimized-fn))) - (setf (slot-value tmethod 'cached-functions-alist) - (mapcar - #'(lambda (cached-fn) - (let ((fn (cdr cached-fn))) - (cons - (car cached-fn) - (symbol-function - (the symbol - (cond ((eq fn function) t-function) - ((eq fn optimized-fn) t-optimized-fn) - (T - (let ((t-name - (trace-function-internal - fn - (gentemp base-name) - options))) - (push t-name traced-function-names) - t-name)))))))) - (slot-value method 'cached-functions-alist))) - (remove-method gf method) - (add-method gf tmethod) - (push (cons tmethod traced-function-names) *traced-methods*) - tmethod)) + (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 (method-cons-traces) - (let* ((m (car method-cons-traces)) - (gf (method-generic-function m))) - (when gf - (remove-method gf m) - (add-method gf (slot-value m 'method)))) - (untrace-method-function-names (cdr method-cons-traces)) - (setq *traced-methods* - (remove method-cons-traces *traced-methods* :test #'eq)))) - (cond ((consp spec) - (multiple-value-bind (gf method) - (parse-method-or-spec spec) - (declare (ignore gf)) - (let ((old-trace (assq method *traced-methods*))) - (if old-trace - (untrace-1 old-trace) - (error "~S is not a traced method?" method))))) - ((typep spec 'standard-method) - (let ((old-trace (assq spec *traced-methods*))) - (if old-trace - (untrace-1 old-trace) - (error "~S is not a traced method?" spec)))) - ((null spec) - (dolist (trace *traced-methods*) (untrace-1 trace))) - (T (error - "Untrace-method needs method, method specifier, or nothing."))))) - -(defun trace-function-internal (function name options) + (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) function) + (setf (symbol-function name) ofunction) (eval `(trace ,name ,@options)) - name) - -(defun untrace-method-function-names (names) - (dolist (name names) - (setf (symbol-function name) NIL)) - (eval `(untrace ,@names))) + (symbol-function name)) -(defun trace-methods (gf) - (let ((methods (generic-function-methods gf))) - (dolist (method methods) - (trace-method method)) - methods)) @@ -398,9 +323,3 @@ (pushnew :pcl *features*) (pushnew :portable-commonloops *features*) (pushnew :pcl-structures *features*) - -#+cmu -(when (find-package "OLD-PCL") - (setf (symbol-function 'old-pcl::print-object) - (symbol-function 'pcl::print-object))) - diff --git a/pcl/excl-low.lisp b/pcl/excl-low.lisp index a0361c485..54c734b4d 100644 --- a/pcl/excl-low.lisp +++ b/pcl/excl-low.lisp @@ -43,10 +43,6 @@ '(setq excl::*without-interrupts* 0))) ,.body))) -(defmacro without-interrupts-simple (&body body) - `(let ((excl::*without-interrupts* 0)) - ,.body)) - (eval-when (compile load eval) (unless (fboundp 'excl::sy_hash) (setf (symbol-function 'excl::sy_hash) @@ -67,12 +63,6 @@ (pop ,list-var) (go start)))))) -(defmacro structurep (x) - `(excl::structurep ,x)) - -(defmacro structure-type (x) - `(svref ,x 0)) - (defun std-instance-p (x) (and (excl::structurep x) (locally @@ -86,6 +76,13 @@ (declare #.*optimize-speed*) (eq (svref ,x 0) 'std-instance))))) +(excl::defcmacro fast-method-call-p (x) + (once-only (x) + `(and (excl::structurep ,x) + (locally + (declare #.*optimize-speed*) + (eq (svref ,x 0) 'fast-method-call))))) + (defmacro %std-instance-wrapper (x) `(svref ,x 1)) @@ -124,32 +121,16 @@ ;;; Define inspector hooks for PCL object instances. -;;; Due to metacircularity certain slots of metaclasses do not have normal -;;; accessors, and for now we just make them uninspectable. They could be -;;; special cased some day. - (defun (:property pcl::std-instance :inspector-function) (object) - (do* ((class (class-of object)) - (components (class-precedence-list class)) - (desc (list (inspect::make-field-def "class" #'class-of :lisp))) - (slots (slots-to-inspect class object) (cdr slots))) - ((null slots) (nreverse desc)) - (let ((name (slot-definition-name (car slots))) - res) - (push (inspect::make-field-def - (string name) - (or (block foo - (dolist (comp components) - (dolist (slot (class-direct-slots comp)) - (and (eq (slot-definition-name slot) name) - (setq res (first (slot-definition-readers slot))) - (return-from foo res))))) - #'(lambda (x) - (declare (ignore x)) - :|Uninspectable Metaclass Slot|)) - :lisp) - desc)))) + (let ((class (class-of object))) + (cons (inspect::make-field-def "class" #'class-of :lisp) + (mapcar #'(lambda (slot) + (inspect::make-field-def + (string (slot-definition-name slot)) + #'(lambda (x) + (slot-value-using-class class x slot)) + :lisp)) + (slots-to-inspect class object))))) (defun (:property pcl::std-instance :inspector-type-function) (x) (class-name (class-of x))) - diff --git a/pcl/fin.lisp b/pcl/fin.lisp index 645ad85e5..05539d32e 100644 --- a/pcl/fin.lisp +++ b/pcl/fin.lisp @@ -129,8 +129,6 @@ explicitly marked saying who wrote it. (error "Attempt to funcall a funcallable-instance without first~%~ setting its funcallable-instance-function.")) - - ;;; ;;; In Lucid Lisp, compiled functions and compiled closures have the same @@ -160,7 +158,7 @@ explicitly marked saying who wrote it. ;;; optimized version of the code for this inner closure function. ;;; (defun make-trampoline (function) - (declare (optimize (speed 3) (safety 0)(compilation-speed 0)(space 0))) + (declare (optimize (speed 3) (safety 0))) #'(lambda (&rest args) (apply function args))) @@ -170,17 +168,16 @@ explicitly marked saying who wrote it. (defun binary-assemble (codes) - (declare (list codes)) (let* ((ncodes (length codes)) (code-vec #-LCL3.0 (lucid::new-code ncodes) #+LCL3.0 (lucid::with-current-area lucid::*READONLY-NON-POINTER-AREA* (lucid::new-code ncodes)))) - (declare (type index ncodes)) + (declare (fixnum ncodes)) (do ((l codes (cdr l)) - (i 0 (the index (1+ i)))) + (i 0 (1+ i))) ((null l) nil) - (declare (type index i)) + (declare (fixnum i)) (setf (lucid::code-ref code-vec i) (car l))) code-vec)) @@ -224,10 +221,8 @@ explicitly marked saying who wrote it. (if (not (lucid::procedurep x)) (error "Can't make a non-procedure a fin.") (setf (lucid::procedure-ref x lucid::procedure-flags) - (logior (the index - (expt 2 (the index - procedure-is-funcallable-instance-bit-position))) - (the index + (logior (expt 2 procedure-is-funcallable-instance-bit-position) + (the fixnum (lucid::procedure-ref x lucid::procedure-flags)))))) @@ -238,13 +233,13 @@ explicitly marked saying who wrote it. ;incorrectly (let ((new-fin (lucid::new-procedure fin-size)) (fin-index fin-size)) - (declare (type index fin-index) + (declare (fixnum fin-index) (type lucid::procedure new-fin)) - (dotimes (i (length (the list funcallable-instance-data)) ) + (dotimes (i (length funcallable-instance-data)) ;; Initialize the new funcallable-instance. As part of our contract, ;; we have to make sure the initial value of all the funcallable ;; instance data slots is NIL. - (setf fin-index (the index (1- fin-index))) + (decf fin-index) (setf (lucid::procedure-ref new-fin fin-index) nil)) ;; ;; "Assemble" the initial function by installing a fast "trampoline" code; @@ -257,7 +252,7 @@ explicitly marked saying who wrote it. #+MIPS (progn (setf (sys:procedure-ref new-fin lucid::procedure-min-args) 0) (setf (sys:procedure-ref new-fin lucid::procedure-max-args) - (the index call-arguments-limit))) + call-arguments-limit)) ;; but start out with the function to be run as an error call. (setf (lucid::procedure-ref new-fin fin-trampoline-fun-index) #'called-fin-without-function) @@ -283,10 +278,10 @@ explicitly marked saying who wrote it. (defmacro funcallable-instance-data-1 (instance data) `(lucid::procedure-ref ,instance - (the index - (- (the index (- (the index fin-size) 1)) - (the index (funcallable-instance-data-position ,data)))))) - + (the fixnum + (- (- fin-size 1) + (the fixnum (funcallable-instance-data-position ,data)))))) + );end of #+Lucid @@ -362,7 +357,7 @@ explicitly marked saying who wrote it. (make-trampoline new-value))))) (defun make-trampoline (function) - (declare #.*optimize-speed*) + (declare (optimize (speed 3) (safety 0))) #'(lambda (&rest args) #+Genera (declare (dbg:invisible-frame :pcl-internals)) (apply function args))) @@ -886,7 +881,7 @@ dbg: ;; This function is never linked in and never appears on the stack. (defun funcallable-instance-mattress-pad () - (declare #.*optimize-speed*) + (declare (optimize (speed 3) (safety 0))) 'nil) (eval-when (eval) @@ -1077,7 +1072,7 @@ dbg: ;; This function is never linked in and never appears on the stack. (defun funcallable-instance-mattress-pad () - (declare #.*optimize-speed*) + (declare (optimize (speed 3) (safety 0))) 'nil) (eval-when (eval) @@ -1166,19 +1161,17 @@ dbg: (defun add-instance-vars (cvec old-cvec) ;; create a constant vector containing everything in the given constant ;; vector plus space for the instance variables - (let* ((nconstants (cond (cvec (length (the simple-vector cvec))) (t 0))) + (let* ((nconstants (cond (cvec (length cvec)) (t 0))) (ndata (length funcallable-instance-data)) - (old-cvec-length (if old-cvec (length (the simple-vector old-cvec)) 0)) + (old-cvec-length (if old-cvec (length old-cvec) 0)) (new-cvec nil)) - (declare (fixnum nconstants ndate old-cvec-length)) - (cond ((<= (the fixnum (+ nconstants ndata)) old-cvec-length) + (cond ((<= (+ nconstants ndata) old-cvec-length) (setq new-cvec old-cvec)) (t - (setq new-cvec (make-array (the fixnum (+ nconstants ndata)))) + (setq new-cvec (make-array (+ nconstants ndata))) (when old-cvec (dotimes (i ndata) - (declare (fixnum i)) - (setf (svref new-cvec (- (the fixnum (+ nconstants ndata)) i 1)) + (setf (svref new-cvec (- (+ nconstants ndata) i 1)) (svref old-cvec (- old-cvec-length i 1))))))) (dotimes (i nconstants) (setf (svref new-cvec i) (svref cvec i))) @@ -1187,11 +1180,8 @@ dbg: (defun funcallable-instance-data-1 (instance data) (let ((constant (excl::fn_constant instance))) - (declare (simple-vector constant)) - (svref constant (- (the fixnum (length constant)) - (the fixnum - (1+ (the fixnum - (funcallable-instance-data-position data)))))))) + (svref constant (- (length constant) + (1+ (funcallable-instance-data-position data)))))) (defsetf funcallable-instance-data-1 set-funcallable-instance-data-1) @@ -1367,9 +1357,9 @@ dbg: (defmacro funcallable-instance-data-1 (fin slot) (if (constantp slot) `(sys:%primitive c:closure-ref ,fin - (+ (or (position ,slot funcallable-instance-data) - (error "Unknown slot: ~S." ,slot)) - fin-data-offset)) + ,(+ (or (position (eval slot) funcallable-instance-data) + (error "Unknown slot: ~S." (eval slot))) + fin-data-offset)) (ext:once-only ((n-slot slot)) `(kernel:%closure-index-ref ,fin @@ -1384,9 +1374,13 @@ dbg: `(progn (kernel:%set-funcallable-instance-info ,n-fin - (+ (or (position ,n-slot funcallable-instance-data) - (error "Unknown slot: ~S." ,n-slot)) - fin-data-offset) + ,(if (constantp slot) + (+ (or (position (eval slot) funcallable-instance-data) + (error "Unknown slot: ~S." (eval slot))) + fin-data-offset) + `(+ (or (position ,n-slot funcallable-instance-data) + (error "Unknown slot: ~S." ,n-slot)) + fin-data-offset)) ,n-val) ,n-val))) ;;; @@ -1452,8 +1446,8 @@ dbg: ((not (functionp new-value)) (error "~S is not a function." new-value)) ((and (cclosurep new-value) - (<= (the index (length (the list (%cclosure-env new-value)))) - (the index funcallable-instance-available-size))) + (<= (length (%cclosure-env new-value)) + funcallable-instance-available-size)) (%set-cclosure fin new-value funcallable-instance-available-size)) (t (set-funcallable-instance-function @@ -1466,14 +1460,12 @@ dbg: (let* ((pos-form (macroexpand `(funcallable-instance-data-position ,data) env)) (index-form (if (constantp pos-form) - (the index - (- (the index funcallable-instance-closure-size) - (the index (eval pos-form)) - 2)) - `(the index - (- (the index funcallable-instance-closure-size) - (the index (funcallable-instance-data-position ,data)) - 2))))) + (- funcallable-instance-closure-size + (eval pos-form) + 2) + `(- funcallable-instance-closure-size + (funcallable-instance-data-position ,data) + 2)))) `(car (%cclosure-env-nthcdr ,index-form ,fin)))) @@ -1966,13 +1958,5 @@ make_turbo_trampoline_internal(base0) (defmacro fsc-instance-slots (fin) `(funcallable-instance-data-1 ,fin 'slots)) -(defun allocate-funcallable-instance (wrapper allocate-static-slot-storage-copy) - (declare (type simple-vector allocate-static-slot-storage-copy)) - (let ((fin (allocate-funcallable-instance-1)) - (slots - (%allocate-static-slot-storage--class - allocate-static-slot-storage-copy))) - (setf (fsc-instance-wrapper fin) wrapper - (fsc-instance-slots fin) slots) - fin)) + diff --git a/pcl/fixup.lisp b/pcl/fixup.lisp index 2ca36d380..aecddc5b3 100644 --- a/pcl/fixup.lisp +++ b/pcl/fixup.lisp @@ -38,4 +38,3 @@ (declare (ignore depth)) (print-object instance stream)) - diff --git a/pcl/fngen.lisp b/pcl/fngen.lisp index d5e97c8a5..e54dad9b3 100644 --- a/pcl/fngen.lisp +++ b/pcl/fngen.lisp @@ -28,11 +28,26 @@ (in-package 'pcl) ;;; -;;; GET-FUNCTION is the main user interface to this code. If it is called -;;; with a lambda expression only, it will return a corresponding function. -;;; The optional constant-converter argument, can be a function which will -;;; be called to convert each constant appearing in the lambda to whatever -;;; value should appear in the function. +;;; GET-FUNCTION is the main user interface to this code. It is like +;;; COMPILE-LAMBDA, only more efficient. It achieves this efficiency by +;;; reducing the number of times that the compiler needs to be called. +;;; Calls to GET-FUNCTION in which the lambda forms differ only by constants +;;; can use the same piece of compiled code. (For example, dispatch dfuns and +;;; combined method functions can often be shared, if they differ only +;;; by referring to different methods.) +;;; +;;; If GET-FUNCTION is called with a lambda expression only, it will return +;;; a corresponding function. The optional constant-converter argument +;;; can be a function which will be called to convert each constant appearing +;;; in the lambda to whatever value should appear in the function. +;;; +;;; There are three internal functions which operate on the lambda argument +;;; to GET-FUNCTION: +;;; compute-test converts the lambda into a key to be used for lookup, +;;; compute-code is used by get-new-function-generator-internal to +;;; generate the actual lambda to be compiled, and +;;; compute-constants is used to generate the argument list that is +;;; to be passed to the compiled function. ;;; ;;; Whether the returned function is actually compiled depends on whether ;;; the compiler is present (see COMPILE-LAMBDA) and whether this shape of @@ -42,33 +57,29 @@ &optional (test-converter #'default-test-converter) (code-converter #'default-code-converter) (constant-converter #'default-constant-converter)) - (apply-function (get-function-generator lambda test-converter code-converter) + (function-apply (get-function-generator lambda test-converter code-converter) (compute-constants lambda constant-converter))) -(declaim (ftype (function (T &optional T T T) (values function T)) - get-function1)) (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)) + (values (the function (get-function-generator lambda test-converter code-converter)) (compute-constants lambda constant-converter))) (defun default-constantp (form) (and (constantp form) - (not (symbolp (eval form))))) + (not (typep (eval form) '(or symbol fixnum))))) (defun default-test-converter (form) (if (default-constantp form) '.constant. form)) -(declaim (ftype (function (T) (values T list)) default-code-converter)) (defun default-code-converter (form) (if (default-constantp form) (let ((gensym (gensym))) (values gensym (list gensym))) - (values form nil))) + form)) (defun default-constant-converter (form) (if (default-constantp form) @@ -84,7 +95,12 @@ (defvar *fgens* ()) (defun store-fgen (fgen) - (setq *fgens* (nconc *fgens* (list 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))) + (setq *fgens* (nconc *fgens* (list fgen)))))) (defun lookup-fgen (test) (find test (the list *fgens*) :key #'fgen-test :test #'equal)) @@ -113,10 +129,6 @@ (fgen-generator fgen) (get-new-function-generator lambda test code-converter)))) -(declaim (ftype (function (T T) (values T list)) - get-new-function-generator-internal - compute-code)) - (defun get-new-function-generator (lambda test code-converter) (multiple-value-bind (gensyms generator-lambda) (get-new-function-generator-internal lambda code-converter) @@ -180,20 +192,22 @@ ;;; ;;; (defmacro precompile-function-generators (&optional system) - (make-top-level-form `(precompile-function-generators ,system) - '(load) + (let ((index -1)) `(progn ,@(gathering1 (collecting) (dolist (fgen *fgens*) (when (or (null (fgen-system fgen)) (eq (fgen-system fgen) system)) (when system (setf (svref fgen 4) system)) (gather1 - `(load-function-generator - ',(fgen-test fgen) - ',(fgen-gensyms fgen) - (function ,(fgen-generator-lambda fgen)) - ',(fgen-generator-lambda fgen) - ',system)))))))) + (make-top-level-form + `(precompile-function-generators ,system ,(incf index)) + '(load) + `(load-function-generator + ',(fgen-test fgen) + ',(fgen-gensyms fgen) + (function ,(fgen-generator-lambda fgen)) + ',(fgen-generator-lambda fgen) + ',system))))))))) (defun load-function-generator (test gensyms generator generator-lambda system) (store-fgen (make-fgen test gensyms generator generator-lambda system))) diff --git a/pcl/fsc.lisp b/pcl/fsc.lisp index d2f3ab7ec..1a68a86d5 100644 --- a/pcl/fsc.lisp +++ b/pcl/fsc.lisp @@ -47,7 +47,7 @@ 'fsc-instance-slots) (defmethod raw-instance-allocator ((class funcallable-standard-class)) - 'allocate-funcallable-instance-1) + 'allocate-funcallable-instance) ;;; ;;; @@ -63,48 +63,15 @@ ((class funcallable-standard-class) &rest initargs) (declare (ignore initargs)) (unless (class-finalized-p class) (finalize-inheritance class)) - (let ((class-wrapper (class-wrapper class))) - (allocate-funcallable-instance - class-wrapper (wrapper-allocate-static-slot-storage-copy class-wrapper)))) + (allocate-funcallable-instance (class-wrapper class))) -(defmethod make-optimized-reader-method-function - ((class funcallable-standard-class) - generic-function - reader-method-prototype - slot-name) - (declare (ignore generic-function reader-method-prototype)) - (make-funcallable-standard-instance-reader-method-function slot-name)) +(defmethod make-reader-method-function ((class funcallable-standard-class) + slot-name) + (make-std-reader-method-function (class-name class) slot-name)) -(defmethod make-optimized-writer-method-function - ((class funcallable-standard-class) - generic-function - writer-method-prototype - slot-name) - (declare (ignore generic-function writer-method-prototype)) - (make-funcallable-standard-instance-writer-method-function slot-name)) - -(defmethod make-optimized-boundp-method-function - ((class funcallable-standard-class) - generic-function - boundp-method-prototype - slot-name) - (declare (ignore generic-function boundp-method-prototype)) - (make-funcallable-standard-instance-boundp-method-function slot-name)) - -(defun make-funcallable-standard-instance-reader-method-function (slot-name) - (declare #.*optimize-speed*) - #'(lambda (instance) - (funcallable-standard-instance-slot-value instance slot-name))) - -(defun make-funcallable-standard-instance-writer-method-function (slot-name) - (declare #.*optimize-speed*) - #'(lambda (nv instance) - (setf (funcallable-standard-instance-slot-value instance slot-name) nv))) - -(defun make-funcallable-standard-instance-boundp-method-function (slot-name) - (declare #.*optimize-speed*) - #'(lambda (instance) - (funcallable-standard-instance-slot-boundp instance slot-name))) +(defmethod make-writer-method-function ((class funcallable-standard-class) + slot-name) + (make-std-writer-method-function (class-name class) slot-name)) ;;;; ;;;; See the comment about reader-function--std and writer-function--sdt. diff --git a/pcl/genera-low.lisp b/pcl/genera-low.lisp index 90f94b0de..71c939d13 100644 --- a/pcl/genera-low.lisp +++ b/pcl/genera-low.lisp @@ -274,7 +274,7 @@ compiler:: specializers lambda-list doc - (getf plist :isl-cache-symbol) + (getf plist :pv-table-cache-symbol) plist fn))) ||# diff --git a/pcl/generic-functions.lisp b/pcl/generic-functions.lisp index 74b2b47b7..8b02e13b1 100644 --- a/pcl/generic-functions.lisp +++ b/pcl/generic-functions.lisp @@ -2,314 +2,776 @@ (in-package :pcl) -;;; 1 arguments -(defgeneric accessor-method-slot-definition (method)) -(defgeneric accessor-method-slot-name (standard-accessor-method)) -(defgeneric |BUILT-IN-CLASS class predicate| (object)) -(defgeneric class-cached-in-generic-functions (pcl-class)) +;;; class predicates +(defgeneric class-eq-specializer-p (object)) +; (t) +; (class-eq-specializer) + +(defgeneric classp (object)) +; (t) +; (class) + +(defgeneric eql-specializer-p (object)) +; (t) +; (eql-specializer) + +(defgeneric exact-class-specializer-p (object)) +; (t) +; (exact-class-specializer) + +(defgeneric forward-referenced-class-p (object)) +; (t) +; (forward-referenced-class) + +(defgeneric funcallable-standard-class-p (object)) +; (t) +; (funcallable-standard-class) + +(defgeneric generic-function-p (object)) +; (t) +; (generic-function) + +(defgeneric legal-lambda-list-p (object x)) +; (standard-method t) + +(defgeneric method-combination-p (object)) +; (t) +; (method-combination) + +(defgeneric method-p (object)) +; (t) +; (method) + +(defgeneric short-method-combination-p (object)) +; (short-method-combination) +; (t) + +(defgeneric slot-class-p (object)) +; (t) +; (slot-class) + +(defgeneric specializerp (object)) +; (t) +; (specializer) + +(defgeneric standard-accessor-method-p (object)) +; (t) +; (standard-accessor-method) + +(defgeneric standard-boundp-method-p (object)) +; (t) +; (standard-boundp-method) + +(defgeneric standard-class-p (object)) +; (t) +; (standard-class) + +(defgeneric standard-generic-function-p (object)) +; (t) +; (standard-generic-function) + +(defgeneric standard-method-p (object)) +; (t) +; (standard-method) + +(defgeneric standard-reader-method-p (object)) +; (t) +; (standard-reader-method) + +(defgeneric standard-writer-method-p (object)) +; (t) +; (standard-writer-method) + +(defgeneric structure-class-p (object)) +; (t) +; (structure-class) + + +;;; readers +(defgeneric accessor-method-slot-definition (standard-accessor-method)) +; (standard-accessor-method) + (defgeneric class-can-precede-list (pcl-class)) -(defgeneric class-constructors (class)) -(defgeneric class-default-initargs (class)) -(defgeneric class-defstruct-conc-name (structure-class)) +; (pcl-class) + (defgeneric class-defstruct-constructor (structure-class)) -(defgeneric class-direct-default-initargs (class)) -(defgeneric class-direct-slots (class)) +; (structure-class) + +(defgeneric class-defstruct-form (structure-class)) +; (structure-class) + (defgeneric class-direct-subclasses (class)) +; (class) + (defgeneric class-direct-superclasses (class)) -(defgeneric class-eq-specializer (pcl-class)) -(defgeneric class-eq-specializer-p (object)) -(defgeneric class-finalized-p (class)) -(defgeneric class-from-defclass-p (structure-class)) +; (class) + +(defgeneric class-eq-specializer (class)) +; (class) + (defgeneric class-incompatible-superclass-list (pcl-class)) -(defgeneric class-internal-slotds (pcl-class)) +; (pcl-class) + +(defgeneric class-initialize-info (slot-class)) +; (slot-class) + (defgeneric class-name (class)) -(defgeneric class-precedence-list (class)) -(defgeneric class-predicate-name (pcl-class)) -(defgeneric class-prototype (class)) -(defgeneric class-side-effect-internal-slotds (slot-class)) -(defgeneric class-slot-cells (class)) -(defgeneric class-slots (class)) +; (class) + +(defgeneric class-precedence-list (pcl-class)) +; (pcl-class) + +(defgeneric class-predicate-name (class)) +; (class) + (defgeneric class-wrapper (pcl-class)) -(defgeneric classp (object)) -(defgeneric compute-class-precedence-list (root)) -(defgeneric compute-default-initargs (class)) -(defgeneric compute-discriminating-function (gf)) -(defgeneric compute-discriminating-function-arglist-info (generic-function)) -(defgeneric compute-slots (class)) -(defgeneric constructor-class (constructor)) -(defgeneric constructor-code-generators (constructor)) -(defgeneric constructor-code-type (constructor)) -(defgeneric constructor-name (constructor)) -(defgeneric constructor-supplied-initarg-names (constructor)) +; (pcl-class) + (defgeneric definition-source (definition-source-mixin)) -(defgeneric |DEFINITION-SOURCE-MIXIN class predicate| (object)) -(defgeneric dependent (updater)) -(defgeneric |DEPENDENT-UPDATE-MIXIN class predicate| (object)) -(defgeneric |DIRECT-SLOT-DEFINITION class predicate| (object)) -(defgeneric |DOCUMENTATION-MIXIN class predicate| (object)) -(defgeneric |EFFECTIVE-SLOT-DEFINITION class predicate| (object)) +; (definition-source-mixin) + (defgeneric eql-specializer-object (eql-specializer)) -(defgeneric eql-specializer-p (object)) -(defgeneric exact-class-specializer-p (object)) -(defgeneric finalize-inheritance (class)) -(defgeneric forward-referenced-class-p (object)) -(defgeneric funcallable-standard-class-p (object)) -(defgeneric function-keywords (method)) -(defgeneric generic-function-argument-precedence-order (standard-generic-function)) -(defgeneric generic-function-declarations (standard-generic-function)) -(defgeneric generic-function-lambda-list (standard-generic-function)) +; (eql-specializer) + (defgeneric generic-function-method-class (standard-generic-function)) +; (standard-generic-function) + (defgeneric generic-function-method-combination (standard-generic-function)) +; (standard-generic-function) + (defgeneric generic-function-methods (standard-generic-function)) +; (standard-generic-function) + (defgeneric generic-function-name (standard-generic-function)) -(defgeneric generic-function-p (object)) -(defgeneric generic-function-pretty-arglist (generic-function)) +; (standard-generic-function) + (defgeneric gf-arg-info (standard-generic-function)) +; (standard-generic-function) + (defgeneric gf-dfun-state (standard-generic-function)) +; (standard-generic-function) + (defgeneric gf-pretty-arglist (standard-generic-function)) -(defgeneric gf-valid-p (standard-generic-function)) -(defgeneric initialize-allocate-static-slot-storage-copy (class)) -(defgeneric initialize-internal-slot-functions (slotd)) -(defgeneric install-lazy-constructor-installer (constructor)) +; (standard-generic-function) + (defgeneric long-method-combination-function (long-method-combination)) -(defgeneric make-class-prototype (class)) -(defgeneric make-instances-obsolete (class)) -(defgeneric |METAOBJECT class predicate| (object)) -(defgeneric method-cached-functions (method)) -(defgeneric method-cached-functions-alist (standard-method)) -(defgeneric method-closure-generator (standard-method)) +; (long-method-combination) + +(defgeneric method-combination-documentation (standard-method-combination)) +; (standard-method-combination) + (defgeneric method-combination-options (standard-method-combination)) -(defgeneric method-combination-p (object)) +; (standard-method-combination) + (defgeneric method-combination-type (standard-method-combination)) -(defgeneric method-constant-value (method)) -(defgeneric method-function (standard-method)) -(defgeneric method-function-for-caching-p (method)) -(defgeneric method-function-name (standard-method)) +; (standard-method-combination) + +(defgeneric method-fast-function (standard-method)) +; (standard-method) + (defgeneric method-generic-function (standard-method)) -(defgeneric method-identifier (standard-method)) -(defgeneric method-lambda-list (standard-method)) -(defgeneric method-needs-next-methods-p (standard-method)) -(defgeneric method-optimized-function (standard-method)) -(defgeneric method-optimized-method-lambda (standard-method)) -(defgeneric method-optimized-slot-indices (standard-method)) -(defgeneric method-p (object)) -(defgeneric method-pretty-arglist (method)) -(defgeneric method-qualifiers (method)) -(defgeneric method-specializers (standard-method)) +; (traced-method) +; (standard-method) + (defgeneric object-plist (plist-mixin)) -(defgeneric |PCL-CLASS class predicate| (object)) -(defgeneric |PLIST-MIXIN class predicate| (object)) -(defgeneric raw-instance-allocator (class)) +; (plist-mixin) + (defgeneric short-combination-identity-with-one-argument (short-method-combination)) +; (short-method-combination) + (defgeneric short-combination-operator (short-method-combination)) -(defgeneric short-method-combination-p (object)) -(defgeneric |SLOT-CLASS class predicate| (object)) -(defgeneric |SLOT-DEFINITION class predicate| (object)) -(defgeneric slot-definition-allocation (standard-slot-definition)) +; (short-method-combination) + (defgeneric slot-definition-boundp-function (effective-slot-definition)) +; (effective-slot-definition) + (defgeneric slot-definition-class (slot-definition)) +; (slot-definition) + (defgeneric slot-definition-defstruct-accessor-symbol (structure-slot-definition)) +; (structure-slot-definition) + (defgeneric slot-definition-initargs (slot-definition)) +; (slot-definition) + (defgeneric slot-definition-initform (slot-definition)) +; (slot-definition) + (defgeneric slot-definition-initfunction (slot-definition)) -(defgeneric slot-definition-initfunction-side-effect-free-p (slot-definition)) +; (slot-definition) + (defgeneric slot-definition-internal-reader-function (structure-slot-definition)) -(defgeneric slot-definition-internal-slotd (effective-slot-definition)) +; (structure-slot-definition) + (defgeneric slot-definition-internal-writer-function (structure-slot-definition)) -(defgeneric slot-definition-location (effective-slot-definition)) +; (structure-slot-definition) + +(defgeneric slot-definition-location (standard-effective-slot-definition)) +; (standard-effective-slot-definition) + (defgeneric slot-definition-name (slot-definition)) +; (slot-definition) + (defgeneric slot-definition-reader-function (effective-slot-definition)) +; (effective-slot-definition) + (defgeneric slot-definition-readers (slot-definition)) +; (slot-definition) + (defgeneric slot-definition-type (slot-definition)) +; (slot-definition) + (defgeneric slot-definition-writer-function (effective-slot-definition)) +; (effective-slot-definition) + (defgeneric slot-definition-writers (slot-definition)) -(defgeneric |SLOT-OBJECT class predicate| (object)) +; (slot-definition) + +(defgeneric specializer-object (class-eq-specializer)) +; (eql-specializer) +; (class-prototype-specializer) +; (class-eq-specializer) + +(defgeneric specializer-type (specializer)) +; (specializer) + + +;;; writers +(defgeneric (setf class-defstruct-constructor) (new-value structure-class)) +; (t structure-class) + +(defgeneric (setf class-defstruct-form) (new-value structure-class)) +; (t structure-class) + +(defgeneric (setf class-direct-slots) (new-value slot-class)) +; (t slot-class) + +(defgeneric (setf class-incompatible-superclass-list) (new-value pcl-class)) +; (t pcl-class) + +(defgeneric (setf class-initialize-info) (new-value slot-class)) +; (t slot-class) + +(defgeneric (setf class-name) (new-value class)) +; (t class) + +(defgeneric (setf class-slots) (new-value slot-class)) +; (t slot-class) + +(defgeneric (setf generic-function-method-class) (new-value standard-generic-function)) +; (t standard-generic-function) + +(defgeneric (setf generic-function-method-combination) (new-value standard-generic-function)) +; (t standard-generic-function) + +(defgeneric (setf generic-function-methods) (new-value standard-generic-function)) +; (t standard-generic-function) + +(defgeneric (setf generic-function-name) (new-value standard-generic-function)) +; (t standard-generic-function) + +(defgeneric (setf gf-dfun-state) (new-value standard-generic-function)) +; (t standard-generic-function) + +(defgeneric (setf gf-pretty-arglist) (new-value standard-generic-function)) +; (t standard-generic-function) + +(defgeneric (setf method-generic-function) (new-value standard-method)) +; (t traced-method) +; (t standard-method) + +(defgeneric (setf object-plist) (new-value plist-mixin)) +; (t plist-mixin) + +(defgeneric (setf slot-definition-allocation) (new-value standard-slot-definition)) +; (t standard-slot-definition) + +(defgeneric (setf slot-definition-boundp-function) (new-value effective-slot-definition)) +; (t effective-slot-definition) + +(defgeneric (setf slot-definition-class) (new-value slot-definition)) +; (t slot-definition) + +(defgeneric (setf slot-definition-defstruct-accessor-symbol) (new-value structure-slot-definition)) +; (t structure-slot-definition) + +(defgeneric (setf slot-definition-initargs) (new-value slot-definition)) +; (t slot-definition) + +(defgeneric (setf slot-definition-initform) (new-value slot-definition)) +; (t slot-definition) + +(defgeneric (setf slot-definition-initfunction) (new-value slot-definition)) +; (t slot-definition) + +(defgeneric (setf slot-definition-internal-reader-function) (new-value structure-slot-definition)) +; (t structure-slot-definition) + +(defgeneric (setf slot-definition-internal-writer-function) (new-value structure-slot-definition)) +; (t structure-slot-definition) + +(defgeneric (setf slot-definition-location) (new-value standard-effective-slot-definition)) +; (t standard-effective-slot-definition) + +(defgeneric (setf slot-definition-name) (new-value slot-definition)) +; (t slot-definition) + +(defgeneric (setf slot-definition-reader-function) (new-value effective-slot-definition)) +; (t effective-slot-definition) + +(defgeneric (setf slot-definition-readers) (new-value slot-definition)) +; (t slot-definition) + +(defgeneric (setf slot-definition-type) (new-value slot-definition)) +; (t slot-definition) + +(defgeneric (setf slot-definition-writer-function) (new-value effective-slot-definition)) +; (t effective-slot-definition) + +(defgeneric (setf slot-definition-writers) (new-value slot-definition)) +; (t slot-definition) + + +;;; 1 argument +(defgeneric accessor-method-class (method)) +; (standard-accessor-method) +; (standard-writer-method) + +(defgeneric accessor-method-slot-name (m)) +; (traced-method) +; (standard-accessor-method) + +(defgeneric class-constructors (class)) +; (slot-class) + +(defgeneric class-default-initargs (class)) +; (slot-class) +; (built-in-class) + +(defgeneric class-direct-default-initargs (class)) +; (slot-class) +; (built-in-class) + +(defgeneric class-direct-slots (class)) +; (slot-class) +; (built-in-class) + +(defgeneric class-finalized-p (class)) +; (pcl-class) + +(defgeneric class-prototype (class)) +; (pcl-class) +; (std-class) +; (structure-class) + +(defgeneric class-slot-cells (class)) +; (std-class) + +(defgeneric class-slots (class)) +; (slot-class) +; (built-in-class) + +(defgeneric compute-class-precedence-list (root)) +; (slot-class) + +(defgeneric compute-default-initargs (class)) +; (slot-class) + +(defgeneric compute-discriminating-function (gf)) +; (standard-generic-function) + +(defgeneric compute-discriminating-function-arglist-info (generic-function)) +; (standard-generic-function) + +(defgeneric compute-slots (class)) +; (std-class) +; :around (std-class) +; (structure-class) +; :around (structure-class) + +(defgeneric finalize-inheritance (class)) +; (structure-class) +; (std-class) + +(defgeneric function-keywords (method)) +; (standard-method) + +(defgeneric generic-function-lambda-list (gf)) +; (generic-function) + +(defgeneric generic-function-pretty-arglist (generic-function)) +; (standard-generic-function) + +(defgeneric gf-fast-method-function-p (gf)) +; (standard-generic-function) + +(defgeneric initialize-internal-slot-functions (slotd)) +; (effective-slot-definition) + +(defgeneric make-instances-obsolete (class)) +; (std-class) +; (symbol) + +(defgeneric method-function (method)) +; (traced-method) +; (standard-method) + +(defgeneric method-lambda-list (m)) +; (traced-method) +; (standard-method) + +(defgeneric method-pretty-arglist (method)) +; (standard-method) + +(defgeneric method-qualifiers (m)) +; (traced-method) +; (standard-method) + +(defgeneric method-specializers (m)) +; (traced-method) +; (standard-method) + +(defgeneric raw-instance-allocator (class)) +; (standard-class) +; (funcallable-standard-class) + +(defgeneric slot-definition-allocation (slotd)) +; (standard-slot-definition) +; (structure-slot-definition) + (defgeneric slots-fetcher (class)) +; (standard-class) +; (funcallable-standard-class) + (defgeneric specializer-class (specializer)) +; (class-prototype-specializer) +; (class-eq-specializer) +; (class) +; (eql-specializer) + (defgeneric specializer-direct-generic-functions (specializer)) +; (class) +; (specializer-with-object) + (defgeneric specializer-direct-methods (specializer)) +; (class) +; (specializer-with-object) + (defgeneric specializer-method-table (specializer)) -(defgeneric specializer-object (class-eq-specializer)) -(defgeneric specializer-type (specializer)) -(defgeneric |SPECIALIZER-WITH-OBJECT class predicate| (object)) -(defgeneric specializerp (object)) -(defgeneric standard-accessor-method-p (object)) -(defgeneric standard-boundp-method-p (object)) -(defgeneric standard-class-p (object)) -(defgeneric |STANDARD-DIRECT-SLOT-DEFINITION class predicate| (object)) -(defgeneric |STANDARD-EFFECTIVE-SLOT-DEFINITION class predicate| (object)) -(defgeneric standard-generic-function-p (object)) -(defgeneric standard-method-p (object)) -(defgeneric |STANDARD-OBJECT class predicate| (object)) -(defgeneric standard-reader-method-p (object)) -(defgeneric |STANDARD-SLOT-DEFINITION class predicate| (object)) -(defgeneric standard-writer-method-p (object)) -(defgeneric |STD-CLASS class predicate| (object)) -(defgeneric structure-class-p (object)) -(defgeneric |STRUCTURE-DIRECT-SLOT-DEFINITION class predicate| (object)) -(defgeneric |STRUCTURE-EFFECTIVE-SLOT-DEFINITION class predicate| (object)) -(defgeneric |STRUCTURE-OBJECT class predicate| (object)) -(defgeneric |STRUCTURE-SLOT-DEFINITION class predicate| (object)) +; (eql-specializer) +; (class-eq-specializer) + (defgeneric update-constructors (class)) +; (slot-class) +; (class) + (defgeneric wrapper-fetcher (class)) +; (standard-class) +; (funcallable-standard-class) + ;;; 2 arguments -(defgeneric add-constructor (class constructor)) (defgeneric add-dependent (metaobject dependent)) +; (dependent-update-mixin t) + (defgeneric add-direct-method (specializer method)) +; (class method) +; (specializer-with-object method) + (defgeneric add-direct-subclass (class subclass)) +; (class class) + (defgeneric add-method (generic-function method)) -(defgeneric cached-slot-locations-and-fetchers-from-wrappers (method wrappers)) +; (standard-generic-function method) + (defgeneric change-class (instance new-class-name)) -(defgeneric (setf class-incompatible-superclass-list) (new-value pcl-class)) -(defgeneric (setf class-name) (new-value class)) +; (standard-object standard-class) +; (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) + (defgeneric compute-applicable-methods (generic-function arguments)) +; (generic-function t) + (defgeneric compute-applicable-methods-using-classes (generic-function classes)) -(defgeneric compute-class-slots (class eslotds)) -(defgeneric compute-constructor-code (class constructor)) +; (generic-function t) + +(defgeneric compute-effective-slot-definition (class dslotds)) +; (slot-class t) + (defgeneric compute-effective-slot-definition-initargs (class direct-slotds)) -(defgeneric compute-instance-layout (class instance-eslotds)) -(defgeneric compute-storage-info (class eslotds)) -(defgeneric (setf constructor-code-type) (new-value constructor)) -(defgeneric describe-object (class stream)) +; (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) +; (slot-object t) +; (t t) + (defgeneric direct-slot-definition-class (class initargs)) +; (structure-class t) +; (std-class t) + (defgeneric effective-slot-definition-class (class initargs)) -(defgeneric (setf generic-function-method-class) (new-value standard-generic-function)) -(defgeneric (setf generic-function-method-combination) (new-value standard-generic-function)) -(defgeneric (setf generic-function-methods) (new-value standard-generic-function)) -(defgeneric (setf generic-function-name) (new-value standard-generic-function)) -(defgeneric (setf gf-dfun-state) (new-value standard-generic-function)) -(defgeneric (setf gf-pretty-arglist) (new-value standard-generic-function)) -(defgeneric (setf gf-valid-p) (new-value standard-generic-function)) +; (std-class t) +; (structure-class t) + (defgeneric inform-type-system-about-class (class name)) -(defgeneric legal-declarations-p (object x)) +; (std-class t) +; (structure-class t) + (defgeneric legal-documentation-p (object x)) -(defgeneric legal-lambda-list-p (object x)) +; (standard-method t) + (defgeneric legal-method-function-p (object x)) +; (standard-method t) + (defgeneric legal-qualifier-p (object x)) +; (standard-method t) + (defgeneric legal-qualifiers-p (object x)) +; (standard-method t) + (defgeneric legal-slot-name-p (object x)) +; (standard-method t) + (defgeneric legal-specializer-p (object x)) +; (standard-method t) + (defgeneric legal-specializers-p (object x)) -(defgeneric make-cached-method-function-from-stored-lambda (method slot-locations-and-fetchers)) -(defgeneric make-cached-method-lambda-from-stored-lambda (method slot-locations-and-fetchers)) +; (standard-method t) + +(defgeneric make-boundp-method-function (class slot-name)) +; (slot-class t) + +(defgeneric make-reader-method-function (class slot-name)) +; (slot-class t) +; (funcallable-standard-class t) + +(defgeneric make-writer-method-function (class slot-name)) +; (slot-class t) +; (funcallable-standard-class t) + (defgeneric map-dependents (metaobject function)) +; (dependent-update-mixin t) + (defgeneric maybe-update-constructors (generic-function method)) -(defgeneric (setf method-cached-functions-alist) (new-value standard-method)) -(defgeneric method-function-for-caching (method wrappers)) -(defgeneric (setf method-function-name) (new-value standard-method)) -(defgeneric (setf method-generic-function) (new-value standard-method)) -(defgeneric (setf method-optimized-function) (new-value standard-method)) -(defgeneric (setf object-plist) (new-value plist-mixin)) -(defgeneric print-object (constructor stream)) +; (generic-function method) + +(defgeneric print-object (mc stream)) +; (t t) +; (class t) +; (slot-definition t) +; (standard-method t) +; (standard-accessor-method t) +; (generic-function t) +; (standard-method-combination t) + (defgeneric remove-boundp-method (class generic-function)) -(defgeneric remove-constructor (class constructor)) +; (slot-class t) + (defgeneric remove-dependent (metaobject dependent)) +; (dependent-update-mixin t) + (defgeneric remove-direct-method (specializer method)) +; (class method) +; (specializer-with-object method) + (defgeneric remove-direct-subclass (class subclass)) +; (class class) + (defgeneric remove-method (generic-function method)) +; (standard-generic-function method) + (defgeneric remove-reader-method (class generic-function)) +; (slot-class t) + (defgeneric remove-writer-method (class generic-function)) +; (slot-class t) + (defgeneric same-specializer-p (specl1 specl2)) +; (specializer specializer) +; (class class) +; (class-eq-specializer class-eq-specializer) +; (eql-specializer eql-specializer) + (defgeneric slot-accessor-function (slotd type)) +; (effective-slot-definition t) + (defgeneric slot-accessor-std-p (slotd type)) -(defgeneric (setf slot-definition-allocation) (new-value standard-slot-definition)) -(defgeneric (setf slot-definition-boundp-function) (new-value effective-slot-definition)) -(defgeneric (setf slot-definition-class) (new-value slot-definition)) -(defgeneric (setf slot-definition-defstruct-accessor-symbol) (new-value structure-slot-definition)) -(defgeneric (setf slot-definition-initargs) (new-value slot-definition)) -(defgeneric (setf slot-definition-initform) (new-value slot-definition)) -(defgeneric (setf slot-definition-initfunction) (new-value slot-definition)) -(defgeneric (setf slot-definition-initfunction-side-effect-free-p) (new-value slot-definition)) -(defgeneric (setf slot-definition-internal-reader-function) (new-value structure-slot-definition)) -(defgeneric (setf slot-definition-internal-slotd) (new-value effective-slot-definition)) -(defgeneric (setf slot-definition-internal-writer-function) (new-value structure-slot-definition)) -(defgeneric (setf slot-definition-location) (new-value effective-slot-definition)) -(defgeneric (setf slot-definition-name) (new-value slot-definition)) -(defgeneric (setf slot-definition-reader-function) (new-value effective-slot-definition)) -(defgeneric (setf slot-definition-readers) (new-value slot-definition)) -(defgeneric (setf slot-definition-type) (new-value slot-definition)) -(defgeneric (setf slot-definition-writer-function) (new-value effective-slot-definition)) -(defgeneric (setf slot-definition-writers) (new-value slot-definition)) +; (effective-slot-definition t) + (defgeneric slots-to-inspect (class object)) +; (slot-class slot-object) + (defgeneric update-gf-dfun (class gf)) +; (std-class t) + (defgeneric validate-superclass (fsc class)) +; (class class) +; (class built-in-class) +; (slot-class forward-referenced-class) +; (funcallable-standard-class standard-class) + ;;; 3 arguments +(defgeneric add-boundp-method (class generic-function slot-name)) +; (slot-class t t) + +(defgeneric add-reader-method (class generic-function slot-name)) +; (slot-class t t) + +(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) + (defgeneric compute-effective-method (generic-function combin applicable-methods)) -(defgeneric compute-effective-slot-definition (class name dslotds)) -(defgeneric compute-layout (class cpl instance-eslotds)) -(defgeneric default-initargs (class supplied-initargs all-default)) +; (generic-function long-method-combination t) +; (generic-function short-method-combination t) +; (generic-function standard-method-combination t) + +(defgeneric compute-slot-accessor-info (slotd type gf)) +; (effective-slot-definition t t) + (defgeneric find-method-combination (generic-function type options)) +; (generic-function (eql progn) t) +; (generic-function (eql or) t) +; (generic-function (eql nconc) t) +; (generic-function (eql min) t) +; (generic-function (eql max) t) +; (generic-function (eql list) t) +; (generic-function (eql append) t) +; (generic-function (eql and) t) +; (generic-function (eql +) t) +; (generic-function (eql standard) t) + +(defgeneric (setf slot-accessor-function) (function slotd type)) +; (t effective-slot-definition t) + (defgeneric (setf slot-accessor-std-p) (value slotd type)) +; (t effective-slot-definition t) + (defgeneric slot-boundp-using-class (class object slotd)) -(defgeneric slot-exists-p-using-class (class object slotd)) +; (std-class standard-object standard-effective-slot-definition) +; (structure-class structure-object structure-effective-slot-definition) + (defgeneric slot-makunbound-using-class (class object slotd)) -(defgeneric slot-unbound (class class-instance slot-name)) +; (std-class standard-object standard-effective-slot-definition) +; (structure-class structure-object structure-effective-slot-definition) + +(defgeneric slot-unbound (class instance slot-name)) +; (t t t) + (defgeneric slot-value-using-class (class object slotd)) -(defgeneric store-closure-generator-p (generic-function method initargs)) -(defgeneric store-method-function-p (generic-function method initargs)) -(defgeneric store-method-optimized-function-p (generic-function method initargs)) -(defgeneric store-optimized-method-lambda-p (generic-function method initargs)) +; (std-class standard-object standard-effective-slot-definition) +; (structure-class structure-object structure-effective-slot-definition) + ;;; 4 arguments -(defgeneric load-constructor-internal (class name initargs generators)) -(defgeneric make-closure-generator-form (generic-function method optimized-method-lambda initargs)) -(defgeneric make-documented-boundp-method-function (class generic-function boundp-method-prototype slot-name)) -(defgeneric make-documented-reader-method-function (class generic-function reader-method-prototype slot-name)) -(defgeneric make-documented-writer-method-function (class generic-function writer-method-prototype slot-name)) -(defgeneric make-method-lambda (generic-function method lambda-expression environment)) -(defgeneric make-optimized-boundp-method-function (class generic-function boundp-method-prototype slot-name)) -(defgeneric make-optimized-method-lambda (generic-function method lambda-expression environment)) -(defgeneric make-optimized-reader-method-function (class generic-function reader-method-prototype slot-name)) -(defgeneric make-optimized-writer-method-function (class generic-function writer-method-prototype slot-name)) +(defgeneric make-method-lambda (proto-generic-function proto-method lambda-expression environment)) +; (standard-generic-function standard-method t t) + (defgeneric (setf slot-value-using-class) (new-value class object slotd)) +; (t std-class standard-object standard-effective-slot-definition) +; (t structure-class structure-object structure-effective-slot-definition) -;;; 5 arguments -(defgeneric compile-structure-class-internals (class direct-slots conc-name predicate-name constructor)) -(defgeneric make-constructor-code-generators (class name lambda-list supplied-initarg-names supplied-initargs)) -;;; 6 arguments -(defgeneric do-defstruct-from-defclass (class direct-superclasses direct-slots conc-name predicate constructor)) +;;; 5 arguments +(defgeneric make-method-initargs-form (proto-generic-function proto-method lambda-expression lambda-list environment)) +; (standard-generic-function standard-method t t t) -;;; 8 arguments -(defgeneric optimize-instance-access (generic-function method parameter-class parameter slots read/write slot-name new-value)) ;;; optional arguments -(defgeneric add-boundp-method (class generic-function slot-name &optional direct-slot)) -(defgeneric add-cached-function (method function slot-locations &optional slot-fetchers)) -(defgeneric add-reader-method (class generic-function slot-name &optional direct-slot)) -(defgeneric add-writer-method (class generic-function slot-name &optional direct-slot)) -(defgeneric documentation (object &optional doc-type)) -(defgeneric (setf documentation) (new-value object &optional doc-type)) -(defgeneric get-cached-function (method slot-locations &optional slot-fetchers)) -(defgeneric get-constructor (class name &optional error-p)) -(defgeneric get-method (generic-function qualifiers specializers &optional errorp)) +(defgeneric (setf documentation) (new-value slotd &optional doc-type)) +; (t t) +; (t documentation-mixin) +; (t standard-slot-definition) + +(defgeneric documentation (slotd &optional doc-type)) +; (t) +; (documentation-mixin) +; (standard-slot-definition) + +(defgeneric get-method (generic-function qualifiers specializers &optional (errorp t))) +; (standard-generic-function t t) + (defgeneric remove-named-method (generic-function-name argument-specifiers &optional extra)) +; (t t) + (defgeneric slot-missing (class instance slot-name operation &optional new-value)) -(defgeneric update-slot-accessor-function (slotd type function &optional update-accessors-p)) +; (t t t t) + ;;; keyword arguments (defgeneric allocate-instance (class &rest initargs)) -(defgeneric boundp-method-class (class direct-slot &rest initargs)) -(defgeneric copy-instance-slots (object1 object2 &key exclude-slot-names)) -(defgeneric describe-object-slots (object stream &key slots-to-inspect &allow-other-keys)) -(defgeneric ensure-class-using-class (name class &rest args &key)) -(defgeneric ensure-generic-function-using-class (generic-function function-specifier &key generic-function-class environment &allow-other-keys)) -(defgeneric initialize-instance (gf &key lambda-list argument-precedence-order)) -(defgeneric make-direct-slotd (class &rest initargs &key name conc-name defstruct-accessor-symbol &allow-other-keys)) -(defgeneric make-instance (class-name &rest initargs)) +; (standard-class) +; (structure-class) +; (funcallable-standard-class) + +(defgeneric ensure-class-using-class (name class &rest args &key &allow-other-keys)) +; (t null) +; (t pcl-class) + +(defgeneric ensure-generic-function-using-class (generic-function function-specifier &key &allow-other-keys)) +; (null t) +; (generic-function t) + +(defgeneric initialize-instance (gf &key &allow-other-keys)) +; (slot-object) +; :after (standard-generic-function) + +(defgeneric make-instance (class &rest initargs)) +; (symbol) +; (class) + (defgeneric no-applicable-method (generic-function &rest args)) -(defgeneric no-next-method (generic-function method &rest args)) +; (t) + (defgeneric reader-method-class (class direct-slot &rest initargs)) -(defgeneric reinitialize-instance (gf &rest args &key lambda-list argument-precedence-order)) -(defgeneric shared-initialize (generic-function slot-names &key lambda-list argument-precedence-order)) -(defgeneric trace-method (method &rest options)) -(defgeneric update-dependent (meta-object dependent &rest initargs)) +; (slot-class t) + +(defgeneric reinitialize-instance (gf &rest args &key &allow-other-keys)) +; (slot-object) +; :before (slot-class) +; :after (slot-class) +; (standard-method) +; :after (standard-generic-function) + +(defgeneric shared-initialize (generic-function slot-names &key &allow-other-keys)) +; (slot-object t) +; :after (documentation-mixin t) +; :after (class-eq-specializer t) +; :after (eql-specializer t) +; :after (std-class t) +; :before (class t) +; :after (structure-class t) +; :before (built-in-class t) +; :after (standard-slot-definition t) +; :after (structure-slot-definition t) +; :before (standard-method t) +; :before (standard-accessor-method t) +; :after (standard-method t) +; :after (standard-accessor-method t) +; :before (standard-generic-function t) + (defgeneric update-instance-for-different-class (previous current &rest initargs)) +; (standard-object standard-object) + (defgeneric update-instance-for-redefined-class (instance added-slots discarded-slots property-list &rest initargs)) +; (standard-object t t t) + (defgeneric writer-method-class (class direct-slot &rest initargs)) +; (slot-class t) + diff --git a/pcl/ibcl-low.lisp b/pcl/ibcl-low.lisp index 33a5bc782..2ab3f77ba 100644 --- a/pcl/ibcl-low.lisp +++ b/pcl/ibcl-low.lisp @@ -73,11 +73,6 @@ `(and (si:structurep ,x) (eq (si:structure-name ,x) 'std-instance)))) -(import 'si:structurep) - -(defmacro structure-type (x) - `(si:structure-name ,x)) - (dolist (inline '((si:structurep ((t) compiler::boolean nil nil "type_of(#0)==t_structure") compiler::inline-always) diff --git a/pcl/init.lisp b/pcl/init.lisp index 3d57b1671..9518c1286 100644 --- a/pcl/init.lisp +++ b/pcl/init.lisp @@ -30,47 +30,40 @@ (in-package 'pcl) -(declaim (type boolean *check-initargs-p*)) -(defvar *check-initargs-p* nil) +(defmethod make-instance ((class symbol) &rest initargs) + (apply #'make-instance (find-class class) initargs)) -(defmacro checking-initargs (&body forms) - `(when *check-initargs-p* ,@forms)) - -(declaim (type boolean *making-instance-p*)) -(defvar *making-instance-p* nil) - -(defmethod make-instance ((class slot-class) &rest initargs) - (declare (list initargs)) +(defmethod make-instance ((class class) &rest initargs) (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-1 - class initargs - (append (compute-applicable-methods - #'allocate-instance (list* class initargs)) - (compute-applicable-methods - #'initialize-instance (list* class-proto initargs)) - (compute-applicable-methods - #'shared-initialize (list* class-proto t initargs))))))) - (let* ((*making-instance-p* T) - (instance (apply #'allocate-instance class initargs))) - (apply #'initialize-instance instance initargs) - instance))) - -(defmethod make-instance ((class-name symbol) &rest initargs) - (apply #'make-instance (find-class class-name) initargs)) + (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)) + (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)) (defvar *default-initargs-flag* (list nil)) -(defmethod default-initargs ((class slot-class) supplied-initargs all-default) +(defmethod default-initargs ((class slot-class) supplied-initargs) + (call-initialize-function + (initialize-info-default-initargs-function + (initialize-info class supplied-initargs)) + nil supplied-initargs) + #|| ;; This implementation of default initargs is critically dependent ;; on all-default-initargs not having any duplicate initargs in it. - (let ((miss *default-initargs-flag*)) + (let ((all-default (class-default-initargs class)) + (miss *default-initargs-flag*)) (flet ((getf* (plist key) (do () ((null plist) miss) @@ -82,48 +75,31 @@ nil (if (eq (getf* supplied-initargs (caar tail)) miss) (list* (caar tail) - (funcall-function (cadar tail)) + (funcall (cadar tail)) (default-1 (cdr tail))) (default-1 (cdr tail)))))) - (append supplied-initargs (default-1 all-default)))))) - - -(defmethod allocate-instance ((class standard-class) &rest initargs) - (declare (ignore initargs)) - (unless (or *making-instance-p* (class-finalized-p class)) - (finalize-inheritance class)) - (let* ((class-wrapper (class-wrapper class)) - (instance (%allocate-instance--class - (wrapper-allocate-static-slot-storage-copy - class-wrapper)))) - (setf (std-instance-wrapper instance) class-wrapper) - instance)) - -(defmethod allocate-instance ((class structure-class) &rest initargs) - (declare (ignore initargs)) - (let ((constructor (class-defstruct-constructor class))) - (if constructor - (funcall-function (symbol-function constructor)) - (error "Can't allocate an instance of class ~S" (class-name class))))) + (append supplied-initargs (default-1 all-default))))) + ||#) (defmethod initialize-instance ((instance slot-object) &rest initargs) (apply #'shared-initialize instance t initargs)) - (defmethod reinitialize-instance ((instance slot-object) &rest initargs) - (checking-initargs - (when (and initargs (eq *boot-state* 'complete) - (not (getf initargs :allow-other-keys))) - (check-initargs-1 - (class-of instance) initargs - (append (compute-applicable-methods - #'reinitialize-instance (list* instance initargs)) - (compute-applicable-methods - #'shared-initialize (list* instance nil 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)) + (error "Invalid initialization argument ~S for class ~S" + (cdr valid-p) (class-name class)))) (apply #'shared-initialize instance nil initargs) instance) - (defmethod update-instance-for-different-class ((previous standard-object) (current standard-object) &rest initargs) @@ -138,15 +114,10 @@ (if (and (not (memq (slot-definition-name slotd) previous-slot-names)) (eq (slot-definition-allocation slotd) ':instance)) (push (slot-definition-name slotd) added-slots))) - (checking-initargs - (when (and initargs (not (getf initargs :allow-other-keys))) - (check-initargs-1 - (class-of current) initargs - (append (compute-applicable-methods - #'update-instance-for-different-class - (list* previous current initargs)) - (compute-applicable-methods - #'shared-initialize (list* current added-slots initargs)))))) + (check-initargs-1 + (class-of current) initargs + (list (list* 'update-instance-for-different-class previous current initargs) + (list* 'shared-initialize current added-slots initargs))) (apply #'shared-initialize current added-slots initargs))) (defmethod update-instance-for-redefined-class ((instance standard-object) @@ -154,31 +125,37 @@ discarded-slots property-list &rest initargs) - (checking-initargs - (when (and initargs (not (getf initargs :allow-other-keys))) - (check-initargs-1 - (class-of instance) initargs - (append (compute-applicable-methods - #'update-instance-for-redefined-class - (list* instance added-slots discarded-slots property-list initargs)) - (compute-applicable-methods - #'shared-initialize (list instance added-slots initargs)))))) + (check-initargs-1 + (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) - (declare (list initargs)) - (declare #.*optimize-speed*) + ((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. + ;; (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: + ;; (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 @@ -189,136 +166,93 @@ ;; () ;; no slots are set from initforms ;; - (flet - ((init-safe (slots initing-internal-slotds) - (dolist (internal-slotd initing-internal-slotds) - (unless - (and - initargs - ;; Try to initialize the slot from one of the initargs. - (let ((slot-initargs (internal-slotd-initargs internal-slotd)) - (initargs-ptr initargs)) - (loop - (when (memq (car initargs-ptr) slot-initargs) - (let ((location (internal-slotd-location internal-slotd))) - (typecase location - (fixnum (setf (%svref slots location) - (cadr initargs-ptr))) - (cons (setf (cdr location) (cadr initargs-ptr))) - (T (method-function-funcall - (internal-slotd-writer-function internal-slotd) - (cadr initargs-ptr) instance)))) - (return 't)) - (when (null (setf initargs-ptr (cddr initargs-ptr))) - (return))))) - ;; Try to initialize the slot from its initform. - (when (or (eq slot-names 't) - (memq (internal-slotd-name internal-slotd) slot-names)) - (let ((location (internal-slotd-location internal-slotd))) - (typecase location - (fixnum - (when (eq (%svref slots location) *slot-unbound*) - (let ((initfn (internal-slotd-initfunction - internal-slotd))) - (when initfn - (setf (%svref slots location) - (slot-initfunction-funcall initfn)))))) - (cons - (when (eq (cdr location) *slot-unbound*) - (let ((initfn (internal-slotd-initfunction - internal-slotd))) - (when initfn - (setf (cdr location) - (slot-initfunction-funcall initfn)))))) - (T - (unless (method-function-funcall - (internal-slotd-boundp-function internal-slotd) - instance) - (let ((initfn (internal-slotd-initfunction - internal-slotd))) - (when initfn - (method-function-funcall - (internal-slotd-writer-function internal-slotd) - (slot-initfunction-funcall initfn) instance))))))))))) - - (init-unsafe (initing-internal-slotds) - (dolist (internal-slotd initing-internal-slotds) - (unless - (and - initargs - ;; Try to initialize the slot from one of the initargs. - (let ((slot-initargs (internal-slotd-initargs internal-slotd)) - (initargs-ptr initargs)) - (loop - (when (memq (car initargs-ptr) slot-initargs) - (method-function-funcall - (internal-slotd-writer-function internal-slotd) - (cadr initargs-ptr) instance) - (return 't)) - (when (null (setf initargs-ptr (cddr initargs-ptr))) - (return))))) - ;; Try to initialize the slot from its initform. - (when (or (eq slot-names 't) - (memq (internal-slotd-name internal-slotd) slot-names)) - (unless (method-function-funcall - (internal-slotd-boundp-function internal-slotd) - instance) - (let ((initfn (internal-slotd-initfunction internal-slotd))) - (when initfn - (method-function-funcall - (internal-slotd-writer-function internal-slotd) - (slot-initfunction-funcall initfn) instance))))))))) - - (when (or slot-names initargs) - (let ((initing-internal-slotds - (fast-slot-value (class-of instance) - (if (and *making-instance-p* (null initargs)) - 'side-effect-internal-slotds - 'internal-slotds)))) - (if *safe-to-use-slot-wrapper-optimizations-p* - (cond - ((std-instance-p instance) - (fast-check-wrapper-validity instance std-instance-wrapper) - (init-safe (std-instance-slots instance) initing-internal-slotds)) - ((fsc-instance-p instance) - (fast-check-wrapper-validity instance fsc-instance-wrapper) - (init-safe (fsc-instance-slots instance) initing-internal-slotds)) - #+pcl-user-instances - ((user-instance-p instance) - (fast-check-wrapper-validity instance user-instance-wrapper) - (init-safe (user-instance-slots instance) initing-internal-slotds)) - (T (init-unsafe initing-internal-slotds))) - (init-unsafe initing-internal-slotds)))) + (let* ((class (class-of instance)) + (slotds (class-slots class)) + #-new-kcl-wrapper + (std-p (or (std-instance-p instance) (fsc-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 #-new-kcl-wrapper (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)) - ;;; ;;; if initargs are valid return nil, otherwise signal an error ;;; +(defun check-initargs-1 (class initargs call-list &optional (plist-p t) (error-p t)) + (multiple-value-bind (legal allow-other-keys) + (check-initargs-values 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))))) + +(defun check-initargs-values (class call-list) + (let ((methods (mapcan #'(lambda (call) + (if (consp call) + (copy-list (compute-applicable-methods + (gdefinition (car call)) + (cdr call))) + (list call))) + call-list)) + (legal (apply #'append (mapcar #'slot-definition-initargs + (class-slots class))))) + ;; Add to the set of slot-filling initargs the set of + ;; initargs that are accepted by the methods. If at + ;; any point we come across &allow-other-keys, we can + ;; just quit. + (dolist (method methods) + (multiple-value-bind (nreq nopt keysp restp allow-other-keys keys) + (analyze-lambda-list (if (consp method) + (early-method-lambda-list method) + (method-lambda-list method))) + (declare (ignore nreq nopt keysp restp)) + (when allow-other-keys + (return-from check-initargs-values (values nil t))) + (setq legal (append keys legal)))) + (values legal nil))) -(declaim (ftype (function (T) (values list boolean)) function-keywords)) +(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 + (error "Invalid initialization argument ~S for class ~S" + key + (class-name class)) + (return-from check-initargs-2-plist nil))))) + t) -(defun check-initargs-1 (class initargs methods) - (let ((legal (apply #'append (mapcar #'internal-slotd-initargs - (class-internal-slotds class))))) - (unless nil ; (getf initargs :allow-other-keys) ; This is already checked. - ;; Add to the set of slot-filling initargs the set of - ;; initargs that are accepted by the methods. If at - ;; any point we come across &allow-other-keys, we can - ;; just quit. - (dolist (method methods) - (multiple-value-bind (keys allow-other-keys) - (function-keywords method) - (declare (type boolean allow-other-keys)) - (when allow-other-keys - (return-from check-initargs-1 nil)) - (setq legal (append keys legal)))) - ;; 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) - (error "Invalid initialization argument ~S for class ~S" - key - (class-name class))))))) +(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 + (error "Invalid initialization argument ~S for class ~S" + key + (class-name class)) + (return-from check-initargs-2-list nil))))) + t) diff --git a/pcl/iterate.lisp b/pcl/iterate.lisp index 57041e31e..d690a9537 100644 --- a/pcl/iterate.lisp +++ b/pcl/iterate.lisp @@ -307,7 +307,6 @@ NIL => never; :USER => those resulting from user code; T => always, even if it's let-body) update-forms) (dolist (v vars) - #-excl (declare (ignore v)) ; Pop off the vars we have now ; bound from the list of vars @@ -368,13 +367,12 @@ NIL => never; :USER => those resulting from user code; T => always, even if it's (eq (car binding-type) 'lambda) (not (find-if #'(lambda (x) - (member x lambda-list-keywords - :test #'eq) + (member x lambda-list-keywords) ) (setq let-bindings (second binding-type))) ) - (eql (length (the list (second expansion))) - (length (the list let-bindings))) + (eql (length (second expansion)) + (length let-bindings)) (null (cddr expansion))) ; A simple LAMBDA form can be ; treated as LET @@ -481,13 +479,13 @@ NIL => never; :USER => those resulting from user code; T => always, even if it's :abort)) ((and (setq renaming (assoc form renamed-vars - :test #'eq)) + )) (variable-same-p form env iterate-env)) ; Reference to one of the vars ; we're renaming (cdr renaming)) - ((and (member form bound-vars :test #'eq) + ((and (member form bound-vars) (variable-same-p form env iterate-env)) ; FORM is a var that is bound @@ -592,7 +590,7 @@ NIL => never; :USER => those resulting from user code; T => always, even if it's (consp (setq body (cdr form))) (listp (setq args (car body))) (or (null nargs) - (eql (length (the list args)) + (eql (length args) nargs)) form))) @@ -665,7 +663,7 @@ NIL => never; :USER => those resulting from user code; T => always, even if it's (declare (ignore context)) (let (pair) (cond ((and (symbolp form) - (setq pair (assoc form alist :test #'eq)) + (setq pair (assoc form alist)) (variable-same-p form subenv env)) (cdr pair)) (t form)))))) @@ -1070,11 +1068,11 @@ NIL => never; :USER => those resulting from user code; T => always, even if it's ; non-variable or one that has ; been rebound form) - ((setq pair (assoc form alist :test #'eq)) + ((setq pair (assoc form alist)) ; One to rename (cdr pair)) (t ; var is free - (pushnew form closed :test #'eq) + (pushnew form closed) form))))) closed))) diff --git a/pcl/kcl-low.lisp b/pcl/kcl-low.lisp index 281ff6b6e..77cb4f569 100644 --- a/pcl/kcl-low.lisp +++ b/pcl/kcl-low.lisp @@ -28,9 +28,10 @@ (in-package "SI") (export '(%structure-name %compiled-function-name - %set-compiled-function-name)) + %set-compiled-function-name + %instance-ref + %set-instance-ref)) (in-package 'pcl) -(import 'si:structurep) (shadow 'lisp:dotimes) @@ -83,31 +84,7 @@ (incf ,index)))))) (defun printing-random-thing-internal (thing stream) - (format stream "~O" (si:address thing))) - - -#+akcl -(eval-when (load compile eval) - -;compiler::*compile-ordinaries* is set to t in kcl-patches - -(if (and (boundp 'si::*akcl-version*) - (>= si::*akcl-version* 604)) - (progn - (pushnew :turbo-closure *features*) - (pushnew :turbo-closure-env-size *features*)) - (when (fboundp 'si::allocate-growth) - (pushnew :turbo-closure *features*))) - -;; patch around compiler bug. -(when (<= si::*akcl-version* 609) - (let ((vcs "static int Vcs; -")) - (unless (search vcs compiler::*cmpinclude-string*) - (setq compiler::*cmpinclude-string* - (concatenate 'string vcs compiler::*cmpinclude-string*))))) - -) + (format stream "~X" (si:address thing))) (defmacro %svref (vector index) `(svref (the simple-vector ,vector) (the fixnum ,index))) @@ -129,25 +106,26 @@ #+akcl (progn +#-new-kcl-wrapper ;; declare that std-instance-p may be computed simply, and will not change. (si::freeze-defstruct 'std-instance) +(si::freeze-defstruct 'method-call) +(si::freeze-defstruct 'fast-method-call) -(defvar *pcl-funcall* '(lambda (loc) - (compiler::wt-nl - "{object _funobj = " loc ";" - "if(type_of(_funobj)==t_cclosure && (_funobj->cc.cc_turbo)) - (*(_funobj->cc.cc_self))(_funobj->cc.cc_turbo); - else if (type_of(_funobj)==t_cfun) (*(_funobj->cc.cc_self))(); - else super_funcall_no_event(_funobj);}"))) -(setq compiler::*super-funcall* *pcl-funcall*) +(defvar *pcl-funcall* + `(lambda (loc) + (compiler::wt-nl + "{object _funobj = " loc ";" + "if(Rset&&type_of(_funobj)!=t_symbol)funcall_no_event(_funobj); + else super_funcall(_funobj);}"))) -) +(setq compiler::*super-funcall* *pcl-funcall*) -(defun function-ftype-declaimed-p (name) - "Returns whether the function given by name already has its ftype declaimed." - (get name 'compiler::proclaimed-function)) +(defmacro fmc-funcall (fn pv-cell next-method-call &rest args) + `(funcall ,fn ,pv-cell ,next-method-call ,@args)) +) ;;; ;;; turbo-closure patch. See the file kcl-mods.text for details. @@ -192,21 +170,43 @@ int n; object cc; ;;; #+akcl means this is an AKCL newer than 5/11/89 (structures changed) (eval-when (compile load eval) +#+new-kcl-wrapper +(progn + +(defun instance-ref (slots index) + (si:structure-ref1 slots index)) + +(defun set-instance-ref (slots index value) + (si:structure-set1 slots index value)) + +(defsetf instance-ref set-instance-ref) +(defsetf %instance-ref %set-instance-ref) +) + +(defsetf structure-def set-structure-def) + ;;((name args-type result-type side-effect-p new-object-p c-expression) ...) (defparameter *kcl-function-inlines* - '(#-akcl (si:structurep (t) compiler::boolean nil nil "type_of(#0)==t_structure") + '((%fboundp (t) compiler::boolean nil nil "(#0)->s.s_gfdef!=OBJNULL") + (%symbol-function (t) t nil nil "(#0)->s.s_gfdef") + #-akcl (si:structurep (t) compiler::boolean nil nil "type_of(#0)==t_structure") #-akcl (si:%structure-name (t) t nil nil "(#0)->str.str_name") #+akcl (si:%structure-name (t) t nil nil "(#0)->str.str_def->str.str_self[0]") + #+new-kcl-wrapper + (si:%instance-ref (t t) t nil nil "(#0)->str.str_self[fix(#1)]") + #+new-kcl-wrapper + (si:%set-instance-ref (t t t) t t nil "(#0)->str.str_self[fix(#1)]=(#2)") (si:%compiled-function-name (t) t nil nil "(#0)->cf.cf_name") (si:%set-compiled-function-name (t t) t t nil "((#0)->cf.cf_name)=(#1)") (cclosurep (t) compiler::boolean nil nil "type_of(#0)==t_cclosure") + #+akcl (sfun-p (t) compiler::boolean nil nil "type_of(#0)==t_sfun") (%cclosure-env (t) t nil nil "(#0)->cc.cc_env") (%set-cclosure-env (t t) t t nil "((#0)->cc.cc_env)=(#1)") #+turbo-closure (%cclosure-env-nthcdr (fixnum t) t nil nil "(#1)->cc.cc_turbo[#0]") (logxor (fixnum fixnum) fixnum nil nil "((#0) ^ (#1))"))) - + (defun make-function-inline (inline) (setf (get (car inline) 'compiler::inline-always) (list (if (fboundp 'compiler::flags) @@ -223,11 +223,12 @@ int n; object cc; (defmacro define-inlines () `(progn ,@(mapcan #'(lambda (inline) - (let ((name (intern (format nil "~S inline" (car inline)))) - (vars (mapcar #'(lambda (type) - (declare (ignore type)) - (gensym)) - (cadr inline)))) + (let* ((*package* *the-pcl-package*) + (name (intern (format nil "~S inline" (car inline)))) + (vars (mapcar #'(lambda (type) + (declare (ignore type)) + (gensym)) + (cadr inline)))) `((make-function-inline ',(cons name (cdr inline))) ,@(when (or (every #'(lambda (type) (eq type 't)) (cadr inline)) @@ -251,7 +252,7 @@ int n; object cc; (declare (ignore ignore)) (cond ((compiled-function-p fn) (si::turbo-closure fn) - (when (symbolp new-name) (proclaim-closure new-name)) + ;;(when (symbolp new-name) (proclaim-defgeneric new-name nil)) (setf (si:%compiled-function-name fn) new-name)) ((and (listp fn) (eq (car fn) 'lambda-block)) @@ -263,13 +264,6 @@ int n; object cc; fn) -(defun proclaim-closure (spec) - (when (consp spec) - (setq spec (get-setf-function-name (cadr spec)))) - (unless (function-ftype-declaimed-p spec) - #+kcl (setf (get spec 'compiler::proclaimed-closure) t))) - - #+akcl (clines "#define AKCL206") (clines " @@ -304,12 +298,24 @@ object set_cclosure (result_cc,value_cc,available_size) (defentry %set-cclosure (object object int) (object set_cclosure)) -(pushnew :structure-functions *features*) +(defun structure-functions-exist-p () + t) + +(si:define-compiler-macro structure-instance-p (x) + (once-only (x) + `(and (si:structurep ,x) + (not (eq (si:%structure-name ,x) 'std-instance))))) + +(defun structure-type (x) + (and (si:structurep x) + (si:%structure-name x))) -(defmacro structure-type (x) - `(si:%structure-name (the structure ,x))) +(si:define-compiler-macro structure-type (x) + (once-only (x) + `(and (si:structurep ,x) + (si:%structure-name ,x)))) -(defun known-structure-type-p (type) +(defun structure-type-p (type) (or (not (null (gethash type *structure-table*))) (let (#+akcl(s-data nil)) (and (symbolp type) @@ -332,6 +338,7 @@ object set_cclosure (result_cc,value_cc,available_size) (defun structure-type-slot-description-list (type) (or (cdr (gethash type *structure-table*)) (mapcan #'(lambda (slotd) + #-new-kcl-wrapper (when (and slotd (car slotd)) (let ((offset (fifth slotd))) (let ((reader #'(lambda (x) @@ -353,7 +360,9 @@ object set_cclosure (result_cc,value_cc,available_size) (list (list slot-name reader-sym reader - (and (not read-only-p) writer)))))))) + (and (not read-only-p) writer))))))) + #+new-kcl-wrapper + (list slotd)) (let ((slotds (structure-type-internal-slotds type)) (inc (structure-type-included-type-name type))) (if inc @@ -361,19 +370,32 @@ object set_cclosure (result_cc,value_cc,available_size) slotds) slotds))))) - -(defun structure-slotd-name (slotd) - (first slotd)) - -(defun structure-slotd-accessor-symbol (slotd) - (second slotd)) - -(defun structure-slotd-reader-function (slotd) - (third slotd)) - -(defun structure-slotd-writer-function (slotd) - (fourth slotd)) - +#+new-kcl-wrapper +(defun si::slot-reader-function (slot) + (let ((offset (si::slot-offset slot))) + (si:turbo-closure #'(lambda (x) + (si::structure-ref1 x offset))))) + +#+new-kcl-wrapper +(defun si::slot-writer-function (slot) + (let ((offset (si::slot-offset slot))) + (si:turbo-closure #'(lambda (x) + (si::structure-set1 x offset))))) + +(mapcar #'(lambda (fname value) + (setf (symbol-function fname) (symbol-function value))) + '(structure-slotd-name + structure-slotd-accessor-symbol + structure-slotd-reader-function + structure-slotd-writer-function + structure-slotd-type + structure-slotd-init-form) + #-new-kcl-wrapper + '(first second third fourth function-returning-nil function-returning-nil) + #+new-kcl-wrapper + '(si::slot-name si::slot-accessor-name + si::slot-reader-function si::slot-writer-function + si::slot-type si::slot-default-init)) ;; Construct files sys-proclaim.lisp and sys-package.lisp @@ -397,10 +419,11 @@ object set_cclosure (result_cc,value_cc,available_size) ;; proclaims (compiler::make-all-proclaims "*.fn") + (let ((*package* (find-package 'user))) (with-open-file (st "sys-proclaim.lisp" :direction :output :if-exists :append) - (format st "~%(IN-PACKAGE \"PCL\")~%") + ;;(format st "~%(IN-PACKAGE \"PCL\")~%") (print `(dolist (v ', @@ -410,6 +433,6 @@ object set_cclosure (result_cc,value_cc,available_size) (setf (get v 'compiler::proclaimed-closure) t)) st) (format st "~%") - )) - + ))) + diff --git a/pcl/kcl-patches.lisp b/pcl/kcl-patches.lisp index 3d94b9420..c051d9be3 100644 --- a/pcl/kcl-patches.lisp +++ b/pcl/kcl-patches.lisp @@ -30,13 +30,52 @@ #+akcl (eval-when (compile load eval) + (when (<= system::*akcl-version* 609) (pushnew :pre_akcl_610 *features*)) + +(if (and (boundp 'si::*akcl-version*) + (>= si::*akcl-version* 604)) + (progn + (pushnew :turbo-closure *features*) + (pushnew :turbo-closure-env-size *features*)) + (when (fboundp 'si::allocate-growth) + (pushnew :turbo-closure *features*))) + +;; patch around compiler bug. +(when (<= si::*akcl-version* 609) + (let ((vcs "static int Vcs; +")) + (unless (search vcs compiler::*cmpinclude-string*) + (setq compiler::*cmpinclude-string* + (concatenate 'string vcs compiler::*cmpinclude-string*))))) + +(let ((rset "int Rset; +")) + (unless (search rset compiler::*cmpinclude-string*) + (setq compiler::*cmpinclude-string* + (concatenate 'string rset compiler::*cmpinclude-string*)))) + +(when (get 'si::basic-wrapper 'si::s-data) + (pushnew :new-kcl-wrapper *features*) + (pushnew :structure-wrapper *features*)) + ) + #+akcl (progn +(unless (fboundp 'real-c2lambda-expr-with-key) + (setf (symbol-function 'real-c2lambda-expr-with-key) + (symbol-function 'c2lambda-expr-with-key))) + +(defun c2lambda-expr-with-key (lambda-list body) + (declare (special *sup-used*)) + (setq *sup-used* t) + (real-c2lambda-expr-with-key lambda-list body)) + + ;There is a bug in the implementation of *print-circle* that ;causes some akcl debugging commands (including :bt and :bl) ;to cause the following error when PCL is being used: @@ -94,34 +133,45 @@ (defentry objnull-p (object) (object "objnull_p")) (defun can-use-print-circle-p (x) + (catch 'can-use-print-circle-p + (can-use-print-circle-p1 x nil))) + +(defun can-use-print-circle-p1 (x so-far) (and (not (objnull-p x)) ; because of deficiencies in the compiler, maybe? - (typecase x - (vector (or (not (eq 't (array-element-type x))) - (every #'can-use-print-circle-p x))) - (cons (and (can-use-print-circle-p (car x)) - (can-use-print-circle-p (cdr x)))) - (array (or (not (eq 't (array-element-type x))) - (let* ((rank (array-rank x)) - (dimensions (make-list rank))) - (dotimes (i rank) - (setf (nth i dimensions) (array-dimension x i))) - (or (member 0 dimensions) - (do ((cursor (make-list rank :initial-element 0))) - (nil) - (declare (:dynamic-extent cursor)) - (unless (can-use-print-circle-p (apply #'aref x cursor)) - (return nil)) - (when (si::increment-cursor cursor dimensions) - (return t))))))) - (t (or (not (si:structurep x)) - (let* ((def (si:structure-def x)) - (name (si::s-data-name def)) - (len (si::s-data-length def)) - (pfun (si::s-data-print-function def))) - (and (null pfun) - (dotimes (i len t) - (unless (can-use-print-circle-p (si:structure-ref x name i)) - (return nil)))))))))) + (if (member x so-far) + (throw 'can-use-print-circle-p t) + (let ((so-far (cons x so-far))) + (flet ((can-use-print-circle-p (x) + (can-use-print-circle-p1 x so-far))) + (typecase x + (vector (or (not (eq 't (array-element-type x))) + (every #'can-use-print-circle-p x))) + (cons (and (can-use-print-circle-p (car x)) + (can-use-print-circle-p (cdr x)))) + (array (or (not (eq 't (array-element-type x))) + (let* ((rank (array-rank x)) + (dimensions (make-list rank))) + (dotimes (i rank) + (setf (nth i dimensions) (array-dimension x i))) + (or (member 0 dimensions) + (do ((cursor (make-list rank :initial-element 0))) + (nil) + (declare (:dynamic-extent cursor)) + (unless (can-use-print-circle-p + (apply #'aref x cursor)) + (return nil)) + (when (si::increment-cursor cursor dimensions) + (return t))))))) + (t (or (not (si:structurep x)) + (let* ((def (si:structure-def x)) + (name (si::s-data-name def)) + (len (si::s-data-length def)) + (pfun (si::s-data-print-function def))) + (and (null pfun) + (dotimes (i len t) + (unless (can-use-print-circle-p + (si:structure-ref x name i)) + (return nil))))))))))))) (defun si::apply-display-fun (display-fun n lis) (let ((*print-length* si::*debug-print-level*) diff --git a/pcl/lap.lisp b/pcl/lap.lisp index d41313a59..3e250fa5a 100644 --- a/pcl/lap.lisp +++ b/pcl/lap.lisp @@ -49,15 +49,14 @@ (defun make-lap-closure-generator (closure-variables arguments iregs vregs fvregs tregs lap-code) - (funcall-function *make-lap-closure-generator* - closure-variables arguments iregs - vregs fvregs tregs lap-code)) + (funcall *make-lap-closure-generator* + closure-variables arguments iregs + vregs fvregs tregs lap-code)) (defmacro precompile-lap-closure-generator (cvars args i-regs v-regs fv-regs t-regs lap) - (funcall-function *precompile-lap-closure-generator* - cvars args i-regs - v-regs fv-regs t-regs lap)) + (funcall *precompile-lap-closure-generator* cvars args i-regs + v-regs fv-regs t-regs lap)) (defmacro lap-in-lisp (cvars args iregs vregs fvregs tregs lap) (declare (ignore cvars args)) @@ -132,7 +131,7 @@ (cadr *generating-lap*) (cons entry allocated)) (cdr entry)) (t - (let ((new `(,type . (:reg ,(incf (the fixnum (caddr *generating-lap*))))))) + (let ((new `(,type . (:reg ,(incf (caddr *generating-lap*)))))) (setf (cadr *generating-lap*) (cons new allocated)) (cdr new))))))) @@ -160,8 +159,9 @@ `(lap-in-lisp ,closure-variables ,arguments ,iregs ,vregs ,fvregs ,tregs ,lap-code)) (*precompiling-lap* - (values closure-variables arguments iregs - vregs fvregs tregs lap-code)) + `(precompile-lap-closure-generator + ,closure-variables ,arguments ,iregs + ,vregs ,fvregs ,tregs ,lap)) (t (make-lap-closure-generator closure-variables arguments iregs @@ -202,13 +202,13 @@ (defun opcode (name &rest args) (let ((emitter (gethash name *lap-emitters*))) (if emitter - (apply-function (symbol-function emitter) args) + (apply emitter args) (error "No opcode named ~S." name)))) (defun operand (name &rest args) (let ((emitter (gethash name *lap-emitters*))) (if emitter - (apply-function (symbol-function emitter) args) + (apply emitter args) (error "No operand named ~S." name)))) (defmacro defopcode (name types) @@ -260,7 +260,8 @@ (and (consp arg) (eq (car arg) x))) (check (x) (ecase x - ((:reg :cdr :constant :iref :cvar :arg :lisp :lisp-variable) (usual x)) + ((:reg :cdr :constant :iref :instance-ref :cvar :arg :lisp :lisp-variable) + (usual x)) (:label (symbolp arg)) (:operand (and (consp arg) (memq (car arg) *lap-operands*)))))) (unless (if (consp type) @@ -274,7 +275,7 @@ (flet ((check (x) (ecase x (:symbol (symbolp arg)) - (:register-number (and (integerp arg) (>= (the fixnum arg) 0))) + (:register-number (and (integerp arg) (>= arg 0))) (:t t) (:reg (and (consp arg) (eq (car arg) :reg))) (:fixnum (typep arg 'fixnum))))) @@ -295,7 +296,7 @@ (defopcode :print (:reg)) ;implement this. -(defopcode :move (:operand (or :reg :iref :cdr :lisp-variable))) +(defopcode :move (:operand (or :reg :iref :instance-ref :cdr :lisp-variable))) (defopcode :eq ((or :reg :constant) (or :reg :constant) :label)) (defopcode :neq ((or :reg :constant) (or :reg :constant) :label)) @@ -306,10 +307,9 @@ (defopcode :fsc-instance-p (:reg :label)) (defopcode :built-in-instance-p (:reg :label)) (defopcode :structure-instance-p (:reg :label)) -#+pcl-user-instances -(defopcode :user-instance-p (:reg :label)) (defopcode :jmp ((or :reg :constant))) +(defopcode :emf-call ((or :reg :constant))) (defopcode :label (:label)) (defopcode :go (:label)) @@ -335,13 +335,9 @@ (defoperand :structure-wrapper (:reg)) (defoperand :other-wrapper (:reg)) (defoperand :built-in-or-structure-wrapper (:reg)) -#+pcl-user-instances -(defoperand :user-wrapper (:reg)) (defoperand :std-slots (:reg)) (defoperand :fsc-slots (:reg)) -#+pcl-user-instances -(defoperand :user-slots (:reg)) (defoperand :wrapper-cache-number-vector (:reg)) @@ -350,6 +346,9 @@ (defoperand :iref (:reg :reg)) (defoperand :iset (:reg :reg :reg)) +(defoperand :instance-ref (:reg :reg)) +(defoperand :instance-set (:reg :reg :reg)) + (defoperand :i1+ (:reg)) (defoperand :i+ (:reg :reg)) (defoperand :i- (:reg :reg)) diff --git a/pcl/list-functions.lisp b/pcl/list-functions.lisp index 83b8fc50d..a272131a2 100644 --- a/pcl/list-functions.lisp +++ b/pcl/list-functions.lisp @@ -5,26 +5,19 @@ (defvar *defmethod-list* nil) (defvar *defmacro-list* nil) (defvar *defgeneric-list* nil) -(defvar *proclaim-list* nil) (defun list-functions (&optional print-p) (let ((eof '(eof)) (*package* *package*)) (setq *defun-list* nil *defmethod-list* nil - *defmacro-list* nil - *proclaim-list* nil) + *defmacro-list* nil) (labels ((process-form (form) (when (consp form) (case (car form) ((in-package export import shadow shadowing-import) (eval form)) #+lcl3.0 (lcl:handler-bind (eval form)) (let (when print-p (print form))) - (declaim - (if (eq (caadr form) 'ftype) - (setf *proclaim-list* - (append (cdr form) *proclaim-list*)) - (when print-p (print form)))) (defun (push (list (cadr form) (caddr form)) *defun-list*)) (defmethod (push (list (cadr form) (caddr form)) @@ -51,14 +44,14 @@ (length *defmacro-list*) (length *defgeneric-list*)))) -(defun list-all-gfs (&optional all-p) +(defun list-all-gfs (&key all-p (show-methods-p t) san-p (name "generic-functions")) (let ((keys nil) (opt nil) (gf-vector (make-array 10 :initial-element nil)) + (readers nil) (writers nil) (cv nil) (*package* *the-pcl-package*) (*print-pretty* nil) (s-a-n (find-package "SLOT-ACCESSOR-NAME")) - (lisp-sans (list (slot-reader-symbol 'function) - (slot-reader-symbol 'type)))) + (lisp-sans (mapcar #'slot-reader-symbol '(function type)))) (map-all-generic-functions #'(lambda (gf) (when (or all-p @@ -66,23 +59,38 @@ (when (consp name) (setq name (cadr name))) (and (not (find #\: (symbol-name name))) (or (eq (symbol-package name) *the-pcl-package*) - (memq name lisp-sans) - (and (eq (symbol-package name) s-a-n) - (string= "PCL " (symbol-name name) :end2 4)))))) + (and san-p + (memq name lisp-sans) + (and (eq (symbol-package name) s-a-n) + (string= "PCL " (symbol-name name) + :end2 4))))))) (let ((ll (generic-function-lambda-list gf))) (multiple-value-bind (nrequired noptional keysp restp allow-other-keys-p keywords) (analyze-lambda-list ll) - (if (or keysp restp allow-other-keys-p keywords) - (push gf keys) - (if (plusp noptional) - (push gf opt) - (push gf (aref gf-vector nrequired))))))))) + (cond ((use-constant-value-dfun-p gf t) + (push gf cv)) + ((or keysp restp allow-other-keys-p keywords) + (push gf keys)) + ((plusp noptional) + (push gf opt)) + ((and (= nrequired 1) + (let ((m (generic-function-methods gf))) + (and m + (every #'standard-reader-method-p m)))) + (push gf readers)) + ((and (= nrequired 2) + (let ((m (generic-function-methods gf))) + (and m + (every #'standard-writer-method-p m)))) + (push gf writers)) + (t + (push gf (aref gf-vector nrequired))))))))) (with-open-file (out (let* ((system (get-system 'pcl)) (*system-directory* (funcall (car system)))) (make-pathname :defaults (truename (make-source-pathname "defsys")) - :name "generic-functions")) + :name name)) :direction :output) (format out ";;;-*-Mode:LISP; Package:PCL; Base:10; Syntax:Common-lisp -*-~2%") (format out "(in-package :pcl)~%") @@ -98,13 +106,31 @@ (string< (symbol-name s1) (symbol-name s2)) (string< (package-name p1) (package-name p2))))))) (dolist (sym list) - (let ((*print-case* :downcase)) - (format out "~&~S~%" - `(defgeneric ,sym ,(generic-function-lambda-list - (gdefinition sym)))))))) + (let* ((*print-case* :downcase) + (gf (gdefinition sym)) + (lambda-list (generic-function-lambda-list gf))) + (format out "~&~S~%" `(defgeneric ,sym ,lambda-list)) + (when show-methods-p + (dolist (m (generic-function-methods gf)) + (let* ((q (method-qualifiers m)) + (qs (if (null q) + "" + (format nil "~{~S~^ ~}" q))) + (s (unparse-specializers m))) + (format out "~&; ~7A ~S~%" qs s))) + (terpri out)))))) + (when cv + (format out "~%;;; class predicates~%") + (print-gf-list cv)) + (when readers + (format out "~%;;; readers~%") + (print-gf-list readers)) + (when writers + (format out "~%;;; writers~%") + (print-gf-list writers)) (dotimes (i 10) (when (aref gf-vector i) - (format out "~%;;; ~D arguments ~%" i) + (format out "~%;;; ~D argument~:P ~%" i) (print-gf-list (aref gf-vector i)))) (format out "~%;;; optional arguments ~%") (print-gf-list opt) diff --git a/pcl/low.lisp b/pcl/low.lisp index 30a7dc26f..324e45858 100644 --- a/pcl/low.lisp +++ b/pcl/low.lisp @@ -65,292 +65,21 @@ (in-package 'pcl) (eval-when (compile load eval) -(defconstant *optimize-speed* - #+kcl - '(optimize) - #-kcl - '(optimize (speed 3) (safety 0) (compilation-speed 0) (space 0)) - "List of declarations for locally-optimized internal code.") +(defvar *optimize-speed* '(optimize (speed 3) (safety 0))) ) - -;;; PCL optimizes slot-value accesses on specialized parameters by caching -;;; methods for each set of classes the method is called on. -;;; *compile-slot-access-method-functions-at-runtime-p* controls whether -;;; July 92 stores the method lambda for such methods and compiles them -;;; at runtime if one of the slot accesses is on a non-:instance allocated -;;; slot, is on a non-standard instance, or has a user-defined -;;; slot-value-using-class method. -;;; Doing so speeds up slot-accesses because each slot access is directly -;;; coded in the cached method to be compiled, at the cost of extra compilation -;;; at runtime. store-optimized-method-lambda-p can also be specialized -;;; for the specific kind of generic-function and methods (see methods.lisp). -;;; The default is normally T, but can be changed. - -(declaim (type boolean *compile-slot-access-method-functions-at-runtime-p*)) -(defvar *compile-slot-access-method-functions-at-runtime-p* T - "When T tells PCL to store the lambda source for methods containing slot - accesses and to compile those slot accesses at runtime in certain cases.") - -;;; -;;; For optimization purposes, July 92 PCL adds the variable -;;; *compile-all-method-functions-p*, that lets a programmer tell PCL -;;; to make sure that all method functions are compiled, and to trust that -;;; they will be compiled. The default is NIL, leaving them compiled or -;;; uncompiled as normal, so people can debug their programs more easily -;;; when loading uncompiled source code. -;;; It can be set to T by a program that uses PCL, but *must* be set -;;; to T before any user methods are loaded (otherwise their method -;;; functions might have been loaded as uncompiled functions, potentially -;;; causing nasty things to happen when the method dispatch functions later -;;; assume that they're compiled). It is safe for a user program to set -;;; it to T after PCL itself is loaded, however, because presumably PCL -;;; will have been loaded as compiled. - -(declaim (type boolean *compile-all-method-functions-p*)) -(defvar *compile-all-method-functions-p* NIL - "When T tells PCL to compile all cached method-functions and - to assume that they are compiled.") - - -;;; *compile-all-slot-initfunctions-p* tells whether all slot -;;; definition initfunctions should be compiled. Default is T. -;;; It can be set to T or NIL by a program that uses PCL, but should -;;; *not* ever later be changed to NIL if PCL has been compiled with it -;;; as T, since the initfunction-funcall's for PCL will have assumed that -;;; they are all compiled. Later changing it to T after PCL has been -;;; compiled with NIL if you change it here, however, is safe. - -(declaim (type boolean *compile-all-slot-initfunctions-p*)) -(defvar *compile-all-slot-initfunctions-p* T - "When T tells PCL to compile all slot initfunctions and assume they are compiled.") - -(declaim (type boolean *uncompiled-slot-initfunctions-exists-p*)) -(defvar *uncompiled-slot-initfunctions-exist-p* NIL - "Tells whether there have ever been any uncompiled slot initfunctions.") - - -;;; To adhere to the AMOP while retaining maximum efficiency, method -;;; functions are actually stored in two ways: as a (1) METHOD-FUNCTION and -;;; (2) as a METHOD-OPTIMIZED-FUNCTION or METHOD-CLOSURE-GENERATOR. -;;; METHOD-FUNCTION is the documented function of the AMOP. -;;; METHOD-OPTIMIZED-FUNCTION is the optimized function used by PCL in actual -;;; method function invocation (METHOD-FUNCTION-FOR-CACHING). Its arguments are -;;; the actual arguments of method, and it recieves its next-methods by -;;; looking at the global *NEXT-METHODS*. Alternatively, if the method's -;;; body contains slot-value accesses that can be optimized for caching, -;;; a METHOD-CLOSURE-GENERATOR is stored instead of METHOD-OPTIMIZED-FUNCTION -;;; to generate an optimized caching function for given parameter types. -;;; -;;; To save space and compile time, generic function STORE-METHOD-FUNCTION-P -;;; (generic-function method initargs) can be specialized to return NIL -;;; if the (normally unused) documented method-functions are not needed. -;;; Default returns T. Variable *standard-store-method-function-p*, which -;;; is what the default store-method-function-p method looks up, can be -;;; set to NIL if it is known that documented method functions will never -;;; be needed. - -(declaim (type boolean *standard-store-method-function-p*)) -(defvar *standard-store-method-function-p* T - "Value used by default STORE-METHOD-METHOD-FUNCTION-P method to tell - whether standard-methods used in standard-generic-functions store - documented method-functions.") - - -;;; Global variables keeping track of whether it is safe to use the -;;; fast slot-value optimizations that directly lookup slot location -;;; from wrapper (wrapper-optimized-slot-value) or not. PCL changes -;;; the appropriate variable to NIL if the user defines any -;;; slot-value-using-class, (setf slot-value-using-class), or -;;; slot-boundp-using-class that it doesn't know about (i.e. whose -;;; specializers aren't found on the corresponding -;;; *safe-slot-value-using-class-specializers* variable. -;;; -;;; Compiled slot-value accesses that are not specialized parameters -;;; inside are generally converted by DEFINE-COMPILER-MACRO to a call -;;; to macro FAST-SLOT-VALUE. FAST-SLOT-VALUE checks whether it -;;; is safe to use the wrapper optimizations by checking the appropriate -;;; global (e.g. *safe-to-use-slot-value-wrapper-optimizations-p*). -;;; If it is safe, then WRAPPER-OPTIMIZED-SLOT-VALUE is used to -;;; access the slot directly by looking it up in the wrapper. If it -;;; is not safe, then ACCESSOR-SLOT-VALUE is called to access the -;;; slot through a reader method defined just for that purpose (March 92 PCL). -;;; -;;; Three optimization hints if defining such slot-value-using-class -;;; method(s): (1) If the slot-value-using-class method(s) is a -;;; "simple" definition that can be looked up in the standard form -;;; (i.e. only has instance slots stored in the std/fsc/user-instance-slots -;;; vector, etc.), and therefore is still eligible for the slot-value -;;; wrapper optimizations, then one can push the method's list of -;;; specializers method onto the appropriate *safe-slot-value-using- -;;; class-specializers* global to inform PCL that the method is still -;;; "safe" (must be done _before_ defining the method). See file -;;; user-instances.lisp for an example. -;;; (2) If you know you are going to define such unsafe s-v-u-c -;;; methods, you can change each of the *safe-to-use-slot-value- -;;; wrapper-optimizations-p* globals defined below to NIL, so that -;;; PCL doesn't generate any of the WRAPPER-OPTIMIZED-SLOT-VALUE -;;; code that it won't be able to use anyway. -;;; (3) If it is guaranteed that you will *not* define such unsafe -;;; s-v-u-c methods, then *always-safe-to-use-slot-wrapper-optimizations-p* -;;; can be set to T, after which slot-value accesses will be compiled -;;; to assume that slot accesses will always be safe. This will slightly -;;; optimize slot-value speed and space because it won't have to -;;; check *safe-to-use-slot-value-wrapper-optimizations-p* and it -;;; won't generate the extra code for ACCESSOR-SLOT-VALUE. If an unsafe -;;; user-defined s-v-u-c methods id defined after this is set to T, -;;; however, then all bets are off. -;;; -;;; Do *not* change the three *safe-to-use-slot-value-wrapper-optimizations-p* -;;; globals by hand (aside for changing their initial values below). - -(declaim (type boolean *safe-to-use-slot-value-wrapper-optimizations-p* - *safe-to-use-set-slot-value-wrapper-optimizations-p* - *safe-to-use-slot-boundp-wrapper-optimizations-p* - *safe-to-use-slot-wrapper-optimizations-p*)) - -(defvar *safe-to-use-slot-value-wrapper-optimizations-p* T - "Tells whether it is safe for slot-value to directly access the - slot through the wrapper for instances of standard-class or - funcallable-standard-class. NIL if any non-standard - slot-value-using-class methods have been defined.") - -(defvar *safe-to-use-set-slot-value-wrapper-optimizations-p* T - "Tells whether it is safe for set-slot-value to directly access the - slot through the wrapper for instances of standard-class or - funcallable-standard-class. NIL if any non-standard - (setf slot-value-using-class) methods have been defined.") - -(defvar *safe-to-use-slot-boundp-wrapper-optimizations-p* T - "Tells whether it is safe for slot-boundp to directly access the - slot through the wrapper for instances of standard-class or - funcallable-standard-class. NIL if any non-standard - slot-boundp-using-class methods have been defined.") - -(defvar *safe-to-use-slot-wrapper-optimizations-p* - (and *safe-to-use-slot-value-wrapper-optimizations-p* - *safe-to-use-set-slot-value-wrapper-optimizations-p* - *safe-to-use-slot-boundp-wrapper-optimizations-p*) - "(and *safe-to-use-slot-value-wrapper-optimizations-p* - *safe-to-use-set-slot-value-wrapper-optimizations-p* - *safe-to-use-slot-boundp-wrapper-optimizations-p*)") - - -(defvar *safe-slot-value-using-class-specializers* - '((std-class standard-object standard-effective-slot-definition) - (structure-class structure-object structure-effective-slot-definition)) - "List of the names of the standard slot-value-using-class - method specializers that it is safe to use the slot-value - wrapper optimizations for.") - -(defvar *safe-set-slot-value-using-class-specializers* - '((T std-class standard-object standard-effective-slot-definition) - (T structure-class structure-object structure-effective-slot-definition)) - "List of the names of the standard (setf slot-value-using-class) - method specializers that it is safe to use the slot-value - wrapper optimizations for.") - -(defvar *safe-slot-boundp-using-class-specializers* - '((std-class standard-object standard-effective-slot-definition) - (structure-class structure-object structure-effective-slot-definition)) - "List of the names of the standard slot-boundp-using-class - method specializers that it is safe to use the slot-boundp - wrapper optimizations for.") - - -(declaim (type boolean *always-safe-to-use-slot-wrapper-optimizations-p*)) -(defvar *always-safe-to-use-slot-wrapper-optimizations-p* NIL - "Global that programmer can set to T for slight optimizations if it is - known that it will always be safe to use wrapper-optimized-slot-value - etc. for slot accesses. (I.e. there will never be user-defined - slot-value-using-class methods not in *safe-slot-value-using-class-specializers*.)") - - -;;; When compiled with the feature :pcl-user-instances, PCL includes the -;;; hooks built in to allow programmers to define their own USER-INSTANCE -;;; low-level type of instances different from STD-INSTANCE, FSC-INSTANCE, -;;; STRUCTURE-INSTANCE, or BUILT-IN-INSTANCE (see file vector.lisp for more -;;; description, and user-instances.lisp as an example of their use to save -;;; space over standard instances). -;;; Note: pcl-user-instances do not currently work in excl (Allegro) on -;;; the Sun 4 because of the low-level Sparc lap optimizations in -;;; quadlap.lisp. :pcl-user-instances is therefore not usually compiled as -;;; a feature in excl on the sun4. If you want to use pcl-user-instances -;;; in excl on the sun4, then the lines defining cpatch and quadlap as -;;; part of the (defsystem pcl ...) in defsys.lisp must be commented out -;;; and the below lines modified. - -;#-(and excl sun4) -(pushnew :pcl-user-instances *features*) - - - (defmacro %svref (vector index) `(locally (declare #.*optimize-speed* - (inline svref)) - (svref (the simple-vector ,vector) (the index ,index)))) + (inline svref)) + (svref (the simple-vector ,vector) (the fixnum ,index)))) -(defsetf %svref (vector index) (new-value) +(defsetf %svref %set-svref) + +(defmacro %set-svref (vector index new-value) `(locally (declare #.*optimize-speed* - (inline svref)) - (setf (svref (the simple-vector ,vector) (the index ,index)) - ,new-value))) - - -(defun method-function-storage-form (function) - "Converts a function to the form it will be stored as a method-function - or method-function. This is equal to itself, except that if it is - uncompiled and *compile-all-method-functions-p* is T, then it - will be compiled and that value returned." - (when function - (if (compiled-function-p function) - function - (if *compile-all-method-functions-p* - (compile-function function) - function)))) - -(defmacro method-function-funcall (f &rest args) - (if *compile-all-method-functions-p* - `(funcall-compiled ,f ,@args) - `(funcall-function ,f ,@args))) - -(defmacro method-function-apply (f &rest args) - (if *compile-all-method-functions-p* - `(apply-compiled ,f ,@args) - `(apply-function ,f ,@args))) - - -(defun slot-initfunction-storage-form (initfunction) - "Converts a slot-definition initfunction to the form it will be - stored as. This is equal to itself, except that if it is uncompiled - and *compile-all-slot-initfunctions-p* is T, then it will be compiled - and that value returned." - (if initfunction - (if (compiled-function-p initfunction) - initfunction - (if *compile-all-slot-initfunctions-p* - (compile-initfunction initfunction) - (progn - (setf *uncompiled-slot-initfunctions-exist-p* T) - initfunction))) - (error "No initfunction supplied."))) - -(defun compile-initfunction (initfunction) - ;; This is meant to compile the initfunction if it is not compiled yet, - ;; which should be straightforward, since it will be in the form - ;; (function (lambda () ,initform)). This definitely works in lucid, - ;; excl, and cmu-lisp. ;However, akcl does something strange to that - ;; form (i.e. convert it to '(lambda-closure () () () () ,initform)), - ;; which I've patched, but who knows what the heck other lisps do? -- TL - (if (compiled-function-p initfunction) - initfunction - (compile-function initfunction))) - -(defmacro slot-initfunction-funcall (f &rest args) - (if (and *compile-all-slot-initfunctions-p* - (not *uncompiled-slot-initfunctions-exist-p*)) - `(funcall-compiled ,f ,@args) - `(funcall-function ,f ,@args))) + (inline svref)) + (setf (svref (the simple-vector ,vector) (the fixnum ,index)) + ,new-value))) ;;; @@ -373,127 +102,84 @@ ;;; (defmacro without-interrupts (&body body) `(macrolet ((interrupts-on () ()) - (interrupts-off () ())) + (interrupts-off () ())) (progn ,.body))) -(defmacro without-interrupts-simple (&body body) - `(without-interrupts ,.body)) - + +;;; +;;; Very Low-Level representation of instances with meta-class standard-class. +;;; +#-new-kcl-wrapper +(progn +(defstruct (std-instance (:predicate std-instance-p) + (:conc-name %std-instance-) + (:constructor %%allocate-instance--class ()) + (:print-function print-std-instance)) + (wrapper nil) + (slots nil)) + +(defmacro %instance-ref (slots index) + `(%svref ,slots ,index)) -;;; We have to redefine lisp's DEFSTRUCT macro so that pcl knows about -;;; all the structure-classes. +(defmacro instance-ref (slots index) + `(svref ,slots ,index)) +) -(defmacro pcl-defstruct (name-and-options &body slot-descriptions) - ;; Excludes structures types created with the :type option - (if (and (listp name-and-options) (assq :type (cdr name-and-options))) - `(original-defstruct ,name-and-options ,@slot-descriptions) - `(progn - (store-defstruct-form '(,(if (listp name-and-options) - name-and-options - (list name-and-options)) - ,@slot-descriptions)) - (original-defstruct ,name-and-options ,@slot-descriptions)))) +#+new-kcl-wrapper +(progn +(defvar *init-vector* (make-array 40 :fill-pointer 1 :adjustable t + :initial-element nil)) -(redefine-macro 'defstruct 'pcl-defstruct) -(setf (macro-function 'original-defstruct) (original-definition 'defstruct)) +(defun get-init-list (i) + (declare (fixnum i)(special *slot-unbound*)) + (loop (when (< i (fill-pointer *init-vector*)) + (return (aref *init-vector* i))) + (vector-push-extend + (cons *slot-unbound* + (aref *init-vector* (1- (fill-pointer *init-vector*)))) + *init-vector*))) +(defmacro %std-instance-wrapper (instance) + `(structure-def ,instance)) -(defvar *structure-table* (make-hash-table :test 'eq)) +(defmacro %std-instance-slots (instance) + instance) -(defun store-defstruct-form (defstruct-source) - (setf (gethash (caar defstruct-source) *structure-table*) - defstruct-source)) - -(defun defstruct-form (structure-name) - (gethash structure-name *structure-table*)) - -(defun defstruct-form-class-name (defstruct-form) - ;; Returns the name of the structure defined by the defstruct-form. - (caar defstruct-form)) - -(defun defstruct-form-conc-name (defstruct-form) - ;; Returns a string of the conc-name given by the defstruct source. - (let ((conc-name-option (assq :conc-name (cdar defstruct-form)))) - (if conc-name-option - (if (cadr conc-name-option) - (symbol-name (cadr conc-name-option)) - "") - (concatenate 'simple-string - (symbol-name (defstruct-form-class-name defstruct-form)) - "-")))) - -(defun defstruct-form-predicate-name (defstruct-form) - ;; Returns a string of the predicate-name given by the defstruct source. - (let ((predicate-option (assq :predicate (cdar defstruct-form)))) - (if predicate-option - (cadr predicate-option) - (let ((class-name (defstruct-form-class-name defstruct-form))) - (intern (concatenate 'simple-string (symbol-name class-name) "-P") - (symbol-package class-name)))))) - -(defun defstruct-form-constructor (defstruct-form) - (let ((constructor-option (assq :constructor (cdar defstruct-form)))) - (if constructor-option - (cdr constructor-option) - (let ((class-name (defstruct-form-class-name defstruct-form))) - (list - (intern (concatenate 'simple-string "MAKE-" (symbol-name class-name)) - (symbol-package class-name)) - ()))))) - -#-(or cmu excl ibcl kcl lucid) -(defmacro structurep (x) - `(typep ,x 'structure)) - -#-(or cmu excl ibcl kcl lucid) -(defmacro structure-type (x) - `(type-of ,x)) - -#-(or cmu kcl lucid) -(defun known-structure-type-p (symbol) - (not (null (gethash symbol *structure-table*)))) +(defmacro std-instance-p (x) + `(structurep ,x)) +) -(defmacro structure-instance-p (x) - "All structures except std-instance structures match." - (once-only (x) - `(locally - (declare #.*optimize-speed*) - (and (structurep ,x) - (not (eq (structure-type ,x) 'std-instance)))))) +(defmacro std-instance-wrapper (x) `(%std-instance-wrapper ,x)) +(defmacro std-instance-slots (x) `(%std-instance-slots ,x)) -(defun structure-type-included-type-name (symbol) - (let ((defstruct-source (gethash symbol *structure-table*))) - (cadr (assq :include (cdar defstruct-source))))) +(defmacro get-wrapper (inst) + `(cond ((std-instance-p ,inst) (std-instance-wrapper ,inst)) + ((fsc-instance-p ,inst) (fsc-instance-wrapper ,inst)) + (t (error "What kind of instance is this?")))) +(defmacro get-instance-wrapper-or-nil (inst) + `(cond ((std-instance-p ,inst) (std-instance-wrapper ,inst)) + ((fsc-instance-p ,inst) (fsc-instance-wrapper ,inst)))) -;;; -;;; Very Low-Level representation of instances with meta-class standard-class. -;;; -(defstruct (std-instance (:predicate std-instance-p) - (:conc-name %std-instance-) - (:constructor %%allocate-instance--class ()) - (:print-function print-std-instance)) - (wrapper nil) - (slots nil)) +(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?")))) -(defmacro std-instance-wrapper (x) `(%std-instance-wrapper ,x)) -(defmacro std-instance-slots (x) `(%std-instance-slots ,x)) +(defmacro get-slots-or-nil (inst) + `(cond ((std-instance-p ,inst) (std-instance-slots ,inst)) + ((fsc-instance-p ,inst) (fsc-instance-slots ,inst)))) (defun print-std-instance (instance stream depth) ;A temporary definition used - (declare (ignore depth)) ;for debugging the bootstrap + (declare (ignore depth)) ;for debugging the bootstrap (printing-random-thing (instance stream) ;code of PCL (See high.lisp). - (format stream "std-instance"))) - -(defmacro %allocate-instance--class (static-slot-storage-copy) - `(let ((instance (%%allocate-instance--class))) - (%allocate-instance--class-1 ,static-slot-storage-copy instance) - instance)) - -(defmacro %allocate-instance--class-1 (static-slot-storage-copy instance) - (once-only (instance) - `(progn - (setf (std-instance-slots ,instance) - (%allocate-static-slot-storage--class ,static-slot-storage-copy))))) + (let ((class (class-of instance))) + (if (or (eq class (find-class 'standard-class nil)) + (eq class (find-class 'funcallable-standard-class nil)) + (eq class (find-class 'built-in-class nil))) + (format stream "~a ~a" (early-class-name class) + (early-class-name instance)) + (format stream "~a" (early-class-name class)))))) ;;; ;;; This is the value that we stick into a slot to tell us that it is unbound. @@ -504,27 +190,18 @@ ;;; code which actually use ..slot-unbound.. rather than this variable. So ;;; much for modularity ;;; -(defconstant *slot-unbound* '..slot-unbound..) +(defvar *slot-unbound* '..slot-unbound..) -;;; As of July 92 PCL, %allocate-static-slot-storage--class does not take -;;; a number of slots. As per the optimization suggestion in the first two -;;; chapters of the CLOS specification, it instead takes a copy of the slot -;;; storage vector and copies it. This original vector copy (stored in -;;; wrapper-allocate-static-slot-storage-copy in the wrappers) holds the -;;; results of the slot :initform forms that neither produce or depend on -;;; side-effects (with any other slots holding *slot-unbound*). - -(defmacro %allocate-static-slot-storage--class (static-slot-storage-copy) - `(locally (declare #.*optimize-speed*) - (copy-simple-vector ,static-slot-storage-copy))) - -(defmacro %allocate-origional-static-slot-storage-copy (no-of-slots) - `(make-array ,no-of-slots :initial-element *slot-unbound*)) +(defmacro %allocate-static-slot-storage--class (no-of-slots) + #+new-kcl-wrapper (declare (ignore no-of-slots)) + #-new-kcl-wrapper + `(make-array ,no-of-slots :initial-element *slot-unbound*) + #+new-kcl-wrapper + (error "don't call this")) (defmacro std-instance-class (instance) - `(wrapper-class (std-instance-wrapper ,instance))) - - + `(wrapper-class* (std-instance-wrapper ,instance))) + ;; ;;;;;; FUNCTION-ARGLIST @@ -566,8 +243,8 @@ (defun set-function-name (function new-name) (declare (notinline set-function-name-1 intern-function-name)) (set-function-name-1 function - (intern-function-name new-name) - new-name)) + (intern-function-name new-name) + new-name)) (defun set-function-name-1 (function new-name uninterned-name) (declare (ignore new-name uninterned-name)) @@ -575,15 +252,15 @@ (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*)))) - + ((listp name) + (intern (let ((*package* *the-pcl-package*) + (*print-case* :upcase) + (*print-pretty* nil) + (*print-gensym* 't)) + (format nil "~S" name)) + *the-pcl-package*)))) + ;;; ;;; COMPILE-LAMBDA ;;; @@ -610,100 +287,67 @@ ;;; ports which have non-reentrant compilers. ;;; ;;; -;;; TL: 07/92: Added name optional parameter to compile-lambda to -;;; allow the lambda to be compiled with a given function name. - (defvar *compiler-present-p* t) (defvar *compiler-speed* - #+(or KCL IBCL GCLisp) :slow - #-(or KCL IBCL GCLisp) :fast) + #+(or KCL IBCL GCLisp CMU) :slow + #-(or KCL IBCL GCLisp CMU) :fast) (defvar *compiler-reentrant-p* - #+(and (not XKCL) (or KCL IBCL)) nil - #-(and (not XKCL) (or KCL IBCL)) t) + #+(and (not XKCL) (or KCL IBCL)) nil + #-(and (not XKCL) (or KCL IBCL)) t) (defun in-the-compiler-p () - #+(and (not xkcl) (or KCL IBCL)) compiler::*compiler-in-use* + #+(and (not xkcl) (or KCL IBCL))compiler::*compiler-in-use* #+gclisp (typep (eval '(function (lambda ()))) 'lexical-closure) ) -(defun compile-function (function) - (cond #+kcl - ((and (listp function) (eq (car function) 'lambda-closure)) - (compile-lambda `(lambda ,@(cddddr function)))) - ((functionp function) (compile-lambda function)) - (T "Function isn't in expected function form -- see - documentation of PCL::COMPILE-FUNCTION."))) +(defvar *compile-lambda-break-p* nil) -(defun compile-lambda (lambda &optional (desirability :fast) name) +(defun compile-lambda (lambda &optional (desirability :fast)) + (when *compile-lambda-break-p* (break)) (cond ((null *compiler-present-p*) - (compile-lambda-uncompiled lambda name)) - ((and (null *compiler-reentrant-p*) - (in-the-compiler-p)) - (compile-lambda-deferred lambda name)) - ((eq desirability :fast) - (compile name lambda)) - ((and (eq desirability :medium) - (memq *compiler-speed* '(:fast :medium))) - (compile name lambda)) - ((and (eq desirability :slow) - (eq *compiler-speed* ':fast)) - (compile name lambda)) - (t - (compile-lambda-uncompiled lambda name)))) - -(defun compile-lambda-uncompiled (uncompiled &optional name) - (let* ((function (coerce uncompiled 'function)) - (form #'(lambda (&rest args) (apply function args)))) - (if name - (progn - (setf (symbol-function name) form) - name) - form))) - -(defun compile-lambda-deferred (uncompiled &optional name) - (let* ((function (coerce uncompiled 'function)) - (compiled nil) - (form - #'(lambda (&rest args) - (if compiled - (apply (the compiled-function compiled) args) - (if (in-the-compiler-p) - (apply function args) - (progn (setq compiled (compile name uncompiled)) - (apply (the compiled-function compiled) args))))))) - (if name - (progn - (setf (symbol-function name) form) - name) - form))) + (compile-lambda-uncompiled lambda)) + ((and (null *compiler-reentrant-p*) + (in-the-compiler-p)) + (compile-lambda-deferred lambda)) + ((eq desirability :fast) + (compile nil lambda)) + ((and (eq desirability :medium) + (member *compiler-speed* '(:fast :medium))) + (compile nil lambda)) + ((and (eq desirability :slow) + (eq *compiler-speed* ':fast)) + (compile nil lambda)) + (t + (compile-lambda-uncompiled lambda)))) + +(defun compile-lambda-uncompiled (uncompiled) + #'(lambda (&rest args) (apply (coerce uncompiled 'function) args))) + +(defun compile-lambda-deferred (uncompiled) + (let ((function (coerce uncompiled 'function)) + (compiled nil)) + #'(lambda (&rest args) + (if compiled + (apply compiled args) + (if (in-the-compiler-p) + (apply function args) + (progn (setq compiled (compile nil uncompiled)) + (apply compiled args))))))) (defmacro precompile-random-code-segments (&optional system) `(progn - (eval-when (compile) (before-precompile-random-code-segments)) + (eval-when (compile) + (update-dispatch-dfuns) + (compile-iis-functions nil)) (precompile-function-generators ,system) - (precompile-dfun-constructors ,system))) - -(defmacro force-compile (fn-name) - "If the function named by FN-NAME isn't compiled, then compile it." - (once-only (fn-name) - `(unless (really-compiled-function-p (symbol-function ,fn-name)) - #+(and (not XKCL) (or KCL IBCL)) - (if (in-the-compiler-p) - (in-compiler-force-compile ,fn-name) - (compile ,fn-name)) - #-(and (not XKCL) (or KCL IBCL)) - (compile ,fn-name)))) - -(defun in-compiler-force-compile (fn-name) - (let ((sym-fn (symbol-function fn-name))) - (if (and (consp sym-fn) (eq (car sym-fn) 'lambda-block)) - (compile-lambda `(lambda ,@(cddr sym-fn)) fn-name) - (error "Uncompiled SYMBOL-FUNCTION of ~S in unexpected - form (FORCE-COMPILE)" fn-name)))) - + (precompile-dfun-constructors ,system) + (precompile-iis-functions ,system) + (eval-when (load) + (compile-iis-functions t)))) + (defun record-definition (type spec &rest args) (declare (ignore type spec args)) @@ -711,10 +355,90 @@ (defun doctor-dfun-for-the-debugger (gf dfun) (declare (ignore gf)) dfun) +;; From braid.lisp +#-new-kcl-wrapper +(defmacro built-in-or-structure-wrapper (x) + (once-only (x) + (if (structure-functions-exist-p) ; otherwise structurep is too slow for this + `(if (structurep ,x) + (wrapper-for-structure ,x) + (if (symbolp ,x) + (if ,x *the-wrapper-of-symbol* *the-wrapper-of-null*) + (built-in-wrapper-of ,x))) + `(or (and (symbolp ,x) + (if ,x *the-wrapper-of-symbol* *the-wrapper-of-null*)) + (built-in-or-structure-wrapper1 ,x))))) + ;Low level functions for structures ;Functions on arbitrary objects +(defvar *structure-table* (make-hash-table :test 'eq)) + +(defun declare-structure (name included-name slot-description-list) + (setf (gethash name *structure-table*) + (cons included-name slot-description-list))) + +(unless (fboundp 'structure-functions-exist-p) + (setf (symbol-function 'structure-functions-exist-p) + #'(lambda () nil))) + +(defun default-structurep (x) + (structure-type-p (type-of x))) + +(defun default-structure-instance-p (x) + (let ((type (type-of x))) + (and (not (eq type 'std-instance)) + (structure-type-p type)))) + +(defun default-structure-type (x) + (type-of x)) + +(unless (fboundp 'structurep) + (setf (symbol-function 'structurep) #'default-structurep)) + +; excludes std-instance +(unless (fboundp 'structure-instance-p) + (setf (symbol-function 'structure-instance-p) #'default-structure-instance-p)) + +; returns a symbol +(unless (fboundp 'structure-type) + (setf (symbol-function 'structure-type) #'default-structure-type)) + + +;Functions on symbols naming structures + +; Excludes structures types created with the :type option +(defun structure-type-p (symbol) + (not (null (gethash symbol *structure-table*)))) + +(defun structure-type-included-type-name (symbol) + (car (gethash symbol *structure-table*))) + +; direct slots only +; The results of this function are used only by the functions below. +(defun structure-type-slot-description-list (symbol) + (cdr (gethash symbol *structure-table*))) + + +;Functions on slot-descriptions (returned by the function above) + +;returns a symbol +(defun structure-slotd-name (structure-slot-description) + (first structure-slot-description)) + +;returns a symbol +(defun structure-slotd-accessor-symbol (structure-slot-description) + (second structure-slot-description)) + +;returns a symbol or a list or nil +(defun structure-slotd-writer-function (structure-slot-description) + (third structure-slot-description)) + +(defun structure-slotd-type (structure-slot-description) + (fourth structure-slot-description)) +(defun structure-slotd-init-form (structure-slot-description) + (fifth structure-slot-description)) diff --git a/pcl/lucid-low.lisp b/pcl/lucid-low.lisp index 20107328a..ec473574e 100644 --- a/pcl/lucid-low.lisp +++ b/pcl/lucid-low.lisp @@ -106,7 +106,7 @@ -#+lcl4.0 +#+lcl3.0 (progn (defvar *saved-compilation-speed* 3) @@ -191,7 +191,12 @@ ;;; The following should override the definitions provided by lucid-low. ;;; #+(or LCL3.0 (and APOLLO DOMAIN/OS)) -(defstruct-simple-predicate std-instance std-instance-p) +(progn +(defstruct-simple-predicate std-instance std-instance-p) +(defstruct-simple-predicate fast-method-call fast-method-call-p) +(defstruct-simple-predicate method-call method-call-p) +) + (defun set-function-name-1 (fn new-name ignore) @@ -307,12 +312,18 @@ (in-package 'pcl) (pushnew :structure-wrapper *features*) -(pushnew :structure-functions *features*) + +(defun structure-functions-exist-p () + t) + +(defun structure-instance-p (x) + (and (structurep x) + (not (eq 'std-instance (structure-type x))))) (defvar *structure-type* nil) (defvar *structure-length* nil) -(defun known-structure-type-p (type) +(defun structure-type-p (type) (declare (special lucid::*defstructs*)) (let ((s-data (gethash type lucid::*defstructs*))) (or (and s-data @@ -328,30 +339,29 @@ (declare (special lucid::*defstructs*)) (let ((s-data (gethash type lucid::*defstructs*))) (if s-data - (nthcdr (the index - (let ((include (structure-ref s-data 6 'defstruct))) - (if include - (let ((inc-s-data (gethash include lucid::*defstructs*))) - (if inc-s-data - (length (structure-ref inc-s-data 7 'defstruct)) - 0)) - 0))) - (map - 'list - #'(lambda (slotd) - (let* ((slot-name (system:structure-ref slotd 0 'lucid::defstruct-slot)) - (position (system:structure-ref slotd 1 'lucid::defstruct-slot)) - (accessor (system:structure-ref slotd 2 'lucid::defstruct-slot)) - (read-only-p (system:structure-ref slotd 5 'lucid::defstruct-slot))) - (list slot-name accessor - #'(lambda (x) - (system:structure-ref x position type)) - (unless read-only-p - #'(lambda (v x) - (setf (system:structure-ref x position type) - v)))))) - (structure-ref s-data 7 'defstruct))) ; slots - Fix this - (let ((result (make-list (the index *structure-length*)))) + (nthcdr (let ((include (structure-ref s-data 6 'defstruct))) + (if include + (let ((inc-s-data (gethash include lucid::*defstructs*))) + (if inc-s-data + (length (structure-ref inc-s-data 7 'defstruct)) + 0)) + 0)) + (map 'list + #'(lambda (slotd) + (let* ((ds 'lucid::defstruct-slot) + (slot-name (system:structure-ref slotd 0 ds)) + (position (system:structure-ref slotd 1 ds)) + (accessor (system:structure-ref slotd 2 ds)) + (read-only-p (system:structure-ref slotd 5 ds))) + (list slot-name accessor + #'(lambda (x) + (system:structure-ref x position type)) + (unless read-only-p + #'(lambda (v x) + (setf (system:structure-ref x position type) + v)))))) + (structure-ref s-data 7 'defstruct))) ; slots - Fix this + (let ((result (make-list *structure-length*))) (dotimes (i *structure-length* result) (let* ((name (format nil "SLOT~D" i)) (slot-name (intern name (or (symbol-package type) *package*))) diff --git a/pcl/macros.lisp b/pcl/macros.lisp index 1bc49ba5b..5ae83f4d6 100644 --- a/pcl/macros.lisp +++ b/pcl/macros.lisp @@ -46,7 +46,8 @@ class variable-rebinding pcl-fast-call - specializer-names + method-name + method-lambda-list )) ;;; Age old functions which CommonLisp cleaned-up away. They probably exist @@ -69,23 +70,19 @@ (defun make-caxr (n form) - (declare (type fixnum n)) (if (< n 4) `(,(nth n '(car cadr caddr cadddr)) ,form) - (make-caxr (the fixnum (- n 4)) `(cddddr ,form)))) + (make-caxr (- n 4) `(cddddr ,form)))) (defun make-cdxr (n form) - (declare (type fixnum n)) (cond ((zerop n) form) ((< n 5) `(,(nth n '(identity cdr cddr cdddr cddddr)) ,form)) - (t (make-cdxr (the fixnum (- n 4)) `(cddddr ,form))))) + (t (make-cdxr (- n 4) `(cddddr ,form))))) ) - (defun true (&rest ignore) (declare (ignore ignore)) t) (defun false (&rest ignore) (declare (ignore ignore)) nil) (defun zero (&rest ignore) (declare (ignore ignore)) 0) -(defvar *keyword-package* (find-package 'keyword)) (defun make-plist (keys vals) (if (null vals) @@ -101,168 +98,34 @@ ;;; lifted it from there but I am honest. Not only that but this one is ;;; written in Common Lisp. I feel a lot like bootstrapping, or maybe more ;;; like rebuilding Rome. -;;; -;;; Modified 5/8/92 to work right on THE forms and to not wrap an -;;; extra lambda if none of the variables are complex -- TL. - -(defun un-the (form) - "Returns the actual form within a form that may start with THE." - (if (and (listp form) (eq (car form) 'the)) - (un-the (third form)) - form)) - -(defun simple-eval-access-p (form) - "Returns whether evaluation of the form is 'simple', i.e. does not - require computation to calculate. This is true of constants, variables, - and functions." - (or (constantp form) ;; Form is a constant? - (symbolp form) ;; Form is a variable? - (and (listp form) - (eq (car form) 'function)) ;; Form is a function? - (and (listp form) ;; If form starts with THE, the real form - (eq (car form) 'the) ;; third element. - (simple-eval-access-p (third form))))) - (defmacro once-only (vars &body body) (let ((gensym-var (gensym)) - (run-time-vars (gensym "RUN-TIME-VARS")) - (run-time-vals (gensym "RUN-TIME-VALS")) + (run-time-vars (gensym)) + (run-time-vals (gensym)) (expand-time-val-forms ())) (dolist (var vars) - (push `(if (simple-eval-access-p ,var) + (push `(if (or (symbolp ,var) + (numberp ,var) + (and (listp ,var) + (member (car ,var) '(quote function)))) ,var - (let ((,gensym-var (gensym ,(symbol-name var)))) + (let ((,gensym-var (gensym))) (push ,gensym-var ,run-time-vars) (push ,var ,run-time-vals) ,gensym-var)) - expand-time-val-forms)) + expand-time-val-forms)) `(let* (,run-time-vars ,run-time-vals (wrapped-body (let ,(mapcar #'list vars (reverse expand-time-val-forms)) ,@body))) - (if ,run-time-vars - `(let ,(mapcar #'list (reverse ,run-time-vars) - (reverse ,run-time-vals)) - ,wrapped-body) - wrapped-body)))) - -#-(or cmu) ; And probably others, but this is the only I know. -(unless (fboundp 'declaim) - (defmacro declaim (&rest decl-specs) - (let ((proclamations NIL)) - (declare (list proclamations)) - (dolist (decl-spec decl-specs) - #-(or cmu kcl) - (when (eq (car decl-spec) 'ftype) - (dolist (function-name (cddr decl-spec)) - (setf (get function-name 'ftype-declaimed-p) T))) - (push `(proclaim ',decl-spec) proclamations)) - (if (cdr proclamations) - `(progn ,@proclamations) - (car proclamations))))) - -#-(or cmu kcl) -(defun function-ftype-declaimed-p (name) - "Returns whether the function given by name already has its ftype declaimed." - (get name 'ftype-declaimed-p)) - - -(deftype index () `(integer 0 ,most-positive-fixnum)) - -(defmacro pop-key-value (key - settable-lambda-list - &optional - default-value) - ;; If key is on the settable-lambda-list, then it and its value is - ;; destructively removed from the list, and its value is returned. - ;; Else, default-value is returned and the settable-lambda-list - ;; stays the same. - (once-only (key) - `(let ((list-ptr ,settable-lambda-list)) - (if (eq (car list-ptr) ,key) - (progn - (setf ,settable-lambda-list (cddr list-ptr)) - (cadr list-ptr)) - (progn - (setf list-ptr (cdr list-ptr)) - (let ((next-cdr (cdr list-ptr))) - (loop (when (null next-cdr) - (return ,default-value)) - (when (eq (car next-cdr) ,key) - (setf (cdr list-ptr) (cddr next-cdr)) - (return (cadr next-cdr))) - (setf next-cdr - (cdr (setf list-ptr (cdr next-cdr))))))))))) - -(defmacro copy-simple-vector (orig) - "Fast way to copy a simple-vector." - #-kcl - (once-only (orig) - `(let* ((i 0) - (n (length (the simple-vector ,orig))) - (new (make-array n))) - (declare (type index i n) (type simple-vector new)) - (tagbody - begin-loop - (if (>= i n) (go end-loop)) - (setf (svref new i) (svref (the simple-vector ,orig) i)) - (setf i (the index (1+ i))) - (go begin-loop) - end-loop) - new)) - #+kcl - `(copy-seq (the simple-vector ,orig))) - -(defun lambda-list-legal-p (lambda-list - &optional - (options-allowed-p T) - (keywords-allowed lambda-list-keywords)) - (when (listp lambda-list) - (dolist (element lambda-list T) - (unless (or (symbolp element) - (memq element keywords-allowed) - (and options-allowed-p (listp element))) - (return NIL))))) - - -(defun lambda-list-required-args (lambda-list) - (let ((collection NIL)) - (dolist (element lambda-list) - (if (memq element lambda-list-keywords) - (return) - (push element collection))) - (nreverse collection))) - -(defun npermutation-p (list1 list2) - "Returns whether list1 is a permutation of list2" - (if (null list1) - (null list2) - (unless (null list2) - (when (memq (car list1) list2) - (npermutation-p (cdr list1) - (delete (car list1) list2 :count 1)))))) - -(defun permutation-p (list1 list2) - "Returns whether list1 is a permutation of list2" - (npermutation-p list1 (copy-list list2))) - -(defun count-non-nils (list) - "Returns the count of non nil elements in the list." - (if list - (let ((non-nil-count 0) - (list-ptr list)) - (declare (type fixnum non-nil-count)) - (loop (when (car list-ptr) - (setf non-nil-count (the fixnum (1+ non-nil-count)))) - (unless (setf list-ptr (cdr list-ptr)) - (return non-nil-count)))) - 0)) + `(let ,(mapcar #'list (reverse ,run-time-vars) + (reverse ,run-time-vals)) + ,wrapped-body)))) (eval-when (compile load eval) -(proclaim '(ftype (function (T &optional T) (values T T T)) extract-declarations)) (defun extract-declarations (body &optional environment) - (declare (values documentation declarations body)) + ;;(declare (values documentation declarations body)) (let (documentation declarations form) (when (and (stringp (car body)) (cdr body)) @@ -290,9 +153,18 @@ body))) ) -;#+Lucid -;(eval-when (compile load eval) -; (eval `(defstruct (,(intern "FASLESCAPE" (find-package 'lucid)))))) +(defun get-declaration (name declarations &optional default) + (dolist (d declarations default) + (dolist (form (cdr d)) + (when (and (consp form) (eq (car form) name)) + (return-from get-declaration (cdr form)))))) + + +#+Lucid +(eval-when (compile load eval) + (eval `(defstruct ,(intern "FASLESCAPE" (find-package 'lucid))))) + +(defvar *keyword-package* (find-package 'keyword)) (defun make-keyword (symbol) (intern (symbol-name symbol) *keyword-package*)) @@ -347,7 +219,7 @@ (eval-when (compile load eval) (defun destructure (pattern form) - (declare (values setqs binds)) + ;;(declare (values setqs binds)) (let ((*destructure-vars* ()) (setqs ())) (declare (special *destructure-vars*)) @@ -368,7 +240,6 @@ (pending-pops 0) (var nil) (setqs ())) - (declare (type fixnum pending-pops)) (labels ((make-pop (var form pop-into) (prog1 @@ -485,7 +356,6 @@ (char nil char) (i 0 (+ i 1))) ((= i length) string) - (declare (type fixnum i length)) (setq char (elt string i)) (cond ((both-case-p char) (if flag @@ -498,39 +368,26 @@ (unless dashes-p (setf (elt string i) #\space))) (t (setq flag nil)))))) -#-(or lucid kcl excl cmu) -(eval-when (compile) -(warn "****** Things would go faster if you fix define-compiler-macro for -your lisp") +#-(or lucid kcl) +(eval-when (compile load eval) +;(warn "****** Things will go faster if you fix define-compiler-macro") ) -#+(or lucid kcl excl cmu) (defmacro define-compiler-macro (name arglist &body body) - `(#+lucid lcl:def-compiler-macro - #+kcl si::define-compiler-macro - #+excl excl::defcmacro - #+cmu c:def-source-transform + #+(or lucid kcl) + `(#+lucid lcl:def-compiler-macro #+kcl si::define-compiler-macro ,name ,arglist - ,@body)) + ,@body) + #-(or kcl lucid) + nil) -#-(or lucid kcl excl cmu) -(defmacro define-compiler-macro (name arglist &body body) - (declare (ignore name arglist body)) - NIL) - -(defmacro safe-subtypep (type1 type2) - #+(or cmu kcl excl) - `(subtypep ,type1 ,type2) - #+lucid - (once-only (type1 type2) - `(if (and (lcl:type-specifier-p ,type1) - (lcl:type-specifier-p ,type2)) - (subtypep ,type1 ,type2) - (values nil nil))) - #-(or cmu kcl excl lucid) - (declare (ignore type1 type2)) - #-(or cmu kcl excl lucid) - `(values nil nil)) + +;;; +;;; FIND-CLASS +;;; +;;; This is documented in the CLOS specification. +;;; +(defvar *find-class* (make-hash-table :test #'eq)) (defun make-constant-function (value) #'(lambda (object) @@ -541,18 +398,80 @@ your lisp") (declare (ignore x)) nil) -(defun documented-function-returning-nil (args next-methods) - (declare (ignore args next-methods)) - nil) - (defun function-returning-t (x) (declare (ignore x)) t) -(defun documented-function-returning-t (args next-methods) - (declare (ignore args next-methods)) - t) +(defmacro find-class-cell-class (cell) + `(car ,cell)) + +(defmacro find-class-cell-predicate (cell) + `(cdr ,cell)) + +(defmacro make-find-class-cell (class-name) + (declare (ignore class-name)) + '(cons nil #'function-returning-nil)) + +(defun find-class-cell (symbol &optional dont-create-p) + (or (gethash symbol *find-class*) + (unless dont-create-p + (unless (legal-class-name-p 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) + +(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)) + (cond ((null errorp) nil) + ((legal-class-name-p symbol) + (error "No class named: ~S." symbol)) + (t + (error "~S is not a legal class name." symbol))))) + +(defun find-class-predicate-from-cell (symbol cell &optional (errorp t)) + (unless (find-class-cell-class cell) + (find-class-from-cell symbol cell errorp)) + (find-class-cell-predicate cell)) + +(defun legal-class-name-p (x) + (and (symbolp x) + (not (keywordp x)))) + +(defun find-class (symbol &optional (errorp t) environment) + (declare (ignore environment)) + (find-class-from-cell symbol (find-class-cell symbol errorp) errorp)) + +(defun find-class-predicate (symbol &optional (errorp t) environment) + (declare (ignore environment)) + (find-class-predicate-from-cell symbol (find-class-cell symbol errorp) errorp)) +#-setf +(defsetf find-class (symbol &optional (errorp t) environment) (new-value) + (declare (ignore errorp environment)) + `(SETF\ PCL\ FIND-CLASS ,new-value ,symbol)) + +(defun #-setf SETF\ PCL\ FIND-CLASS #+setf (setf find-class) (new-value symbol) + (if (legal-class-name-p symbol) + (setf (find-class-cell-class (find-class-cell symbol)) new-value) + (error "~S is not a legal class name." symbol))) + +#-setf +(defsetf find-class-predicate (symbol &optional (errorp t) environment) (new-value) + (declare (ignore errorp environment)) + `(SETF\ PCL\ FIND-CLASS-PREDICATE ,new-value ,symbol)) + +(defun #-setf SETF\ PCL\ FIND-CLASS-PREDICATE #+setf (setf find-class-predicate) + (new-value symbol) + (if (legal-class-name-p symbol) + (setf (find-class-cell-predicate (find-class-cell symbol)) new-value) + (error "~S is not a legal class name." symbol))) + +(defun find-wrapper (symbol) + (class-wrapper (find-class symbol))) #|| ; Anything that used this should use eval instead. (defun reduce-constant (old) @@ -576,13 +495,12 @@ your lisp") `(let* ((limit ,size) (result (make-array limit)) (index 0)) - (declare (type fixnum index)) (values #'(lambda (value) (if (= index limit) (error "vectorizing more elements than promised.") (progn (setf (svref result index) value) - (setf index (the fixnum (1+ index))) + (incf index) value))) #'(lambda () result)))) @@ -607,62 +525,13 @@ your lisp") tail) (setq tail (funcall ,by tail)))))) - -;;; -;;; Functions and types for dealing with functions. -;;; - -(defun really-function-p (x) - "Returns whether X is really a function (as per X3J13)" - #+cmu (functionp x) - #+lucid (procedurep x) - #-(or cmu lucid) - (and (functionp x) (not (or (symbolp x) (consp x))))) - -(defun really-compiled-function-p (function) - "Returns whether FUNCTION is really a compiled function and not an - interpreted function masquerading as a compiled function." - #-cmu - (compiled-function-p function) - #+cmu - (the boolean - (and (compiled-function-p function) - (not (eval:interpreted-function-p function))))) - -(deftype real-function () - #+cmu 'function - #+lucid 'system:procedure - #-(or cmu lucid) `(satisfies really-function-p)) - -(defmacro funcall-function (form &rest args) - #+cmu `(funcall (the function ,form) ,@args) - #+lucid `(funcall (the system:procedure ,form) ,@args) - #-(or cmu lucid) `(funcall ,form ,@args)) - -(defmacro apply-function (form &rest args) - #+cmu `(apply (the function ,form) ,@args) - #+lucid `(apply (the system:procedure ,form) ,@args) - #-(or cmu lucid) `(apply ,form ,@args)) - (defmacro function-funcall (form &rest args) - `(funcall-function ,form ,@args)) + #-cmu `(funcall ,form ,@args) + #+cmu `(funcall (the function ,form) ,@args)) (defmacro function-apply (form &rest args) - `(apply-function ,form ,@args)) - -(defmacro funcall-compiled (form &rest args) - `(funcall (the compiled-function ,form) ,@args)) - -(defmacro apply-compiled (form &rest args) - `(apply (the compiled-function ,form) ,@args)) - -(defmacro force-compile (fn-name) - "If the function named by FN-NAME isn't compiled, then compile it." - (once-only (fn-name) - `(unless (really-compiled-function-p (symbol-function ,fn-name)) - (compile ,fn-name)))) - - + #-cmu `(apply ,form ,@args) + #+cmu `(apply (the function ,form) ,@args)) ;;; @@ -796,8 +665,6 @@ your lisp") ))) (defun setfboundp (symbol) - #-(or Genera Lucid KCL Xerox :coral cmu) - (declare (ignore symbol)) #+Genera (not (null (get-properties (symbol-plist symbol) 'lt::(derived-setf-function trivial-setf-method setf-equivalence setf-method)))) @@ -844,7 +711,6 @@ your lisp") (defsetf slot-value set-slot-value) (defvar *redefined-functions* nil) -(defvar *redefined-macros* nil) (defmacro original-definition (name) `(get ,name ':definition-before-pcl)) @@ -857,29 +723,24 @@ your lisp") (setf (symbol-function name) (symbol-function new))) -(defun redefine-macro (name new) - (pushnew name *redefined-macros*) - (unless (original-definition name) - (setf (original-definition name) - (macro-function name))) - (setf (macro-function name) - (macro-function new))) - -(defun pcl::reset-pcl-package () ; Try to do this safely - (let* ((vars '(pcl::*pcl-directory* - pcl::*default-pathname-extensions* - pcl::*pathname-extensions* - pcl::*redefined-functions*)) +(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*)) (let ((pkg (find-package "PCL"))) (do-symbols (sym pkg) (when (eq pkg (symbol-package sym)) - (if (constantp sym) + (if (or (constantp sym) + (eq sym 'wrapper) + (eq sym 'arg-info)) (unintern sym pkg) (progn (makunbound sym) - (unless (eq sym 'pcl::reset-pcl-package) + (unless (eq sym 'reset-pcl-package) (fmakunbound sym)) #+cmu (fmakunbound `(setf ,sym)) (setf (symbol-plist sym) nil)))))) @@ -895,7 +756,7 @@ your lisp") (proclaim `(special ,var)) (set var value))) names values)) - (dolist (sym pcl::*redefined-functions*) + (dolist (sym *redefined-functions*) (setf (symbol-function sym) (get sym ':definition-before-pcl))) nil)) diff --git a/pcl/methods.lisp b/pcl/methods.lisp index 577e28001..89cc24de5 100644 --- a/pcl/methods.lisp +++ b/pcl/methods.lisp @@ -27,6 +27,57 @@ (in-package 'pcl) +(defmethod print-object (instance stream) + (printing-random-thing (instance stream) + (let ((name (class-name (class-of instance)))) + (if name + (format stream "~S" name) + (format stream "Instance"))))) + +(defmethod print-object ((class class) stream) + (named-object-print-function class stream)) + +(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 shared-initialize :after ((slotd standard-slot-definition) slot-names &key) + (declare (ignore slot-names)) + (with-slots (allocation class) + slotd + (setq allocation (if (eq allocation :class) class allocation)))) + +(defmethod shared-initialize :after ((slotd structure-slot-definition) slot-names + &key (allocation :instance)) + (declare (ignore slot-names)) + (unless (eq allocation :instance) + (error "structure slots must have :instance allocation"))) + +(defmethod inform-type-system-about-class ((class structure-class) (name t)) + nil) + ;;; ;;; METHODS ;;; @@ -38,346 +89,43 @@ ;;; ;;; -(defclass method (metaobject) () - (:predicate-name method-p)) - -(defclass standard-method (definition-source-mixin documentation-mixin plist-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 - :reader method-function) - (function-name - :initform nil - :accessor method-function-name) - (optimized-function - :initform nil - :accessor method-optimized-function) - (closure-generator - :initform nil - :reader method-closure-generator) - (cached-functions-alist - :initform nil - :accessor method-cached-functions-alist - :documentation - "Alist of all cached functions of method and the slot-locations/fetchers - they're cached for.") - (needs-next-methods-p - :initform T ;Better safe than sorry - :initarg :needs-next-methods-p - :reader method-needs-next-methods-p - :documentation - "Does method call CALL-NEXT-METHOD or NEXT-METHOD-P?") - (optimized-slot-indices - :initform NIL - :type list - :initarg :optimized-slot-indices - :reader method-optimized-slot-indices - :documentation - "List of slot index forms optimized by optimize-instance-access - for slot-values within the method body. Each index is in the - form '(index-var parameter slot-name).") - (optimized-method-lambda - :initform NIL - :type list - :initarg :optimized-method-lambda - :reader method-optimized-method-lambda - :documentation - "The optimized PCL method-lambda. Only stored for methods for - which store-optimized-method-lambda-p is T.") - (identifier - :initform nil - :initarg :identifier - :reader method-identifier - :documentation - "Symbol identifier for method used for THIS-METHOD and NO-NEXT-METHOD.") - ) - (:predicate-name standard-method-p)) - -(defclass standard-accessor-method (standard-method) - ((slot-name :initform nil - :initarg :slot-name - :reader accessor-method-slot-name)) - (:predicate-name standard-accessor-method-p)) - -(defclass standard-reader-method (standard-accessor-method) () - (:predicate-name standard-reader-method-p)) - -(defclass standard-writer-method (standard-accessor-method) () - (:predicate-name standard-writer-method-p)) - -(defclass standard-boundp-method (standard-accessor-method) () - (:predicate-name standard-boundp-method-p)) - - -(defvar *the-class-method* (find-class 'method)) -(defvar *the-class-standard-method* (find-class 'standard-method)) -(defvar *the-class-standard-reader-method* (find-class 'standard-reader-method)) -(defvar *the-class-standard-writer-method* (find-class 'standard-writer-method)) -(defvar *the-class-standard-boundp-method* (find-class 'standard-boundp-method)) - -(defmethod accessor-method-slot-definition ((method standard-accessor-method)) - (let ((slot-name (accessor-method-slot-name method)) - (direct-class (car (last (method-specializers method))))) - (dolist (direct-slot (class-direct-slots direct-class)) - (when (eq (slot-definition-name direct-slot) slot-name) - (return direct-slot))))) +(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)) + (setf (slot-value method 'function) + (method-function-from-fast-function fmf))))) + +(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) - (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))))) + (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) - (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))))) - -(defmethod method-cached-functions ((method standard-method)) - (mapcar #'cdr (slot-value method 'cached-functions-alist))) - -(defvar *generic-functions-having-cached-closures* NIL) - -(declaim (ftype (function (T T) (values list list)) - cached-slot-locations-and-fetchers-from-wrappers)) -(defmethod cached-slot-locations-and-fetchers-from-wrappers ((method standard-method) - wrappers) - (declare (type list wrappers)) - (if wrappers - (let ((slot-accesses (method-optimized-slot-indices method)) - (generic-function (method-generic-function method)) - (lambda-list (method-lambda-list method)) - (accessed-classes NIL) - (slot-locations NIL) - (slot-fetchers NIL)) - (declare (type list lambda-list accessed-classes - slot-locations slot-fetchers)) - (dolist (slot-access (reverse slot-accesses)) - (let* ((wrapper (nth (the index - (posq (first slot-access) lambda-list)) - wrappers)) - (class (wrapper-class wrapper)) - (slotd (find-slot-definition class (second slot-access)))) - (if (and slotd - (or *safe-to-use-slot-wrapper-optimizations-p* - (slot-values-safe-using-class-p class slotd))) - (progn - (push (slot-definition-location slotd) slot-locations) - (unless (memq class accessed-classes) - (let ((cached-in-fns - (fast-slot-value class 'cached-in-generic-functions - slow-slot-value))) - (unless (memq generic-function cached-in-fns) - (fast-set-slot-value class 'cached-in-generic-functions - (cons generic-function cached-in-fns) - slow-slot-value))) - (push class accessed-classes))) - (push NIL slot-locations)) - (push (slots-fetcher class) slot-fetchers))) - (values slot-locations slot-fetchers)) - (let ((null-list - (make-list - (length (the list (method-optimized-slot-indices method)))))) - (values null-list null-list)))) - -(defmethod get-cached-function ((method standard-method) - slot-locations - &optional slot-fetchers) - (dolist (acons (method-cached-functions-alist method)) - (when (and (list-eq (caar acons) slot-locations) - (or (equal (cdar acons) slot-fetchers) - (null slot-fetchers))) - (return (cdr acons))))) - -(defmethod add-cached-function ((method standard-method) - function - slot-locations - &optional slot-fetchers) - (let ((new-function - (set-function-name-1 - (method-function-storage-form function) - (method-function-name method) - nil)) - (cached-functions - (method-cached-functions-alist method))) - #+(and kcl turbo-closure) (si:turbo-closure new-function) - (dolist (acons cached-functions - (setf (method-cached-functions-alist method) - (cons (cons (cons slot-locations slot-fetchers) function) - cached-functions))) - (when (and (every #'eql (caar acons) slot-locations) - (or (equal (cdar acons) slot-fetchers) - (null slot-fetchers))) - (setf (cdr acons) function) - (return))) - (setf (method-function-method new-function) method) - (pushnew (method-generic-function method) - *generic-functions-having-cached-closures* :test #'eq) - new-function)) - - -;;; closure-generators are used only by method-function-for-caching -;;; and make-not-for-caching-method-function (in vector.lisp). - -(defmethod method-function-for-caching-p ((method standard-method)) - (slot-value method 'closure-generator)) - -(defmethod method-function-for-caching ((method standard-method) wrappers) - (let* ((closure-generator (slot-value method 'closure-generator))) - (if closure-generator - (multiple-value-bind (slot-locations slot-fetchers) - (cached-slot-locations-and-fetchers-from-wrappers method wrappers) - (or (get-cached-function method slot-locations slot-fetchers) - (add-cached-function - method - (method-function-funcall - closure-generator - (list slot-locations slot-fetchers method)) - slot-locations - slot-fetchers))) - (let ((optimized-function (slot-value method 'optimized-function))) - (if optimized-function - optimized-function - (error "~A has neither closure-generator nor optimized-function." - method)))))) - -(defvar *cons-global-variable-table* (make-hash-table :test #'eq)) - -(defun get-cons-global-variable (cons) - (declare (type cons cons)) - (or (gethash cons *cons-global-variable-table*) - (setf (gethash cons *cons-global-variable-table*) - (let ((cons-var (gentemp ".CONS"))) - (eval `(defvar ,cons-var)) - (set cons-var cons) - cons-var)))) - -(defmethod make-cached-method-function-from-stored-lambda - ((method standard-method) - slot-locations-and-fetchers) - (compile-lambda (make-cached-method-lambda-from-stored-lambda - method slot-locations-and-fetchers))) - -(defmethod make-cached-method-lambda-from-stored-lambda - ((method standard-method) - slot-locations-and-fetchers) - (let* ((slot-locations (first slot-locations-and-fetchers)) - (slot-fetchers (second slot-locations-and-fetchers)) - (method-lambda (slot-value method 'optimized-method-lambda)) - (lambda-list (cadr method-lambda)) - (body (cddr method-lambda)) - (slot-indices - (slot-value method 'optimized-slot-indices)) - (used-slot-locations - (mapcar #'(lambda (loc) - (if (consp loc) (get-cons-global-variable loc) loc)) - slot-locations))) - (multiple-value-bind (documentation declarations real-body) - (extract-declarations body) - (flet ((access-form (x slot location slots-fetcher) - (cond ((typep location 'fixnum) - `(svref (the simple-vector (,slots-fetcher ,x)) - ,location)) - ((and (symbolp location) (not (null location))) - `(cdr ,location)) - ((null location) - `(fast-slot-value ,x ',slot)) - (T (error "Unknown slot-location type ~S" location))))) - `(lambda ,lambda-list - ,@declarations - ,@documentation - (macrolet - ((optimized-parameter-read (x slot index) - (declare (ignore index)) - (cond - ,@(mapcar - #'(lambda (slot-index loc slots-fetcher) - (let ((slot-param (first slot-index)) - (slot-name (second slot-index))) - `((and (eq x ',slot-param) - (eq (second slot) ',slot-name)) - ,(if loc - ``(let ((.value. - ,',(access-form slot-param slot-name - loc slots-fetcher))) - (if (eq .value. *slot-unbound*) - (funcall #'slot-value ,',slot-param - ',',slot-name) - .value.)) - ``(fast-slot-value ,',slot-param - ',',slot-name))))) - slot-indices used-slot-locations slot-fetchers))) - (optimized-parameter-write (x slot index new) - (declare (ignore index)) - (cond - ,@(mapcar - #'(lambda (slot-index loc slots-fetcher) - (let ((slot-param (first slot-index)) - (slot-name (second slot-index))) - `((and (eq x ',slot-param) - (eq (second slot) ',slot-name)) - `(setf ,',(access-form slot-param slot-name - loc slots-fetcher) - ,new)))) - slot-indices used-slot-locations slot-fetchers))) - (optimized-parameter-boundp (x slot index) - (declare (ignore index)) - (cond - ,@(mapcar - #'(lambda (slot-index loc slots-fetcher) - (let ((slot-param (first slot-index)) - (slot-name (second slot-index))) - `((and (eq x ',slot-param) - (eq (second slot) ',slot-name)) - ,(if loc - ``(neq ,',(access-form slot-param slot-name - loc slots-fetcher) - *slot-unbound*) - ``(fast-slot-boundp ,',slot-param - ',',slot-name))))) - slot-indices used-slot-locations slot-fetchers)))) - ,@real-body)))))) - - -(defmethod method-function-for-caching-p ((method standard-accessor-method)) - t) - -(defmethod method-function-for-caching ((method standard-accessor-method) wrappers) - (let* ((slot-name (slot-value method 'slot-name)) - (type (cond ((standard-reader-method-p method) 'reader) - ((standard-writer-method-p method) 'writer) - ((standard-boundp-method-p method) 'boundp))) - (class (wrapper-class (if (eq type 'writer) (cadr wrappers) (car wrappers)))) - (slotd (find-slot-definition class slot-name))) - (if slotd - (let ((slot-accessor-function (slot-accessor-function slotd type))) - (pushnew (cons NIL slot-accessor-function) - (method-cached-functions-alist method) :test #'equal) - slot-accessor-function) - (slot-value method 'optimized-function)))) + (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 @@ -394,13 +142,19 @@ Method objects cannot be reinitialized." method)) +(defmethod legal-documentation-p ((object standard-method) x) + (if (or (null x) (stringp x)) + t + "a string or NULL")) + (defmethod legal-lambda-list-p ((object standard-method) x) - (lambda-list-legal-p x)) + (declare (ignore x)) + t) (defmethod legal-method-function-p ((object standard-method) x) - (if (or (null x) (functionp x)) + (if (functionp x) t - "is not a function")) + "a function")) (defmethod legal-qualifiers-p ((object standard-method) x) (flet ((improper-list () @@ -421,6 +175,7 @@ (cond ((not (symbolp x)) "is not a symbol and so cannot be bound") ((keywordp x) "is a keyword and so cannot be bound") ((memq x '(t nil)) "cannot be bound") + ((constantp x) "is a constant and so cannot be bound") (t t))) (defmethod legal-specializers-p ((object standard-method) x) @@ -449,12 +204,9 @@ lambda-list specializers function - optimized-function - closure-generator - optimized-slot-indices - documentation) - (declare (ignore slot-names closure-generator optimized-slot-indices - documentation)) + fast-function + documentation) + (declare (ignore slot-names)) (flet ((lose (initarg value string) (error "When initializing the method ~S:~%~ The ~S initialization argument was: ~S.~%~ @@ -463,333 +215,84 @@ (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 function)) - (check-optimized-function - (legal-method-function-p method optimized-function))) + (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-optimized-function t) - (lose :optimized-function optimized-function check-optimized-function)) (unless (eq check-function t) - (lose :function function check-function))))) + (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 - (check-initargs-legality-p T) - slot-name - (slot-definition () slot-def-supplied-p)) + &key slot-name slot-definition) (declare (ignore slot-names)) - (when check-initargs-legality-p + (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))) - (when (and slot-def-supplied-p - (not (*typep slot-definition 'direct-slot-definition))) - (error "When initializing the accessor method ~S:~%~ - The initialization argument :slot-definition was ~A.~%~ - It must be an instance of a subclass of DIRECT-SLOT-DEFINITION" - method slot-definition)))) - -(defmethod shared-initialize :after ((method standard-method) - slot-names - &key - function - optimized-function - closure-generator - identifier - (qualifiers () qualifiers-p) - (constant-value () constant-value-p)) + (error "The value of the :SLOT-NAME initarg ~A." 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)))) + +(defmethod shared-initialize :after ((method standard-accessor-method) + slot-names + &key) (declare (ignore slot-names)) - (when qualifiers-p - (setf (plist-value method 'qualifiers) qualifiers)) - (when constant-value-p - (setf (plist-value method 'constant-value) constant-value)) - (when function - (setf function (method-function-storage-form function)) - (setf (slot-value method 'function) function) - (setf (method-function-method function) method) - (pushnew (cons nil function) - (method-cached-functions-alist method) :test #'equal)) - (when optimized-function - (setf optimized-function (method-function-storage-form optimized-function)) - (setf (slot-value method 'optimized-function) optimized-function) - (setf (method-function-method optimized-function) method) - (pushnew (cons nil optimized-function) - (method-cached-functions-alist method) :test #'equal)) - (when closure-generator - (setf (slot-value method 'closure-generator) - (method-function-storage-form closure-generator))) - (when identifier - (setf (get-method-from-identifier identifier) method))) + (with-slots (slot-name slot-definition) + method + (unless slot-definition + (let ((class (accessor-method-class method))) + (when (slot-class-p class) + (setq slot-definition (find slot-name (class-direct-slots class) + :key #'slot-definition-name))))) + (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)) -(declaim (ftype (function (T) (values T boolean)) method-constant-value)) -(defmethod method-constant-value ((method standard-method)) - "First value returned is constant value returned by method if it does, - second value is whether or not the method has a constant value." - (let ((constant-value-or-default - (plist-value method 'constant-value 'no-constant-value))) - (if (eq constant-value-or-default 'no-constant-value) - (values NIL NIL) - (values constant-value-or-default T)))) - - -(defclass generic-function (dependent-update-mixin - definition-source-mixin - documentation-mixin - metaobject) - () - (:metaclass funcallable-standard-class) - (:predicate-name generic-function-p)) - -(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) - (lambda-list - :initarg :lambda-list - :reader generic-function-lambda-list) - (argument-precedence-order - :initarg :argument-precedence-order - :reader generic-function-argument-precedence-order) - (declarations - :initform nil - :initarg :declarations - :reader generic-function-declarations) - -; (permutation -; :accessor gf-permutation) - (arg-info - :initform (make-arg-info) - :reader gf-arg-info) - (dfun-state - :initform () - :accessor gf-dfun-state) - (valid-p - :initform nil - :accessor gf-valid-p) - (pretty-arglist - :initform () - :accessor gf-pretty-arglist) - ) - (:metaclass funcallable-standard-class) - (:predicate-name standard-generic-function-p) - (:default-initargs :method-class *the-class-standard-method* - :method-combination *standard-method-combination*)) - - (defvar *the-class-generic-function* (find-class 'generic-function)) (defvar *the-class-standard-generic-function* (find-class 'standard-generic-function)) -(defmethod store-method-function-p ((generic-function standard-generic-function) - (method standard-method) - initargs) - ;; Should methods of this generic-function store their own method-function? - ;; Answer is normally T to keep stay compatible with the AMOP even - ;; though PCL actually uses the function in method-optimized-function - ;; for efficiency. However, answer can be NIL if the programmer doesn't - ;; care about method-functions, which will cut down on binary sizes - ;; significantly since it would stop methods from carrying around - ;; an extra (unused) method-function. - (declare (ignore initargs)) - *standard-store-method-function-p*) - -(defmethod store-method-optimized-function-p - ((generic-function standard-generic-function) - (method standard-method) - initargs) - ;; Should methods of this generic-function store their own - ;; method-optimized-function? - ;; Answer better be T unless a closure-generator is stored - ;; for the method instead, or if the programmer has redefined the - ;; discriminating method function dispatch code to use the - ;; documented method-functions rather than the optimized PCL - ;; method-optimized-functions, - (null (memq :optimized-slot-indices initargs))) - -(defmethod store-closure-generator-p - ((generic-function standard-generic-function) - (method standard-method) - initargs) - ;; Should methods of this generic-function store their own - ;; method function closure generators? - ;; Answer better be T unless a method-optimized-function is - ;; stored instead, or if the programmer has redefined the - ;; the discriminating method function dispatch code to use - ;; the documented method-functions rather than the optimized - ;; PCL method-optimized-functions. - (not (null (memq :optimized-slot-indices initargs)))) - -(defmethod store-optimized-method-lambda-p - ((generic-function standard-generic-function) - (method standard-method) - initargs) - ;; Should methods of this generic-function store their own - ;; their optimized-method-lambdas? - ;; Generally only stored when the method contains slot-value - ;; accesses on its parameter lists, in which case the lambda - ;; is used to compile the cached method for slot accesses of non - ;; :instance allocated slots or non-standard instances at - ;; runtime to directly optimize those accesses. - (and *compile-slot-access-method-functions-at-runtime-p* - (not (null (memq :optimized-slot-indices initargs))))) - -(declaim (ftype (function (T T T T) (values list list)) - make-method-lambda - make-optimized-method-lambda)) - -(defmethod make-method-lambda ((generic-function standard-generic-function) - (method standard-method) - lambda-expression - environment) - (multiple-value-bind (optimized-method-lambda initargs) - (make-optimized-method-lambda generic-function method - lambda-expression environment) - ;; Pass the optimized-method-lambda back through a global for - ;; for macro or accessor expansion. - (setf *optimized-method-lambda* optimized-method-lambda) - (values - (make-documented-standard-method-lambda - lambda-expression - environment - *standard-pcl-make-method-lambda-doc-string* - (getf initargs :identifier)) - initargs))) - -(defmethod make-optimized-method-lambda - ((generic-function standard-generic-function) - (method standard-method) - lambda-expression - environment) - (make-optimized-standard-method-lambda generic-function method - lambda-expression environment)) - -(defmethod make-closure-generator-form - ((generic-function standard-generic-function) - (method standard-method) - optimized-method-lambda - initargs) - ;; Closure generators must be in the form of functions whose arguments - ;; is a list of the wrappers of the objects passed to a generic function - ;; (or null), and which generates the method-optimized-function cached - ;; for the generic function when the gf is called with parameters having - ;; those wrappers. - (make-std-closure-generator-form - generic-function method optimized-method-lambda initargs)) - -(defmethod optimize-instance-access ((generic-function standard-generic-function) - (method standard-method) - (parameter-class T) - parameter slots read/write slot-name new-value) - (optimize-std-instance-access parameter-class parameter slots read/write - slot-name new-value)) - -(defmethod optimize-instance-access ((generic-function standard-generic-function) - (method standard-method) - (parameter-class structure-class) - parameter slots read/write slot-name new-value) - (declare (ignore slots)) - (let ((slotd (find-slot-definition parameter-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)))) - -(defmethod reader-method-class ((class slot-class) direct-slot &rest initargs) - (declare (ignore direct-slot initargs)) - *the-class-standard-reader-method*) - -(defmethod writer-method-class ((class slot-class) direct-slot &rest initargs) - (declare (ignore direct-slot initargs)) - *the-class-standard-writer-method*) - -(defmethod boundp-method-class ((class slot-class) direct-slot &rest initargs) - (declare (ignore direct-slot initargs)) - *the-class-standard-boundp-method*) - -(defmethod reader-method-class ((class standard-class) - (direct-slot standard-direct-slot-definition) - &rest initargs) - (declare (ignore initargs)) - *the-class-standard-reader-method*) - -(defmethod writer-method-class ((class standard-class) - (direct-slot standard-direct-slot-definition) - &rest initargs) - (declare (ignore initargs)) - *the-class-standard-writer-method*) - -(defmethod boundp-method-class ((class standard-class) - (direct-slot standard-direct-slot-definition) - &rest initargs) - (declare (ignore initargs)) - *the-class-standard-boundp-method*) - - -(defmethod reader-method-class ((class funcallable-standard-class) - (direct-slot standard-direct-slot-definition) - &rest initargs) - (declare (ignore initargs)) - *the-class-standard-reader-method*) - -(defmethod writer-method-class ((class funcallable-standard-class) - (direct-slot standard-direct-slot-definition) - &rest initargs) - (declare (ignore initargs)) - *the-class-standard-writer-method*) - -(defmethod boundp-method-class ((class funcallable-standard-class) - (direct-slot standard-direct-slot-definition) - &rest initargs) - (declare (ignore initargs)) - *the-class-standard-boundp-method*) - - (defmethod print-object ((generic-function generic-function) stream) (named-object-print-function generic-function stream - (list (length (the list (generic-function-methods generic-function)))))) - + (if (slot-boundp generic-function 'methods) + (list (length (generic-function-methods generic-function))) + "?"))) (defmethod shared-initialize :before ((generic-function standard-generic-function) slot-names - &key (check-initargs-legality-p T) - (name nil namep) + &key (name nil namep) (lambda-list () lambda-list-p) argument-precedence-order declarations documentation (method-class nil method-class-supplied-p) (method-combination nil method-combination-supplied-p)) - - (declare (ignore slot-names documentation)) + (declare (ignore slot-names + declarations argument-precedence-order documentation + lambda-list lambda-list-p)) (when namep (set-function-name generic-function name)) @@ -810,7 +313,7 @@ "a subclass of the class METHOD")) (setf (slot-value generic-function 'method-class) method-class)) ((slot-boundp generic-function 'method-class)) - (check-initargs-legality-p + (t (initarg-error :method-class "not supplied" "a subclass of the class METHOD"))) @@ -820,49 +323,10 @@ method-combination "a method combination object"))) ((slot-boundp generic-function 'method-combination)) - (check-initargs-legality-p + (t (initarg-error :method-combination "not supplied" - "a method combination object"))) - - (cond (lambda-list-p - (unless (legal-lambda-list-p generic-function lambda-list) - (initarg-error :lambda-list - lambda-list - "lambda list without default initial value forms")) - (when argument-precedence-order - (unless (and (listp argument-precedence-order) - (permutation-p argument-precedence-order - (lambda-list-required-args - lambda-list))) - (initarg-error :argument-precedence-order - argument-precedence-order - "permutation of required :lambda-list args")))) - (argument-precedence-order - (initarg-error :argument-precedence-order - argument-precedence-order - "supplied only when :lambda-list is supplied"))) - (when (and declarations - (not (legal-declarations-p generic-function declarations))) - (initarg-error :declarations - declarations - "a legal set of DEFGENERIC declarations")))) - -(defmethod shared-initialize :after - ((generic-function standard-generic-function) - slot-names - &key (lambda-list () lambda-list-p) - (argument-precedence-order () argument-precedence-order-p)) - (declare (ignore slot-names argument-precedence-order)) - (when (and lambda-list-p (not argument-precedence-order-p)) - (setf (slot-value generic-function 'argument-precedence-order) - (lambda-list-required-args lambda-list)))) - -(defmethod legal-declarations-p ((object standard-generic-function) x) - (listp x)) - -(defmethod legal-lambda-list-p ((object standard-generic-function) x) - (lambda-list-legal-p x NIL (remove '&aux lambda-list-keywords))) + "a method combination object"))))) #|| @@ -919,43 +383,31 @@ (t (remove-method generic-function method))))) -(defvar *reinitialize-gf-updates-dfun-p* T) - (defun real-add-named-method (generic-function-name - method-class qualifiers specializers lambda-list - function - optimized-function - closure-generator &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* ((*reinitialize-gf-updates-dfun-p* NIL) - (generic-function + (let* ((generic-function (ensure-generic-function generic-function-name - :lambda-list (method-ll->generic-function-ll lambda-list))) + :lambda-list (method-ll->generic-function-ll + lambda-list))) (specs (parse-specializers specializers)) - (new (apply #'make-instance - method-class - :qualifiers qualifiers - :specializers specs - :lambda-list lambda-list - :function function - :function - (method-function-storage-form function) - :optimized-function - (method-function-storage-form optimized-function) - :closure-generator - (method-function-storage-form closure-generator) - other-initargs))) +; (existing (get-method generic-function qualifiers specs nil)) + (proto (method-prototype-for-gf generic-function-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))) (defun make-specializable (function-name &key (arglist nil arglistp)) - (declare (type boolean arglistp)) (cond ((not (null arglistp))) ((not (fboundp function-name))) ((fboundp 'function-arglist) @@ -975,7 +427,6 @@ (generic-function (make-instance 'standard-generic-function :name function-name)) (nrequireds 0)) - (declare (type index nrequireds)) (if (generic-function-p original) original (progn @@ -988,19 +439,14 @@ (when arglistp (setf (gf-pretty-arglist generic-function) arglist)) (when original - (add-named-method - function-name - 'standard-method - () - (make-list nrequireds :initial-element 't) - arglist - (when (call-store-method-function-p - generic-function - (class-prototype *the-class-standard-method*) - nil) - (make-std-documented-method-function original)) - original - NIL)) + (add-named-method function-name + () + (make-list nrequireds :initial-element 't) + arglist + (list :function + #'(lambda (args next-methods) + (declare (ignore next-methods)) + (apply original args))))) generic-function)))) @@ -1036,32 +482,26 @@ ;;; specializes (e.g. for a classical generic-function this is the ;;; list: (1)). ;;; -(declaim (ftype (function (T) (values index boolean list)) - compute-discriminating-function-arglist-info)) (defmethod compute-discriminating-function-arglist-info ((generic-function standard-generic-function)) - (declare (values number-of-required-arguments - rest-argument-p - specialized-argument-postions)) + ;;(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))) - (declare (type boolean restp) (list specialized-positions methods)) (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 (the index number-required) restp (sort specialized-positions #'<)))) + (values number-required restp (sort specialized-positions #'<)))) -(declaim (ftype (function (T T T T T) (values index boolean list)) - compute-discriminating-function-arglist-info-internal)) (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 (type index requireds)) + (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)) @@ -1069,7 +509,7 @@ ((memq arg '(&optional &rest &key)) (return (setq restp t))) ((memq arg lambda-list-keywords)) - (t (setf requireds (the index (1+ requireds)))))) + (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 @@ -1083,13 +523,9 @@ ;; 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 (the index (if (and number-of-requireds - (< (the index number-of-requireds) requireds)) - number-of-requireds - requireds)) + (values (min (or number-of-requireds requireds) requireds) (or restp - (and number-of-requireds - (/= (the index number-of-requireds) requireds))) + (and number-of-requireds (/= number-of-requireds requireds))) specialized-argument-positions))) (defun make-discriminating-function-arglist (number-required-arguments restp) @@ -1104,213 +540,54 @@ ;;; ;;; ;;; -(defstruct (arg-info - (:conc-name nil) - (:constructor make-arg-info ())) - arg-info-precedence - arg-info-metatypes - (arg-info-number-optional nil :type (or index null)) - (arg-info-key/rest-p nil :type boolean) - arg-info-keywords ;nil no keyword or rest allowed - ;(k1 k2 ..) each method must accept these keyword arguments - ;T must have &key or &rest - - gf-info-simple-accessor-type ; nil, reader, writer, boundp - (gf-precompute-dfun-and-emf-p nil :type boolean) ; set by set-arg-info - - gf-info-static-c-a-m-emf - (gf-info-c-a-m-emf-std-p nil :type boolean) - (arg-info-lambda-list :no-lambda-list)) - -(declaim (ftype (function (T) boolean) arg-info-valid-p)) -(defun arg-info-valid-p (arg-info) - (not (null (arg-info-number-optional arg-info)))) - -(declaim (ftype (function (T) boolean) arg-info-applyp)) -(defun arg-info-applyp (arg-info) - (or (plusp (the index (arg-info-number-optional arg-info))) - (arg-info-key/rest-p arg-info))) - -(declaim (ftype (function (T) index) arg-info-number-required)) -(defun arg-info-number-required (arg-info) - (length (the list (arg-info-metatypes arg-info)))) - -(declaim (ftype (function (T) index) arg-info-nkeys)) -(defun arg-info-nkeys (arg-info) - (count-if #'(lambda (x) (neq x 't)) (arg-info-metatypes arg-info))) - -(defun set-arg-info (gf precedence metatypes number-optional key/rest-p keywords - &optional (lambda-list nil lambda-list-p)) - (declare (type index number-optional) - (type boolean key/rest-p lambda-list-p)) - (let ((arg-info (gf-arg-info gf))) - (setf (arg-info-precedence arg-info) precedence) - (setf (arg-info-metatypes arg-info) metatypes) - (setf (arg-info-number-optional arg-info) number-optional) - (setf (arg-info-key/rest-p arg-info) key/rest-p) - (setf (arg-info-keywords arg-info) keywords) - (when lambda-list-p - (setf (arg-info-lambda-list arg-info) lambda-list)) - (setf (gf-precompute-dfun-and-emf-p arg-info) - (the boolean - (let* ((name (generic-function-name gf)) - (sym (if (atom name) name (cadr name))) - (pkg-list (cons *the-pcl-package* - (package-use-list *the-pcl-package*)))) - (not (null (memq (symbol-package sym) pkg-list)))))) - arg-info)) - -(defun new-arg-info-from-generic-function (gf lambda-list argument-precedence-order) - (multiple-value-bind (nreq nopt keysp restp allow-other-keys-p keywords) - (analyze-lambda-list lambda-list) - (declare (type index nreq nopt) - (type boolean keysp restp) - (type list keywords) - (ignore allow-other-keys-p)) - (let ((metatypes (make-list nreq)) - (precedence - (compute-precedence lambda-list nreq argument-precedence-order))) - (set-arg-info gf - precedence - metatypes - nopt - (or keysp restp) - keywords - lambda-list)))) - -(defun new-arg-info-from-method (gf method) - (multiple-value-bind (nreq nopt keysp restp) - (analyze-lambda-list (method-lambda-list method)) - (declare (type index nreq nopt) - (type boolean keysp restp)) - (set-arg-info gf - (compute-precedence (method-lambda-list method) nreq ()) - (mapcar #'raise-metatype - (make-list nreq) (method-specializers method)) - nopt - (or keysp restp) - ()))) - -(defun add-arg-info (generic-function method) - (let ((arg-info (gf-arg-info generic-function))) - (if (not (arg-info-valid-p arg-info)) - (new-arg-info-from-method generic-function method) - (flet ((lose (string &rest args) - (error "Attempt to add the method ~S to the generic function ~S.~%~ - But ~A" - method - generic-function - (apply #'format nil string args))) - (compare (x y) - (declare (type index x y)) - (if (> x y) "more" "fewer"))) - (multiple-value-bind (nreq nopt keysp restp allow-other-keys-p keywords) - (analyze-lambda-list (method-lambda-list method)) - (declare (type index nreq nopt) - (type boolean keysp restp allow-other-keys-p) - (type list keywords)) - (let ((gf-nreq (arg-info-number-required arg-info)) - (gf-nopt (arg-info-number-optional arg-info)) - (gf-key/rest-p (arg-info-key/rest-p arg-info)) - (gf-keywords (arg-info-keywords arg-info))) - (declare (type index gf-nreq gf-nopt) - (type boolean gf-key/rest-p)) - - (unless (= nreq gf-nreq) - (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." - (compare nopt gf-nopt))) - (unless (eq (or keysp restp) gf-key/rest-p) - (error "the method and generic function differ in whether they accept~%~ - rest or keyword arguments.")) - (when gf-keywords - (unless (or (and restp (not keysp)) - allow-other-keys-p - (every #'(lambda (k) (memq k keywords)) gf-keywords)) - (error - "the generic function requires each method to accept the keyword arguments~%~ - ~S. The method does not accept all of these." - gf-keywords))) - (set-arg-info generic-function - (arg-info-precedence arg-info) - (mapcar #'raise-metatype (arg-info-metatypes arg-info) - (method-specializers method)) - gf-nopt - gf-key/rest-p - gf-keywords))))))) - -(defun remove-arg-info (generic-function method) - (let ((arg-info (gf-arg-info generic-function))) - (set-arg-info generic-function - (arg-info-precedence arg-info) - (let* ((nreq (arg-info-number-required arg-info)) - (metatypes (make-list nreq)) - (old-methods (generic-function-methods generic-function)) - (methods (remove method old-methods))) - (declare (type index nreq)) - (dolist (specls (mapcar #'method-specializers methods)) - (setq metatypes (mapcar #'raise-metatype metatypes specls))) - metatypes) - (arg-info-number-optional arg-info) - (arg-info-key/rest-p arg-info) - (arg-info-keywords arg-info)))) + +(defmethod generic-function-lambda-list ((gf generic-function)) + (gf-lambda-list gf)) + +(defmethod gf-fast-method-function-p ((gf standard-generic-function)) + (gf-info-fast-mf-p (slot-value gf 'arg-info))) (defmethod initialize-instance :after ((gf standard-generic-function) &key (lambda-list nil lambda-list-p) argument-precedence-order) - (when lambda-list-p - (new-arg-info-from-generic-function gf lambda-list argument-precedence-order)) - (when (arg-info-valid-p (gf-arg-info gf)) - (update-dfun gf))) + (with-slots (arg-info) + gf + (if lambda-list-p + (set-arg-info gf + :lambda-list lambda-list + :argument-precedence-order argument-precedence-order) + (set-arg-info gf)) + (when (arg-info-valid-p arg-info) + (update-dfun gf)))) (defmethod reinitialize-instance :after ((gf standard-generic-function) &rest args &key (lambda-list nil lambda-list-p) argument-precedence-order) - (let* ((arg-info (gf-arg-info gf)) - (valid-p (arg-info-valid-p arg-info))) - (when lambda-list-p - (if (not valid-p) - (new-arg-info-from-generic-function gf lambda-list argument-precedence-order) - (setf (arg-info-lambda-list arg-info) lambda-list))) - (when (and *reinitialize-gf-updates-dfun-p* - valid-p args - (or (not (eq (car args) 'lambda-list)) - (cddr args))) + (with-slots (arg-info) + gf + (if lambda-list-p + (set-arg-info gf + :lambda-list lambda-list + :argument-precedence-order argument-precedence-order) + (set-arg-info gf)) + (when (and (arg-info-valid-p arg-info) + args + (or lambda-list-p (cddr args))) (update-dfun gf)))) ;;; ;;; ;;; -(defun compute-precedence (lambda-list nreq argument-precedence-order) - (declare (type list lambda-list argument-precedence-order)) - (declare (ignore nreq)) - (let ((nreq (analyze-lambda-list lambda-list))) - (declare (type index nreq)) - (if (null argument-precedence-order) - (let ((list nil))(dotimes (i nreq list) (push (- (1- nreq) i) list))) - (mapcar #'(lambda (x) (position x lambda-list)) argument-precedence-order)))) - - -(defmethod no-applicable-method (generic-function &rest args) - (cerror "Retry call to ~S" - "No matching method for the generic-function ~S,~@ - when called with arguments ~S." - generic-function args) - (apply generic-function args)) - -(defmethod no-next-method ((generic-function standard-generic-function) - (method standard-method) - &rest args) - (error - "No next method for generic function ~S in method ~S" - generic-function method args)) (proclaim '(special *lazy-dfun-compute-p*)) -(defun real-add-method (generic-function method) +(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~@ @@ -1319,7 +596,6 @@ (let* ((name (generic-function-name generic-function)) (qualifiers (method-qualifiers method)) - (lambda-list (method-lambda-list method)) (specializers (method-specializers method)) (existing (get-method generic-function qualifiers specializers nil))) ;; @@ -1331,240 +607,59 @@ (when existing (remove-method generic-function existing)) ;; (setf (method-generic-function method) generic-function) - (setf (method-function-name method) - (intern-function-name - (make-method-spec name - qualifiers - (unparse-specializers specializers)))) - (unless (slot-boundp generic-function 'lambda-list) - (let ((gf-lambda-list - (method-ll->generic-function-ll lambda-list))) - (fast-set-slot-value generic-function 'lambda-list gf-lambda-list - slow-slot-value) - (fast-set-slot-value generic-function 'argument-precedence-order - (lambda-list-required-args gf-lambda-list) - slow-slot-value))) - (add-arg-info generic-function method) (pushnew method (generic-function-methods generic-function)) (dolist (specializer specializers) (add-direct-method specializer method)) - (update-gf-info generic-function) - (update-dfun generic-function) - (maybe-update-constructors generic-function 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) + (maybe-update-constructors generic-function method)) method))) - + (defun real-remove-method (generic-function method) (if (neq generic-function (method-generic-function method)) (error "The method ~S is attached to the generic function~@ ~S. It can't be removed from the generic function~@ to which it is not attached." method (method-generic-function method)) - (let* ((methods (generic-function-methods generic-function)) + (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)) - (remove-arg-info generic-function 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) (maybe-update-constructors generic-function method) generic-function))) -;;; -;;; -;;; - -(declaim (ftype (function (T T) (values boolean boolean)) - specializer-applicable-using-type-p)) - + (defun compute-applicable-methods-function (generic-function arguments) (values (compute-applicable-methods-using-types generic-function (types-from-arguments generic-function arguments 'eql)))) - + (defmethod compute-applicable-methods ((generic-function generic-function) arguments) (values (compute-applicable-methods-using-types generic-function (types-from-arguments generic-function arguments 'eql)))) -(declaim (ftype (function (T T) (values T boolean)) - compute-applicable-methods-using-classes)) (defmethod compute-applicable-methods-using-classes ((generic-function generic-function) classes) (compute-applicable-methods-using-types generic-function (types-from-arguments generic-function classes 'class-eq))) -(declaim (ftype (function (T T) (values list boolean)) - compute-applicable-methods-using-types)) -(defun compute-applicable-methods-using-types (generic-function types) - (let ((definite-p t) (possibly-applicable-methods nil)) - (declare (type boolean definite-p)) - (dolist (method (generic-function-methods generic-function)) - (let ((specls (method-specializers method)) - (types types) - (possibly-applicable-p t) (applicable-p t)) - (declare (type boolean possibly-applicable-p applicable-p)) - (dolist (specl specls) - (multiple-value-bind (specl-applicable-p specl-possibly-applicable-p) - (specializer-applicable-using-type-p specl (pop types)) - (declare (type boolean specl-applicable-p - specl-possibly-applicable-p)) - (unless specl-applicable-p - (setq applicable-p nil)) - (unless specl-possibly-applicable-p - (setq possibly-applicable-p nil) - (return nil)))) - (when possibly-applicable-p - (unless applicable-p (setq definite-p nil)) - (push method possibly-applicable-methods)))) - (values (sort-applicable-methods generic-function - (nreverse possibly-applicable-methods) - types) - definite-p))) - -;This is used to speed up precompute-effective-methods. -(defvar *in-precompute-effective-methods-p* nil) - -;used only in specializer-applicable-using-type-p -(declaim (ftype (function (T T) (values boolean boolean)) - class-applicable-using-class-p)) -(defun class-applicable-using-class-p (specl type) - (let ((pred (class-on-class-precedence-list-p specl type))) - (declare (type boolean pred)) - (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)))))) - -;used only in map-all-orders -(declaim (ftype (function (T T) boolean) class-might-precede-p)) -(defun class-might-precede-p (class1 class2) - (if (not *in-precompute-effective-methods-p*) - (not (or (eq class1 class2) - (class-on-class-precedence-list-p class1 class2))) - (class-can-precede-p class1 class2))) - -(declaim (ftype (function (T T) (values boolean boolean)) saut-and-p)) -(defun saut-and-p (specl type) - (let ((applicable-p nil) - (all-solid-p T)) - (declare (type boolean applicable-p all-solid-p)) - (dolist (type (cdr type)) - (multiple-value-bind (appl poss-appl) - (specializer-applicable-using-type-p specl type) - (declare (type boolean appl poss-appl)) - (when appl (return (setq applicable-p t))) - (unless poss-appl (setq all-solid-p nil)))) - (values applicable-p (or applicable-p all-solid-p)))) - -(declaim (ftype (function (T T) (values boolean boolean)) saut-or-p)) -(defun saut-or-p (specl type) - ;; T T if all are definitely applicable. - ;; If any are definitely unapplicable, then definitely unapplicable. - ;; Else NIL NIL. - (let ((any-unapplicable-p NIL) - (definitely-unapplicable-p NIL)) - (declare (type boolean any-unapplicable-p definitely-unapplicable-p)) - (dolist (type (cdr type)) - (multiple-value-bind (appl poss-appl) - (specializer-applicable-using-type-p specl type) - (declare (type boolean appl poss-appl)) - (unless appl - (setq any-unapplicable-p t) - (when poss-appl - (return (setq definitely-unapplicable-p T)))))) - (values (not any-unapplicable-p) - (or (not any-unapplicable-p) definitely-unapplicable-p)))) - -(declaim (ftype (function (T T) (values boolean boolean)) saut-not-p)) -(defun saut-not-p (specl type) - (let ((ntype (cadr type))) - (values nil - (the boolean - (case (car ntype) - (class (saut-not-class-p specl ntype)) - (class-eq (saut-not-class-eq-p specl ntype)) - (eql (saut-not-eql-p specl ntype)) - (t (error "~s cannot handle the second argument ~s" - 'specializer-applicable-using-type-p type))))))) - -(declaim (ftype (function (T T) boolean) saut-not-class-p)) -(defun saut-not-class-p (specl ntype) - (not (class-on-class-precedence-list-p (cadr ntype) (type-class specl)))) - -(declaim (ftype (function (T T) boolean) saut-not-class-eq-p)) -(defun saut-not-class-eq-p (specl ntype) - (let ((class (case (car specl) - (eql (class-of (cadr specl))) - (class-eq (cadr specl))))) - (not (eq class (cadr ntype))))) - -(declaim (ftype (function (T T) boolean) saut-not-class-eql-p)) -(defun saut-not-eql-p (specl ntype) - (case (car specl) - (eql (not (eql (cadr specl) (cadr ntype)))) - (t t))) - -(declaim (ftype (function (T T) (values boolean boolean)) saut-class-p)) -(defun saut-class-p (specl type) - (case (car specl) - (class (class-applicable-using-class-p (cadr specl) (cadr type))) - (t (values - nil - (class-on-class-precedence-list-p (cadr type) (type-class specl)))))) - -(declaim (ftype (function (T T) (values boolean boolean)) saut-eq-p)) -(defun saut-class-eq-p (specl type) - (if (eq (car specl) 'eql) - (values nil (eq (class-of (cadr specl)) (cadr type))) - (let ((pred (case (car specl) - (class-eq (eq (cadr specl) (cadr type))) - (class (or (eq (cadr specl) (cadr type)) - (class-on-class-precedence-list-p - (cadr specl) (cadr type))))))) - (declare (type boolean pred)) - (values pred pred)))) - -(declaim (ftype (function (T T) (values boolean boolean)) saut-eql-p)) -(defun saut-eql-p (specl type) - (let ((pred - (case (car specl) - (eql (eql (cadr specl) (cadr type))) - (class-eq (eq (cadr specl) (class-of (cadr type)))) - (class (class-on-class-precedence-list-p - (cadr specl) (class-of (cadr type))))))) - (declare (type boolean pred)) - (values pred pred))) - -(defun specializer-applicable-using-type-p (specl type) - (declare (values applicable-p maybe-applicable-p)) - (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 it can't handle it, then it gives up and hopes the normal - ;; subtypep can figure it out. - (if (or (atom type) (eq (car type) 't)) - (values nil t) - (case (car type) - (and (saut-and-p specl type)) - (or (saut-or-p specl type)) - (not (saut-not-p specl type)) - (class (saut-class-p specl type)) - (class-eq (saut-class-eq-p specl type)) - (eql (saut-eql-p specl type)) - (t (multiple-value-bind (appl certain-p) - (subtypep (convert-to-system-type type) - (convert-to-system-type specl)) - (declare (type boolean appl certain-p)) - (values appl (or appl (not certain-p)))))))) - (defun proclaim-incompatible-superclasses (classes) (setq classes (mapcar #'(lambda (class) (if (symbolp class) @@ -1576,10 +671,7 @@ (unless (eq class other-class) (pushnew other-class (class-incompatible-superclass-list class)))))) -(declaim (ftype (function (T T) boolean) superclasses-compatible-p)) (defun superclasses-compatible-p (class1 class2) - (assure-finalized class1) - (assure-finalized class2) (let ((cpl1 (class-precedence-list class1)) (cpl2 (class-precedence-list class2))) (dolist (sc1 cpl1 t) @@ -1593,11 +685,11 @@ (built-in-class std-class structure-class) ; direct subclasses of pcl-class (standard-class funcallable-standard-class) ;; superclass metaobject - (class eql-specializer class-eq-specializer method ; method-combination + (class eql-specializer class-eq-specializer method method-combination generic-function slot-definition) ;; metaclass built-in-class - (number sequence character symbol ; direct subclasses of t, but not array - standard-object structure-object) + (number sequence character ; direct subclasses of t, but not array + standard-object structure-object) ; or symbol (number array character symbol ; direct subclasses of t, but not sequence standard-object structure-object) (complex float rational) ; direct subclasses of number @@ -1607,96 +699,6 @@ (string bit-vector) ; direct subclasses of vector )) -(declaim (ftype (function (T T) boolean) classes-have-common-subclass-p)) -(defun classes-have-common-subclass-p (class1 class2) - (or (eq class1 class2) - (let ((class1-subs (class-direct-subclasses class1))) - (or (not (null (memq class2 class1-subs))) - (dolist (class1-sub class1-subs nil) - (when (classes-have-common-subclass-p class1-sub class2) - (return t))))))) - -(defun order-specializers (specl1 specl2 index compare-classes-function) - (declare (type real-function compare-classes-function)) - (let ((type1 (specializer-type specl1)) - (type2 (specializer-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-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)))))))) - -(defun sort-applicable-methods (generic-function methods types) - (sort-methods methods - (arg-info-precedence (gf-arg-info generic-function)) - #'(lambda (class1 class2 index) - (declare (type index index)) - (let* ((class (type-class (nth index types))) - (cpl (class-precedence-list class))) - (if (memq class2 (memq class1 cpl)) - class1 class2))))) - -(defun sort-methods (methods precedence compare-classes-function) - (flet ((sorter (method1 method2) - (dolist (index precedence) - (declare (type index index)) - (let* ((specl1 (nth index (method-specializers method1))) - (specl2 (nth index (method-specializers method2))) - (order (order-specializers - specl1 specl2 index compare-classes-function))) - (when order - (return-from sorter (eq order specl1))))))) - (stable-sort methods #'sorter))) - -(defun map-all-orders (methods precedence function) - (declare (type real-function function)) - (let ((choices nil)) - (flet ((compare-classes-function (class1 class2 index) - (declare (ignore index)) - (let ((choice nil)) - (dolist (c choices nil) - (when (or (and (eq (first c) class1) - (eq (second c) class2)) - (and (eq (first c) class2) - (eq (second c) class1))) - (return (setq choice c)))) - (unless choice - (setq choice - (if (class-might-precede-p class1 class2) - (if (class-might-precede-p class2 class1) - (list class1 class2 nil t) - (list class1 class2 t)) - (if (class-might-precede-p class2 class1) - (list class2 class1 t) - (let ((name1 (class-name class1)) - (name2 (class-name class2))) - (if (and name1 name2 (symbolp name1) (symbolp name2) - (string< (symbol-name name1) - (symbol-name name2))) - (list class1 class2 t) - (list class2 class1 t)))))) - (push choice choices)) - (car choice)))) - (loop (funcall function - (sort-methods methods precedence #'compare-classes-function)) - (unless (dolist (c choices nil) - (unless (third c) - (rotatef (car c) (cadr c)) - (return (setf (third c) t)))) - (return nil)))))) @@ -1720,175 +722,63 @@ (defmethod specializer-class ((specializer eql-specializer)) (class-of (slot-value specializer 'object))) - - - (defvar *in-gf-arg-info-p* nil) -(defvar arg-info-reader (make-std-reader-method-function 'arg-info)) +(setf (symbol-function 'arg-info-reader) + (let ((mf (initialize-method-function + (make-internal-reader-method-function + 'standard-generic-function 'arg-info) + t))) + #'(lambda (&rest args) (funcall mf args nil)))) (defun types-from-arguments (generic-function arguments &optional type-modifier) - (let* ((arg-info (if *in-gf-arg-info-p* - (method-function-funcall arg-info-reader generic-function) - (let ((*in-gf-arg-info-p* t)) - (gf-arg-info generic-function)))) - (metatypes (arg-info-metatypes arg-info)) - (types-rev nil)) - (declare (type list metatypes)) - (dolist (mt metatypes) - #-(or excl kcl) - (declare (ignore mt)) - (unless arguments - (error "The function ~S requires at least ~D arguments" - (generic-function-name generic-function) - (length metatypes))) - (let ((arg (pop arguments))) - (push (if type-modifier `(,type-modifier ,arg) arg) types-rev))) - (values (nreverse types-rev) arg-info))) + (multiple-value-bind (nreq applyp metatypes nkeys arg-info) + (get-generic-function-info generic-function) + (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)))) (defun get-wrappers-from-classes (nkeys wrappers classes metatypes) - (declare (type index nkeys)) (let* ((w wrappers) (w-tail w) (mt-tail metatypes)) (dolist (class (if (listp classes) classes (list classes))) (unless (eq 't (car mt-tail)) (let ((c-w (class-wrapper class))) - (unless c-w (return-from get-wrappers-from-classes nil)) - (if (= nkeys 1) + (unless c-w (return-from get-wrappers-from-classes nil)) + (if (eql nkeys 1) (setq w c-w) (setf (car w-tail) c-w w-tail (cdr w-tail))))) (setq mt-tail (cdr mt-tail))) w)) -(declaim (ftype (function (T T T) (values T T)) accessor-values)) -(defun accessor-values (arg-info classes methods) - (let* ((accessor-type (gf-info-simple-accessor-type arg-info)) - (accessor-class (case accessor-type - (reader (car classes)) - (writer (cadr classes)) - (boundp (car classes)))) - (slot-name (and accessor-class - (class-standard-p accessor-class) - (accessor-method-slot-name (car methods)))) - (slotd (and accessor-class - (find-slot-definition accessor-class slot-name)))) - (if (and slotd (slot-accessor-std-p slotd accessor-type)) - (values accessor-type (slot-definition-location slotd)) - (values nil nil)))) - - -;;; -;;; Given a generic function and a set of arguments to that generic function, -;;; returns a mess of values. -;;; -;;; <function> The compiled effective method function for this set of -;;; arguments. -;;; -;;; <applicable> Sorted list of applicable methods. -;;; -;;; <wrappers> Is a single wrapper if the generic function has only -;;; one key, that is arg-info-nkeys of the arg-info is 1. -;;; Otherwise a list of the wrappers of the specialized -;;; arguments to the generic function. -;;; -;;; Note that all these wrappers are valid. This function -;;; does invalid wrapper traps when it finds an invalid -;;; wrapper and then returns the new, valid wrapper. -;;; -;;; <invalidp> True if any of the specialized arguments had an invalid -;;; wrapper, false otherwise. -;;; -;;; <type> READER or WRITER when the only method that would be run -;;; is a standard reader or writer method. To be specific, -;;; the value is READER when the method combination is eq to -;;; *standard-method-combination*; there are no applicable -;;; :before, :after or :around methods; and the most specific -;;; primary method is a standard reader method. -;;; -;;; <index> If <type> is READER or WRITER, and the slot accessed is -;;; an :instance slot, this is the index number of that slot -;;; in the object argument. -;;; - -(declaim (ftype (function (T T T) - (values T boolean T T T T)) - cache-miss-values)) -(defun cache-miss-values (gf args state) - (let* ((arg-info (method-function-funcall arg-info-reader gf)) - (metatypes (arg-info-metatypes arg-info)) - (for-accessor-p (eq state 'accessor)) - (for-cache-p (or (eq state 'caching) (eq state 'accessor))) - (cam-std-p (gf-info-c-a-m-emf-std-p arg-info)) - (args-tail args) (invalid-wrapper-p nil) - (wrappers-rev nil) (dfun-wrappers-rev nil) - (types-rev nil) (classes-rev nil)) - (declare (type list metatypes) - (type boolean for-accessor-p for-cache-p cam-std-p - invalid-wrapper-p)) - (dolist (mt metatypes) - (unless args-tail - (error "The function ~S requires at least ~D arguments" - (generic-function-name gf) (length metatypes))) - (let ((arg (pop args-tail))) - (multiple-value-bind (wrapper class type) - (if (eq mt 't) - (values nil *the-class-t* 't) - (let ((wrapper (wrapper-of arg))) - (when (invalid-wrapper-p wrapper) - (setq invalid-wrapper-p t) - (setq wrapper (fast-check-wrapper-validity arg))) - (push wrapper dfun-wrappers-rev) - (let ((wclass (wrapper-class wrapper))) - (values wrapper wclass `(class-eq ,wclass))))) - (push wrapper wrappers-rev) - (push class classes-rev) - (push type types-rev)))) - (let* ((wrappers (nreverse wrappers-rev)) - (classes (nreverse classes-rev)) - (types (mapcar #'(lambda (class) `(class-eq ,class)) classes))) - (multiple-value-bind (methods all-applicable-and-sorted-p) - (if cam-std-p - (compute-applicable-methods-using-types gf types) - (compute-applicable-methods-using-classes gf classes)) - (declare (type boolean all-applicable-and-sorted-p)) - (let ((sdfun (if (or all-applicable-and-sorted-p cam-std-p) - (funcall-function - (get-secondary-dispatch-function1 - gf methods types - all-applicable-and-sorted-p) - nil - (and for-cache-p wrappers)) - (default-secondary-dispatch-function gf)))) - (multiple-value-bind (accessor-type index) - (if (and for-accessor-p all-applicable-and-sorted-p methods) - (accessor-values arg-info classes methods) - (values nil nil)) - (values (if (and dfun-wrappers-rev (null (cdr dfun-wrappers-rev))) - (car dfun-wrappers-rev) - (nreverse dfun-wrappers-rev)) - invalid-wrapper-p - sdfun methods accessor-type index))))))) - (defun sdfun-for-caching (gf classes) (let ((types (mapcar #'class-eq-type classes))) (multiple-value-bind (methods all-applicable-and-sorted-p) (compute-applicable-methods-using-types gf types) - (method-function-funcall - (get-secondary-dispatch-function1 - gf methods types all-applicable-and-sorted-p) - nil (mapcar #'class-wrapper classes))))) + (function-funcall (get-secondary-dispatch-function1 + gf methods types nil t all-applicable-and-sorted-p) + nil (mapcar #'class-wrapper classes))))) (defun value-for-caching (gf classes) (let ((methods (compute-applicable-methods-using-types gf (mapcar #'class-eq-type classes)))) - (method-constant-value (car methods)))) + (method-function-get (or (method-fast-function (car methods)) + (method-function (car methods))) + :constant-value))) (defun default-secondary-dispatch-function (generic-function) #'(lambda (&rest args) (let ((methods (compute-applicable-methods generic-function args))) (if methods - (method-function-apply - (get-effective-method-function generic-function methods) - args) + (let ((emf (get-effective-method-function generic-function methods))) + (invoke-emf emf args)) (apply #'no-applicable-method generic-function args))))) (defun list-eq (x y) @@ -1899,8 +789,6 @@ (defvar *std-cam-methods* nil) -(declaim (ftype (function (T) (values T boolean)) - compute-applicable-methods-emf)) (defun compute-applicable-methods-emf (generic-function) (if (eq *boot-state* 'complete) (let* ((cam (gdefinition 'compute-applicable-methods)) @@ -1914,7 +802,6 @@ cam (list `(eql ,cam) t))))))) (values #'compute-applicable-methods-function t))) -(declaim (ftype (function (T) boolean) compute-applicable-methods-emf-std-p)) (defun compute-applicable-methods-emf-std-p (gf) (gf-info-c-a-m-emf-std-p (gf-arg-info gf))) @@ -1922,23 +809,23 @@ (defun update-all-c-a-m-gf-info (c-a-m-gf) (let ((methods (generic-function-methods c-a-m-gf))) - (if (every #'(lambda (old-method) - (memq old-method methods)) - *old-c-a-m-gf-methods*) + (if (and *old-c-a-m-gf-methods* + (every #'(lambda (old-method) + (member old-method methods)) + *old-c-a-m-gf-methods*)) (let ((gfs-to-do nil) (gf-classes-to-do nil)) (dolist (method methods) - (unless (memq method *old-c-a-m-gf-methods*) + (unless (member method *old-c-a-m-gf-methods*) (let ((specl (car (method-specializers method)))) (if (eql-specializer-p specl) (pushnew (specializer-object specl) gfs-to-do) (pushnew (specializer-class specl) gf-classes-to-do))))) (map-all-generic-functions #'(lambda (gf) - (when (or (memq gf gfs-to-do) - (let ((cpl (class-precedence-list (class-of gf)))) - (dolist (class gf-classes-to-do nil) - (if (memq class cpl) (return T))))) + (when (or (member gf gfs-to-do) + (dolist (class gf-classes-to-do nil) + (member class (class-precedence-list (class-of gf))))) (update-c-a-m-gf-info gf))))) (map-all-generic-functions #'update-c-a-m-gf-info)) (setq *old-c-a-m-gf-methods* methods))) @@ -1948,25 +835,24 @@ (update-gf-simple-accessor-type gf)) (defun update-c-a-m-gf-info (gf) - (multiple-value-bind (c-a-m-emf std-p) - (compute-applicable-methods-emf gf) - (declare (type boolean std-p)) - (let ((arg-info (gf-arg-info gf))) - (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 (early-gf-p gf) + (multiple-value-bind (c-a-m-emf std-p) + (compute-applicable-methods-emf gf) + (let ((arg-info (gf-arg-info gf))) + (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))))) (defun update-gf-simple-accessor-type (gf) (let ((arg-info (gf-arg-info gf))) (setf (gf-info-simple-accessor-type arg-info) (let* ((methods (generic-function-methods gf)) (class (and methods (class-of (car methods)))) - (type (and class - (cond ((eq class *the-class-standard-reader-method*) - 'reader) - ((eq class *the-class-standard-writer-method*) - 'writer) - ((eq class *the-class-standard-boundp-method*) - 'boundp))))) + (type (and class (cond ((eq class *the-class-standard-reader-method*) + 'reader) + ((eq class *the-class-standard-writer-method*) + 'writer) + ((eq class *the-class-standard-boundp-method*) + 'boundp))))) (when (and (gf-info-c-a-m-emf-std-p arg-info) type (dolist (method (cdr methods) t) @@ -1975,137 +861,51 @@ *standard-method-combination*)) type))))) -(declaim (ftype (function (T T) boolean) - accessor-methods-safe-to-use-slot-wrapper-optimizations-p)) -(defun accessor-methods-safe-to-use-slot-wrapper-optimizations-p - (methods type) - ;; Returns whether all accessor-methods Methods are safe for the slot-value - ;; wrapper optimizations. - (let ((safe-specializers - (ecase type - (reader *safe-slot-value-using-class-specializers*) - (writer *safe-set-slot-value-using-class-specializers*) - (boundp *safe-slot-boundp-using-class-specializers*)))) - (declare (type list safe-specializers)) - (dolist (method methods T) - (unless (member (mapcar #'class-name (method-specializers method)) - safe-specializers :test #'equal) - (return NIL))))) - -(declaim (ftype (function (T T) boolean) slot-values-safe-using-class-p)) -(defun slot-values-safe-using-class-p (class slotd) - (let ((types1 (list class (class-prototype class) slotd))) - (and (or *safe-to-use-slot-value-wrapper-optimizations-p* - (accessor-methods-safe-to-use-slot-wrapper-optimizations-p - (compute-applicable-methods #'slot-value-using-class types1) - 'reader)) - (or *safe-to-use-set-slot-value-wrapper-optimizations-p* - (accessor-methods-safe-to-use-slot-wrapper-optimizations-p - (compute-applicable-methods - (gdefinition '(setf slot-value-using-class)) (cons T types1)) - 'writer)) - (or *safe-to-use-slot-boundp-wrapper-optimizations-p* - (accessor-methods-safe-to-use-slot-wrapper-optimizations-p - (compute-applicable-methods #'slot-boundp-using-class types1) - 'boundp))))) - - -(declaim (ftype (function (T T T T) (values function boolean)) - get-accessor-method-function)) (defun get-accessor-method-function (gf type class slotd) - (let* ((types1 `((eql ,class) (class-eq ,class) (eql ,slotd))) + (let* ((std-method (standard-svuc-method type)) + (str-method (structure-svuc-method type)) + (types1 `((eql ,class) (class-eq ,class) (eql ,slotd))) (types (if (eq type 'writer) `(t ,@types1) types1)) (methods (compute-applicable-methods-using-types gf types)) - (std-p (accessor-methods-safe-to-use-slot-wrapper-optimizations-p - methods type))) - (declare (type list methods) (type boolean std-p)) + (std-p (null (cdr methods)))) (values (if std-p (get-optimized-std-accessor-method-function class slotd type) - (let ((wrappers NIL)) + (get-accessor-from-svuc-method-function + class slotd + (get-secondary-dispatch-function + gf methods types + `((,(car (or (member std-method methods) + (member str-method methods) + (error "error in get-accessor-method-function"))) + ,(get-optimized-std-slot-value-using-class-method-function + class slotd type))) (unless (and (eq type 'writer) (dolist (method methods t) (unless (eq (car (method-specializers method)) *the-class-t*) (return nil)))) - (setf wrappers (list (wrapper-of class) - (class-wrapper class) - (wrapper-of slotd))) - (when (eq type 'writer) - (setf wrappers (cons (class-wrapper *the-class-t*) wrappers)))) - (get-accessor-from-svuc-method-function - class slotd - (get-secondary-dispatch-function - gf methods types - (let ((alist ())) - (dolist (method (reverse methods)) - (push (list method - (method-function-for-caching method wrappers)) - alist)) - alist) - wrappers) - type))) + (let ((wrappers (list (wrapper-of class) + (class-wrapper class) + (wrapper-of slotd)))) + (if (eq type 'writer) + (cons (class-wrapper *the-class-t*) wrappers) + wrappers)))) + type)) std-p))) -(defvar *new-class* nil) - ;used by optimize-slot-value-by-class-p (vector.lisp) (defun update-slot-value-gf-info (gf type) - (let* ((old-safe-p - (ecase type - (reader *safe-to-use-slot-value-wrapper-optimizations-p*) - (writer *safe-to-use-set-slot-value-wrapper-optimizations-p*) - (boundp *safe-to-use-slot-boundp-wrapper-optimizations-p*))) - (newly-unsafe-p - (and old-safe-p - (not (accessor-methods-safe-to-use-slot-wrapper-optimizations-p - (generic-function-methods gf) type))))) - (declare (type boolean old-safe-p newly-unsafe-p)) - (unless *new-class* - (update-std-or-str-methods gf type)) - (when (and (standard-svuc-method type) (structure-svuc-method type)) - (flet ((update-class (class) - (when (class-finalized-p class) - (dolist (slotd (class-slots class)) - (multiple-value-bind (function std-p) - (get-accessor-method-function gf type class slotd) - #+kcl (si:turbo-closure function) - (setf (slot-accessor-std-p slotd type) std-p) - (update-slot-accessor-function slotd type function T)) - (when newly-unsafe-p - (ecase type - (reader (initialize-internal-slot-reader-gfs - (slot-definition-name slotd))) - (writer (initialize-internal-slot-writer-gfs - (slot-definition-name slotd))) - (boundp (initialize-internal-slot-boundp-gfs - (slot-definition-name slotd))))))))) - (if *new-class* - (update-class *new-class*) - (map-all-classes #'update-class 'slot-object)))) - (when newly-unsafe-p - (when *always-safe-to-use-slot-wrapper-optimizations-p* - (cerror "Continue even though previously compiled slot-value accesses - might ignore it?" - "Defining user ~S method when PCL was told to assume there - wouldn't be any (~S was set to T)." - (generic-function-name gf) - '*always-safe-to-use-slot-wrapper-optimizations-p*) - (setf *always-safe-to-use-slot-wrapper-optimizations-p* NIL)) - (setf *safe-to-use-slot-wrapper-optimizations-p* NIL) - (ecase type - (reader - (setf *safe-to-use-slot-value-wrapper-optimizations-p* NIL)) - (writer - (setf *safe-to-use-set-slot-value-wrapper-optimizations-p* NIL)) - (boundp - (setf *safe-to-use-slot-boundp-wrapper-optimizations-p* NIL)))) - (unless *safe-to-use-slot-wrapper-optimizations-p* - (dolist (gf *generic-functions-having-cached-closures*) - (update-dfun gf))) - (fix-dfuns-needing-update))) - - + (unless *new-class* + (update-std-or-str-methods gf type)) + (when (and (standard-svuc-method type) (structure-svuc-method type)) + (flet ((update-class (class) + (when (class-finalized-p class) + (dolist (slotd (class-slots class)) + (compute-slot-accessor-info slotd type gf))))) + (if *new-class* + (update-class *new-class*) + (map-all-classes #'update-class 'slot-object))))) (defvar *standard-slot-value-using-class-method* nil) (defvar *standard-setf-slot-value-using-class-method* nil) @@ -2159,78 +959,6 @@ 'structure-effective-slot-definition)) (set-structure-svuc-method type method))))))) -(defvar *free-hash-tables* (mapcar #'list '(eq equal eql))) - -(defmacro with-hash-table ((table test) &body forms) - `(let* ((.free. (assoc ',test *free-hash-tables*)) - (,table (if (cdr .free.) - (pop (cdr .free.)) - (make-hash-table :test ',test)))) - (multiple-value-prog1 - (progn ,@forms) - (clrhash ,table) - (push ,table (cdr .free.))))) - -(defmacro with-eq-hash-table ((table) &body forms) - `(with-hash-table (,table eq) ,@forms)) - -(defmacro with-equal-hash-table ((table) &body forms) - `(with-hash-table (,table equal) ,@forms)) - -(declaim (ftype (function (T T &optional T) - (values T T T T (or index null) boolean)) - make-accessor-table)) -(defun make-accessor-table (generic-function type &optional table) - (unless table (setq table (make-hash-table :test 'eq))) - (let ((methods (generic-function-methods generic-function)) - (all-index nil) - (no-class-slots-p t) - first second (size 0)) - (declare (type index size) (type boolean no-class-slots-p)) - ;; class -> {(specl slotd)} - (dolist (method methods) - (let* ((specializers (method-specializers method)) - (specl (if (eq type 'reader) - (car specializers) - (cadr specializers))) - (standard-object-p (class-standard-p specl)) - (slot-name (accessor-method-slot-name method))) - (declare (type boolean standard-object-p)) - (when (and (not standard-object-p) - (class-on-class-precedence-list-p - *the-class-structure-object* specl)) - (return-from make-accessor-table nil)) - (let ((slotd-table (gethash slot-name *name->class->slotd-table*))) - (when slotd-table - (maphash #'(lambda (class slotd) - (when (class-on-class-precedence-list-p specl class) - (unless (and (or standard-object-p - (class-standard-p class)) - (slot-accessor-std-p slotd type)) - (return-from make-accessor-table nil)) - (push (cons specl slotd) (gethash class table)))) - slotd-table))))) - (maphash #'(lambda (class specl+slotd-list) - (assure-finalized class) - (dolist (sclass (class-precedence-list class) - (error "This can't happen")) - (let ((a (assq sclass specl+slotd-list))) - (when a - (let* ((slotd (cdr a)) - (index (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)) - (setf size (the index (1+ 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 mec-all-classes-internal (spec precompute-p) (cons (specializer-class spec) (and (classp spec) @@ -2276,14 +1004,12 @@ (wrappers (unless (eq nkeys 1) (make-list nkeys))) (precompute-p (gf-precompute-dfun-and-emf-p arg-info)) (default '(default))) - (declare (type index nkeys) - (type boolean precompute-p)) (flet ((add-class-list (classes) (when (or (null new-class) (memq new-class classes)) (let ((wrappers (get-wrappers-from-classes - nkeys wrappers classes metatypes))) + nkeys wrappers classes metatypes))) (when (and wrappers - (eq default (probe-cache cache wrappers default))) + (eq default (probe-cache cache wrappers default))) (let ((value (cond ((eq valuep t) (sdfun-for-caching generic-function classes)) ((eq valuep :constant-value) @@ -2296,28 +1022,24 @@ (mec-all-class-lists (method-specializers method) precompute-p)))) cache))) -(declaim (ftype (function (T) boolean) methods-contain-eql-specializer-p)) -(defun methods-contain-eql-specializer-p (methods) - (dolist (method methods nil) - (when (dolist (spec (method-specializers method) nil) - (when (eql-specializer-p spec) (return t))) - (return t)))) - (defmacro class-test (arg class) (cond ((eq class *the-class-t*) 't) ((eq class *the-class-slot-object*) + #+new-kcl-wrapper + `(or (std-instance-p ,arg) + (fsc-instance-p ,arg)) + #-new-kcl-wrapper `(not (eq *the-class-built-in-class* - (wrapper-class (std-instance-wrapper (class-of ,arg)))))) + (wrapper-class (std-instance-wrapper (class-of ,arg)))))) + #-new-kcl-wrapper ((eq class *the-class-standard-object*) - `(or (std-instance-p ,arg) - (fsc-instance-p ,arg) - (typep ,arg 'standard-object))) - ((or (structure-class-p class) - (eq (class-of class) *the-class-built-in-class*)) - `(typep ,arg ',(class-name class))) + `(or (std-instance-p ,arg) (fsc-instance-p ,arg))) + ((eq class *the-class-structure-object*) + `(memq ',class (class-precedence-list (class-of ,arg)))) + ;; TYPEP is now sometimes faster than doing memq of the cpl (t - `(memq ',class (class-precedence-list (class-of ,arg)))))) + `(typep ,arg ',(class-name class))))) (defmacro class-eq-test (arg class) `(eq (class-of ,arg) ',class)) @@ -2333,9 +1055,13 @@ (defmacro scase (arg &rest clauses) ; This is case, but without gensyms `(let ((.case-arg. ,arg)) (cond ,@(mapcar #'(lambda (clause) - (list* (cond ((listp (car clause)) - `(memq .case-arg. ',(car clause))) - ((memq (car clause) '(t otherwise)) + (list* (cond ((null (car clause)) + nil) + ((consp (car clause)) + (if (null (cdar clause)) + `(eql .case-arg. ',(caar clause)) + `(member .case-arg. ',(car clause)))) + ((member (car clause) '(t otherwise)) `t) (t `(eql .case-arg. ',(car clause)))) @@ -2379,9 +1105,7 @@ (dnet-methods-p false-value))) 'mcase 'scase)) - (type-sym (if (memq (cadr type) '(t nil otherwise)) - `(,(cadr type)) - (cadr type)))) + (type-sym `(,(cadr type)))) `(,case-sym ,arg (,type-sym ,true-value) ,@false-clauses)) @@ -2405,7 +1129,7 @@ (class-eq (cadr type)) (class (cadr type))))) -(defun precompute-effective-methods (gf &optional classes-list-p) +(defun precompute-effective-methods (gf caching-p &optional classes-list-p) (let* ((arg-info (gf-arg-info gf)) (methods (generic-function-methods gf)) (precedence (arg-info-precedence arg-info)) @@ -2417,10 +1141,13 @@ (when methods (when classes-list-p (push (mapcar #'class-from-type known-types) classes-list)) - (map-all-orders + (let ((no-eql-specls-p (not (methods-contain-eql-specializer-p methods)))) + (map-all-orders methods precedence #'(lambda (methods) - (get-secondary-dispatch-function gf methods known-types))))) + (get-secondary-dispatch-function1 + gf methods known-types + nil caching-p no-eql-specls-p)))))) #'(lambda (position type true-value false-value) (declare (ignore position type true-value false-value)) nil) @@ -2441,132 +1168,167 @@ (unless (eq (car new-type) 'not) (setq so-far (mapcan #'(lambda (type) - (unless (*subtypep type new-type) + (unless (*subtypep new-type type) (list type))) so-far))) (if (null so-far) new-type `(and ,new-type ,@so-far))))) -(defun generate-discrimination-net-internal-do-column (p-tail contenders known-types) - (declare (special types methods-function nreq metatypes)) - (if p-tail - (let* ((position (car p-tail)) - (known-type (or (nth position types) t))) - (declare (type index position)) - (if (eq (nth position metatypes) 't) - (generate-discrimination-net-internal-do-column - (cdr p-tail) contenders (cons (cons position known-type) known-types)) - (generate-discrimination-net-internal-do-methods - p-tail contenders known-type () known-types))) - (funcall-function methods-function contenders - (let ((k-t (make-list (the index nreq)))) - (dolist (index+type known-types) - (setf (nth (the index (car index+type)) k-t) - (cdr index+type))) - k-t)))) - -(defun generate-discrimination-net-internal-do-methods - (p-tail contenders known-type winners known-types) - (declare (special test-function type-function)) - ;; - ;; <contenders> - ;; is a (sorted) list of methods that must be discriminated - ;; <known-type> - ;; is the type of this argument, constructed from tests already made. - ;; <winners> - ;; is a (sorted) list of methods that are potentially applicable - ;; after the discrimination has been made. - ;; - (if (null contenders) - (generate-discrimination-net-internal-do-column - (cdr p-tail) winners (cons (cons (car p-tail) known-type) known-types)) - (let* ((position (car p-tail)) - (method (car contenders)) - (specl (nth position (method-specializers method))) - (type (funcall-function type-function (type-from-specializer specl)))) - (declare (type index position)) - (multiple-value-bind (app-p maybe-app-p) - (specializer-applicable-using-type-p type known-type) - (declare (type boolean app-p maybe-app-p)) - (flet ((determined-to-be (truth-value) - (if truth-value app-p (not maybe-app-p))) - (do-if (truth &optional implied) - (let ((ntype (if truth type `(not ,type)))) - (generate-discrimination-net-internal-do-methods p-tail - (cdr contenders) - (if implied - known-type - (augment-type ntype known-type)) - (if truth - (append winners `(,method)) - winners) - known-types)))) - (cond ((determined-to-be nil) (do-if nil t)) - ((determined-to-be t) (do-if t t)) - (t (funcall-function test-function position type - (do-if t) (do-if nil))))))))) - -(defun generate-discrimination-net-internal +#+lcl3.0 (dont-use-production-compiler) + +(defun generate-discrimination-net-internal (gf methods types methods-function test-function type-function) - (declare (special 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))) - (declare (type index nreq)) - (declare (special nreq metatypes)) - (generate-discrimination-net-internal-do-column precedence methods ()))) + (labels ((do-column (p-tail contenders known-types) + (if p-tail + (let* ((position (car p-tail)) + (known-type (or (nth position types) t))) + (if (eq (nth position metatypes) 't) + (do-column (cdr p-tail) contenders + (cons (cons position known-type) known-types)) + (do-methods p-tail 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) + ;; + ;; <contenders> + ;; is a (sorted) list of methods that must be discriminated + ;; <known-type> + ;; is the type of this argument, constructed from tests already made. + ;; <winners> + ;; is a (sorted) list of methods that are potentially applicable + ;; 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)) + (method (car contenders)) + (specl (nth position (method-specializers method))) + (type (funcall type-function (type-from-specializer specl)))) + (multiple-value-bind (app-p maybe-app-p) + (specializer-applicable-using-type-p type known-type) + (flet ((determined-to-be (truth-value) + (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 + (cdr contenders) + (if implied + known-type + (augment-type ntype known-type)) + (if truth + (append winners `(,method)) + winners) + known-types)))) + (cond ((determined-to-be nil) (do-if nil t)) + ((determined-to-be t) (do-if t t)) + (t (funcall test-function position type + (do-if t) (do-if nil)))))))))) + (do-column precedence methods ())))) + +#+lcl3.0 (use-previous-compiler) (defun compute-secondary-dispatch-function (generic-function net &optional method-alist wrappers) - (funcall-function (compute-secondary-dispatch-function1 generic-function net) + (function-funcall (compute-secondary-dispatch-function1 generic-function net) method-alist wrappers)) +(defvar *eq-case-table-limit* 15) (defvar *case-table-limit* 10) -(declaim (type index *case-table-limit*)) + +(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)))) + (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)))) + (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")) + (ecase type + (:simple + `(if (,(if eq-p 'eq 'eql) ,key (car ,info)) + (cdr ,info) + ,default)) + (:assoc + `(dolist (e ,info ,default) + (when (,(if eq-p 'eq 'eql) (car e) ,key) + (return (cdr e))))) + (:hash-table + `(gethash ,key ,info ,default)))) (defun net-test-converter (form) - (cond ((and (consp form) (eq (car form) 'methods)) + (if (atom form) + (default-test-converter form) + (case (car form) + ((invoke-effective-method-function invoke-fast-method-call) + '.call.) + (methods '.methods.) - ((and (consp form) (eq (car form) 'unordered-methods)) + (unordered-methods '.umethods.) - ((and (consp form) (eq (car form) 'mcase) - (< *case-table-limit* (length (the list (cddr form))))) - '.mcase.) - (t (default-test-converter form)))) - -(declaim (ftype (function (T T T) (values T list)) net-code-converter)) -(defun net-code-converter (form metatypes applyp) - (cond ((and (consp form) (or (eq (car form) 'methods) - (eq (car form) 'unordered-methods))) + (mcase + `(mlookup ,(cadr form) nil nil ,@(compute-mcase-parameters (cddr form)))) + (t (default-test-converter form))))) + +(defun net-code-converter (form) + (if (atom form) + (default-code-converter form) + (case (car form) + ((methods unordered-methods) (let ((gensym (gensym))) - (values (make-dfun-call metatypes applyp gensym) + (values gensym (list gensym)))) - ((and (consp form) (eq (car form) 'mcase) - (< *case-table-limit* (length (the list (cddr form))))) - (let ((gensym (gensym)) (default (gensym))) - (values (make-dfun-call metatypes applyp - `(gethash ,(cadr form) ,gensym ,default)) + (mcase + (let ((mp (compute-mcase-parameters (cddr form))) + (gensym (gensym)) (default (gensym))) + (values `(mlookup ,(cadr form) ,gensym ,default ,@mp) (list gensym default)))) - (t (default-code-converter form)))) + (t + (default-code-converter form))))) (defun net-constant-converter (form generic-function) (or (let ((c (methods-converter form generic-function))) (when c (list c))) - (cond ((and (consp form) (eq (car form) 'mcase) - (< *case-table-limit* (length (the list (cddr form))))) - (let* ((list (mapcar #'(lambda (clause) + (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)))) + (methods-converter + meth generic-function)))) (cddr form))) (default (car (last list)))) - (list (list* '.table. (nbutlast list)) + (list (list* ':mcase mp (nbutlast list)) (cdr default)))) - (t (default-constant-converter form))))) + (t + (default-constant-converter form)))))) (defun methods-converter (form generic-function) (cond ((and (consp form) (eq (car form) 'methods)) @@ -2582,35 +1344,67 @@ constant)) (defun convert-table (constant method-alist wrappers) - (when (and (consp constant) - (eq (car constant) '.table.)) - (let ((table (make-hash-table :test 'eql))) - (dolist (k+v (cdr constant)) - (setf (gethash (car k+v) table) - (convert-methods (cdr k+v) method-alist wrappers))) - table))) - -(defun compute-secondary-dispatch-function1 (generic-function net) + (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) (if (eq (car net) 'methods) (get-effective-method-function1 generic-function (cadr net)) - (multiple-value-bind (cfunction constants) - (let* ((arg-info (gf-arg-info generic-function)) - (metatypes (arg-info-metatypes arg-info)) - (applyp (arg-info-applyp arg-info))) - (declare (type boolean applyp)) - (get-function1 `(lambda ,(make-dfun-lambda-list metatypes applyp) ,net) + (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 `(lambda ,arglist + ,(unless function-p + `(declare (ignore .pv-cell. .next-method-call.))) + (let ((emf ,net)) + ,(make-emf-call metatypes applyp 'emf))) #'net-test-converter + #'net-code-converter #'(lambda (form) - (net-code-converter form metatypes applyp)) - #'(lambda (form) - (net-constant-converter form generic-function)))) - #'(lambda (method-alist wrappers) - (apply-function - cfunction - (mapcar #'(lambda (constant) - (or (convert-table constant method-alist wrappers) - (convert-methods constant method-alist wrappers))) - constants)))))) + (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) @@ -2622,73 +1416,8 @@ (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))) - (apply-function emf args)))) - -;;; -;;; NOTE: We are assuming a restriction on user code that the method -;;; combination must not change once it is connected to the -;;; generic function. -;;; -;;; This has to be legal, because otherwise any kind of method -;;; lookup caching couldn't work. See this by saying that this -;;; 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! -(defvar *effective-method-table* (make-hash-table :test 'eq)) - - -(defun get-secondary-dispatch-function (gf methods types &optional - method-alist wrappers) - (funcall-function (get-secondary-dispatch-function1 - gf methods types - (not (methods-contain-eql-specializer-p methods))) - method-alist wrappers)) - -(defun get-secondary-dispatch-function1 (gf methods types - &optional all-applicable-p - (all-sorted-p t)) - (if (null methods) - #'(lambda (method-alist wrappers) - (declare (ignore method-alist wrappers)) - #'(lambda (&rest args) - (apply #'no-applicable-method gf args))) - (let* ((key (car methods)) - (ht-value (or (gethash key *effective-method-table*) - (setf (gethash key *effective-method-table*) - (cons nil nil))))) - (if (and (null (cdr methods)) all-applicable-p) ; the most common case - (or (car ht-value) - (setf (car ht-value) - (get-secondary-dispatch-function2 - gf methods types all-applicable-p all-sorted-p))) - (let ((akey (list methods (if all-applicable-p 'all-applicable types)))) - (or (cdr (assoc akey (cdr ht-value) :test #'equal)) - (let ((value (get-secondary-dispatch-function2 - gf methods types all-applicable-p all-sorted-p))) - (push (cons akey value) (cdr ht-value)) - value))))))) - -(defun get-secondary-dispatch-function2 (gf methods types all-applicable-p all-sorted-p) - (if (and all-applicable-p all-sorted-p) - (let* ((combin (generic-function-method-combination gf)) - (effective (compute-effective-method gf combin methods))) - (make-effective-method-function1 gf effective)) - (let ((net (generate-discrimination-net - gf methods types all-sorted-p))) - (compute-secondary-dispatch-function1 gf net)))) - -(defun get-effective-method-function (gf methods &optional method-alist wrappers) - (funcall-function (get-secondary-dispatch-function1 gf methods nil t) - method-alist wrappers)) + (invoke-emf emf args)))) -(defun get-effective-method-function1 (gf methods &optional (sorted-p t)) - (get-secondary-dispatch-function1 gf methods nil t sorted-p)) - -(defun get-dispatch-function (gf) - (let ((methods (generic-function-methods gf))) - (funcall-function (get-secondary-dispatch-function1 gf methods nil nil nil) - nil nil))) ;;; ;;; The value returned by compute-discriminating-function is a function @@ -2772,29 +1501,17 @@ ;;; ;;; ;;; -(defun gf-dfun-cache (gf) - (let ((state (gf-dfun-state gf))) - (typecase state - (function nil) - (cons (cadr state))))) - -(defun gf-dfun-info (gf) - (let ((state (gf-dfun-state gf))) - (typecase state - (function nil) - (cons (cddr state))))) - (defun slot-value-using-class-dfun (class object slotd) (declare (ignore class)) - (method-function-funcall (slot-definition-reader-function slotd) object)) + (function-funcall (slot-definition-reader-function slotd) object)) (defun setf-slot-value-using-class-dfun (new-value class object slotd) (declare (ignore class)) - (method-function-funcall (slot-definition-writer-function slotd) new-value object)) + (function-funcall (slot-definition-writer-function slotd) new-value object)) (defun slot-boundp-using-class-dfun (class object slotd) (declare (ignore class)) - (method-function-funcall (slot-definition-boundp-function slotd) object)) + (function-funcall (slot-definition-boundp-function slotd) object)) (defmethod compute-discriminating-function ((gf standard-generic-function)) (with-slots (dfun-state arg-info) gf @@ -2818,38 +1535,18 @@ (function dfun-state) (cons (car dfun-state))))) -(defun set-dfun (generic-function &optional dfun cache info) - (setf (gf-dfun-state generic-function) - (if (and dfun (or cache info)) - (list* dfun cache info) - dfun)) - dfun) - -(defun update-dfun (generic-function &optional dfun cache info) - (let ((ocache (gf-dfun-cache generic-function))) - (set-dfun generic-function dfun cache info) - (let ((dfun (compute-discriminating-function generic-function)) - (gf-name (generic-function-name generic-function))) - (unless (eq 'default-method-only (type-of (gf-dfun-info generic-function))) - (setq dfun (doctor-dfun-for-the-debugger - generic-function - #+cmu dfun #-cmu (set-function-name dfun gf-name)))) - (set-funcallable-instance-function generic-function dfun) - #+cmu (set-function-name generic-function gf-name) - (when (and ocache (not (eq ocache cache))) (free-cache ocache)) - (setf *dfuns-needing-update* (remove gf-name *dfuns-needing-update*)) - dfun))) - (defmethod update-gf-dfun ((class std-class) gf) (let ((*new-class* class) - (name (generic-function-name gf)) + #|| (name (generic-function-name gf)) ||# (arg-info (gf-arg-info gf))) - (cond ((eq name 'slot-value-using-class) + (cond #|| + ((eq name 'slot-value-using-class) (update-slot-value-gf-info gf 'reader)) ((equal name '(setf slot-value-using-class)) (update-slot-value-gf-info gf 'writer)) ((eq name 'slot-boundp-using-class) (update-slot-value-gf-info gf 'boundp)) + ||# ((gf-precompute-dfun-and-emf-p arg-info) (multiple-value-bind (dfun cache info) (make-final-dfun-internal gf) @@ -2859,65 +1556,30 @@ ;;; ;;; ;;; -(declaim (ftype (function (T) (values list boolean)) function-keywords)) (defmethod function-keywords ((method standard-method)) (multiple-value-bind (nreq nopt keysp restp allow-other-keys-p keywords) - (analyze-lambda-list (method-lambda-list method)) - (declare (type boolean allow-other-keys-p)) + (analyze-lambda-list (if (consp method) + (early-method-lambda-list method) + (method-lambda-list method))) (declare (ignore nreq nopt keysp restp)) (values keywords allow-other-keys-p))) (defun method-ll->generic-function-ll (ll) - ;; The generic-function lambda-list is the same as the method-lambda - ;; list, except that no default initial values or supplied-p - ;; parameters are allowed for optional or keyword arguments, and - ;; &aux parameters are not allowed (and therefore removed). - (let ((collection NIL)) - (dolist (element ll) - (cond ((listp element) - (push (car element) collection)) - ((eq element '&aux) - (return)) - (T (push element collection)))) - (nreverse collection))) - + (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 ;;; the spec. The lambda list it constructs is the pretty union of the ;;; lambda lists of all the methods. It doesn't take method applicability ;;; into account at all yet. ;;; - -(declaim (ftype (function (T) (values list list boolean list boolean)) - method-pretty-arglist)) -(defmethod method-pretty-arglist ((method standard-method)) - (let ((required ()) - (optional ()) - (rest-p nil) - (key ()) - (allow-other-keys-p nil) - (state 'required) - (arglist (method-lambda-list method))) - (declare (type boolean rest-p allow-other-keys-p)) - (dolist (arg arglist) - (cond ((eq arg '&optional) (setq state 'optional)) - ((eq arg '&rest) (setq state 'rest)) - ((eq arg '&key) (setq state 'key)) - ((eq arg '&allow-other-keys) (setq allow-other-keys-p 't)) - ((memq arg lambda-list-keywords)) - (t - (ecase state - (required (push arg required)) - (optional (push arg optional)) - (key (push arg key)) - (rest (setq rest-p arg)))))) - (values (nreverse required) - (nreverse optional) - rest-p - (nreverse key) - allow-other-keys-p))) - (defmethod generic-function-pretty-arglist ((generic-function standard-generic-function)) (let ((methods (generic-function-methods generic-function)) @@ -2947,3 +1609,29 @@ (nconc required arglist))))) +(defmethod method-pretty-arglist ((method standard-method)) + (let ((required ()) + (optional ()) + (rest nil) + (key ()) + (allow-other-keys nil) + (state 'required) + (arglist (method-lambda-list method))) + (dolist (arg arglist) + (cond ((eq arg '&optional) (setq state 'optional)) + ((eq arg '&rest) (setq state 'rest)) + ((eq arg '&key) (setq state 'key)) + ((eq arg '&allow-other-keys) (setq allow-other-keys 't)) + ((memq arg lambda-list-keywords)) + (t + (ecase state + (required (push arg required)) + (optional (push arg optional)) + (key (push arg key)) + (rest (setq rest arg)))))) + (values (nreverse required) + (nreverse optional) + rest + (nreverse key) + allow-other-keys))) + diff --git a/pcl/notes.text b/pcl/notes.text index 99f527877..fef7419e7 100644 --- a/pcl/notes.text +++ b/pcl/notes.text @@ -1,231 +1,280 @@ - -These notes correspond to the "July 92 PCL" version of PCL. +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 march-92-notes.text and may-day-notes.text also. - Most of those files still apply.] -Newly supported: - -accessor-method-slot-definition -no-next-method -generic-function-argument-precedence-order -reader-method-class -writer-method-class -(setf class-name) - -defgeneric :method option - -class-default-initargs, class-precedence-list, class-prototype, - and class-slots now signal errors when class is not finalized - (as specified in AMOP ch 6). +[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 of specialized parameter inside of defmethod. - Optimization for standard cases of slot-value everywhere else. - -Additional support for structures - Redefines defstruct macro to give PCL access to all structure information - for structure classes in addition to calling the original lisp defstruct. - -All AMOP generic-functions now exported. + 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 ------------------------- -New gfs which obey AMOP ch 6, and some caveats: - -documentation - Stored in all classes, pcl::documentation works as defined. -generic-function-declarations - Stored, but ignored. - -make-method-lambda -method-function - Compatible with AMOP, but will require additions to - compute-discriminating-function and compute-effective-method to - make fully useful. - - In July 92 PCL, method-function returns the documented AMOP - method-function specified by the lambda returned by make-method-lambda. - However, that method-function is not actually used in method function - dispatch. Instead, PCL's make-method-lambda and expand-defmethod also - create an optimized method function (method-optimized-function) or - closure generator (method-closure-generator) that it actually uses for - method function caching and dispatch. This is the same optimized - function whose lambda-list is the lambda-list of the method used in - previous versions of PCL. There are two cases to worry about with this: - - 1. The user specializes their own method on make-method-lambda without - redefining compute-discriminating-function or being careful to make - sure the method-optimized-function is set up properly (as done by the - standard make-method-lambda). Expand-defmethod will detect this case - and create a method-optimized-function that calls the method-function - created by the new make-method-lambda with the parameters *of the - normal make-method-lambda*, i.e. (args methods). This should work - for most cases, albeit slowly, but will fail if the user's modification - expects a different lambda list (as in the example of the AMOP, p. 209). - - 2. The user specializes their own method on make-method-lambda, but also - specializes compute-discriminating-function to call method-function - directly. This should work. - - -------------------------- -Functions which DO NOT obey AMOP: +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. - See march-92-notes.text - -compute-discriminating-function - [the resulting function works differently different because - compute-effective-method is different, and because make-method-lambda - does not exist.] + But see "Initialization of method metaobjects", below. compute-effective-method - Returns only one value. - -------------------------- -Miscellaneous optimizations: - -Optimizations of slot-value of specialized parameter inside of - defmethod: - - 1. Closure variables are now used instead of lookup permutation - vectors to store slot indices when the effective methods are - cached each set of parameter classes they're called on (which - is now all the time, using March 92's optimizations), saving an - aref per slot access. - 2. The cached effective methods optimize slot-access based on the type - of slot indices for the cached parameters. There are three cases: - (a) The most common case -- all specialized parameter slot - accesses within the defmethod are on :instance allocated slots - on standard instances without user-defined slot-value-using-class - methods. In this case, the cached closure for the method - directly accesses the slot through an aref on the standard - instance, without having to call (typep x 'fixnum) or figure out - what type of instance it is. - (b) If one of the slot accesses is on a non-:instance allocated slot, - on a non-standard instance, or has a user-defined slot-value-using-class - method, and store-optimized-method-lambda-p is true for the - generic-function and method (the default defined in low.lisp being - *compile-slot-access-method-functions-at-runtime-p* is T), then the - method to be cached is compiled at runtime to optimize the slot accesses - from a stored version of the method-lambda. The compiled method to be - cached directly codes in each slot access for the particular index - and the type of the instance. - (c). If there are non-standard slot accesses, as in case (b), but - store-optimized-method-lambda-p for the generic-function and method - is NIL, then the cached methods are not compiled at runtime. Instead, - the cached effective method is similar to previous PCL's, i.e. - having to check the index and instance type for each slot access, - though looking up the cached index in a closure variable rather than - a permutation vector to save an aref. - -Further optimizations of slot-value outside of defmethod or inside - of defmethod, but not of a specialized parameter: - - 1. If no non-standard specialized methods have been defined on - slot-value-using-class, then slot-value directly looks up the - value of the slot without calling any generic-functions or functions. - - 2. If non-standard specialized methods have been defined on - slot-value-using-class, then PCL arranges to call an automatically - created generic function that has one method: a reader method defined - on class slot-object (as in March 92 PCL). This optimized generic-function - is now called whether or not the slot-name is constant. - -Make-instance, shared-initialize, and allocate-instance speeded up by: - 1. Implementing suggested instance slot-vector allocation optimization - of the AMOP that copies a slot-vector whose side-effect-free slots - are already initialized. - 2. Using internal copy of slot-definitions (as structures) to speed - up time-intensive internal slot accesses (also speeds up - slot-value-using-class). - 3. Usually assuming and assuring that all slot init-functions are compiled. - -declarations of variable types throughout PCL where applicable. - -avoids unnecessary class updates by lazier class finalization, giving - faster compiling and loading. + Returns only one value. +generic-function-argument-precedence-order + Not yet defined. Can get this information from the arg-info structure. -------------------------- -Miscellaneous optional optimizations (see global variables at beginning -of file low.lisp for full options): - -Variable *compile-all-method-functions-p* can be set to T, forcing all - method functions to be compiled and allowing method function dispatch - code to assume they are compiled. Default is NIL. - -Generic function store-method-function-p (generic-function method initargs) - can be specialized to return NIL if the (normally unused) documented - method-functions are not needed. Saves some space and compile time. - Default returns T. Variable *standard-store-method-function-p*, which - is what the default store-method-function-p method looks up, can be - set to NIL if it is known that documented method functions will never - be needed. - -Generic function store-optimized-method-lambda-p (generic-function method initargs) - can be specialized to return NIL if it is not desireable to optimize - defmethod slot-accesses for non :instance allocated slots by compiling - the cached methods at runtime. (This might be the case if your lisp's - compiler is slow, e.g. KCL, and each such method will only be called a - few times, so that the optimization isn't worth the added runtime compile - time. Alternatively, *compile-slot-access-method-functions-at-runtime-p* - in low.lisp can be set to NIL to make this the default for all methods. - -------------------------- -Useful extensions to CLOS and AMOP: - -boundp-method-class -finalize-all-classes - -trace-methods - Traces all individual methods of a generic-function (as per trace-method). - -(setf standard-instance-access) -(setf funcallable-standard-instance-access) - Functions to allow direct setting of instance slots - (as standard-instance-access and funcallable-standard-instance-access). - -standard-instance-slot-value -(setf standard-instance-slot-value) -standard-instance-slot-boundp -funcallable-standard-instance-slot-value -(setf funcallable-standard-instance-slot-value) -funcallable-standard-instance-slot-boundp -structure-instance-slot-value -(setf structure-instance-slot-value) -structure-instance-slot-boundp - Macros for highly optimized slot access given type of instance - (analogous to standard-instance-access): - -with-optimized-slots - Optimized version of with-slots with a couple of useful additions - to with-slots' functionality. - -with-standard-instance-slots - Slightly faster version of with-optimized-slots for use when instance - is guaranteed to be a standard-instance. - -this-method - Function locally defined within the body of methods to return the method - currently being executed. - +generic-function-declarations + Not yet defined. -------------------------- -Useful low-level extensions to PCL: +reader-method-class + Not yet defined. Some bootstrapping considerations are involved, + but adding this will not be very hard. -Class wrappers now have one unreserved field available for programmer use - (accessed by wrapper-unreserved-field). +(setf class-name) + Currently just a writer method. Does not call reinitialize-instance or + (setf find-class). -Hooks built in to allow programmers to define their own USER-INSTANCE - low-level type of instances different from STD-INSTANCE, FSC-INSTANCE, - STRUCTURE-INSTANCE, or BUILT-IN-INSTANCE (see file user-instances.lisp - as an example of their use to save space over standard instances). +(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/pcl-env.lisp b/pcl/pcl-env.lisp index 2ee226b4c..7bf4b476e 100644 --- a/pcl/pcl-env.lisp +++ b/pcl/pcl-env.lisp @@ -328,9 +328,7 @@ arg-types." (defun pcl-object-p (x) "Is the datum a PCL object?" (or (std-instance-p x) - (fsc-instance-p x) - #+pcl-user-instances - (user-instance-p x))) + (fsc-instance-p x))) (defun \\internal-inspect-object (x type where) (inspect-object x type where)) @@ -1332,8 +1330,8 @@ window" (found-method nil) ((eq (il:stkname current-pos) 'apply) (dolist (method methods) - (when (memq (il:stkarg 1 current-pos) - (method-cached-functions method)) + (when (eq (method-function method) + (il:stkarg 1 current-pos)) (setq method-pos current-pos) (setq found-method method) (return)))))))) @@ -1361,10 +1359,10 @@ window" (setq gf (generic-function-from-frame current-pos)) (when gf (dolist (method (generic-function-methods gf)) - (dolist (function (method-cached-functions method)) - (when (function-matches-frame-p function stack-pos) - (return-from interesting-frame-p - (values t stack-pos stack-pos method))))) + (when (function-matches-frame-p (method-function method) + stack-pos) + (return-from interesting-frame-p + (values t stack-pos stack-pos method)))) (return)))) ;; If we haven't already returned, use the default method. (xcl::interesting-frame-p stack-pos interp-flag)))) diff --git a/pcl/pkg.lisp b/pcl/pkg.lisp index 9b5931e1c..b09f2f47a 100644 --- a/pcl/pkg.lisp +++ b/pcl/pkg.lisp @@ -36,6 +36,7 @@ variable-globally-special-p *variable-declarations* variable-declaration + macroexpand-all )) (in-package :iterate :use '(:lisp :walker)) @@ -73,12 +74,9 @@ #+Lucid (import '(#-LCL3.0 system:arglist #+LCL3.0 lcl:arglist - system:structurep system:structure-type system:structure-length - #-*lisp-hardware lucid::boolean - #+*lisp-hardware *lisp:boolean) + system:structurep system:structure-type system:structure-length) *the-pcl-package*) - - + #+lucid (#-LCL3.0 progn #+LCL3.0 lcl:handler-bind #+LCL3.0 ((lcl:warning #'(lambda (condition) @@ -139,7 +137,7 @@ #+kcl (progn -(import '(system:structurep)) +(import '(si:structurep si:structure-def si:structure-ref)) (shadow 'lisp:dotimes) ) #+kcl @@ -147,23 +145,17 @@ #+kcl (export '(%structure-name %compiled-function-name - %set-compiled-function-name)) + %set-compiled-function-name + %instance-ref + %set-instance-ref)) #+kcl (in-package 'pcl) #+cmu (shadow 'lisp:dotimes) #+cmu -(import '(kernel:funcallable-instance-p ext:structurep c::boolean) +(import '(kernel:funcallable-instance-p ext:structurep) *the-pcl-package*) - -#+CMU -(eval-when (compile) - (setq c:*suppress-values-declaration* T)) - -#-(or cmu lucid) -(deftype boolean () '(member t nil)) - (shadow 'documentation) @@ -187,7 +179,6 @@ defgeneric define-method-combination defmethod - describe-object ensure-generic-function find-class find-method @@ -332,7 +323,6 @@ slot-definition-readers slot-definition-writers slot-definition-type - slot-exists-p-using-class slot-makunbound-using-class slot-value-using-class specializer-direct-generic-function @@ -356,10 +346,21 @@ #+(or KCL IBCL) (mapc 'export (list *chapter-6-exports*) (list *the-pcl-package*)) - + (defvar *slot-accessor-name-package* (or (find-package :slot-accessor-name) (make-package :slot-accessor-name :use '() :nicknames '(:s-a-n)))) +#+kcl +(when (get 'si::basic-wrapper 'si::s-data) + (import (mapcar #'(lambda (s) (intern (symbol-name s) "SI")) + '(:copy-structure-header :swap-structure-contents :set-structure-def + :%instance-ref :%set-instance-ref + + :cache-number-vector :cache-number-vector-length + :wrapper-cache-number-adds-ok :wrapper-cache-number-length + :wrapper-cache-number-mask :wrapper-cache-number-vector-length + :wrapper-layout :wrapper-cache-number-vector + :wrapper-state :wrapper-class :wrapper-length)))) diff --git a/pcl/plap.lisp b/pcl/plap.lisp index e491a5d1f..622dd5c3c 100644 --- a/pcl/plap.lisp +++ b/pcl/plap.lisp @@ -117,7 +117,7 @@ `(,(lap-reg reg) ,(lap-reg-initial-value-form reg))) (append i-regs v-regs fv-regs t-regs)) - (declare (type index ,@(mapcar #'lap-reg *lap-i-regs*)) + (declare (type fixnum ,@(mapcar #'lap-reg *lap-i-regs*)) (type simple-vector ,@(mapcar #'lap-reg *lap-v-regs*)) (type #+structure-wrapper cache-number-vector #-structure-wrapper (simple-array fixnum) @@ -127,13 +127,15 @@ (defvar *empty-vector* '#()) (defvar *empty-fixnum-vector* - (make-array 8 :initial-element 0)) + (make-array 8 + :element-type 'fixnum + :initial-element 0)) (defun lap-reg-initial-value-form (reg) - (cond ((memq reg *lap-i-regs*) 0) - ((memq reg *lap-v-regs*) '*empty-vector*) - ((memq reg *lap-fv-regs*) '*empty-fixnum-vector*) - ((memq reg *lap-t-regs*) nil) + (cond ((member reg *lap-i-regs*) 0) + ((member reg *lap-v-regs*) '*empty-vector*) + ((member reg *lap-fv-regs*) '*empty-fixnum-vector*) + ((member reg *lap-t-regs*) nil) (t (error "What kind of register is ~S?" reg)))) @@ -155,9 +157,6 @@ (:std-instance-p (from label) `(when ,(lap-operands 'RUNTIME\ STD-INSTANCE-P from) (go ,label))) - #+pcl-user-instances - (:user-instance-p (from label) - `(when ,(lap-operands 'RUNTIME\ USER-INSTANCE-P from) (go ,label))) (:fsc-instance-p (from label) `(when ,(lap-operands 'RUNTIME\ FSC-INSTANCE-P from) (go ,label))) (:built-in-instance-p (from label) @@ -166,13 +165,16 @@ (:structure-instance-p (from label) `(when ,(lap-operands 'RUNTIME\ STRUCTURE-INSTANCE-P from) (go ,label))) ;*** - (:jmp (fn) + ((:jmp :emf-call) (fn) (if (eq *lap-args* 'lap-in-lisp) (error "Can't do a :JMP in LAP-IN-LISP.") `(return - ,(if *lap-rest-p* - `(RUNTIME\ APPLY ,(lap-operand fn) ,@*lap-args* .lap-rest-arg.) - `(RUNTIME\ FUNCALL ,(lap-operand fn) ,@*lap-args*))))) + ,(if (eq (car opcode) :jmp) + (if *lap-rest-p* + `(RUNTIME\ APPLY ,(lap-operand fn) ,@*lap-args* .lap-rest-arg.) + `(RUNTIME\ FUNCALL ,(lap-operand fn) ,@*lap-args*)) + `(RUNTIME\ EMF-CALL ,(lap-operand fn) ,*lap-rest-p* ,@*lap-args* + ,@(when *lap-rest-p* `(.lap-rest-arg.))))))) (:return (value) `(return ,(lap-operand value))) @@ -195,23 +197,17 @@ (:constant (c) `',c) ((:std-wrapper :fsc-wrapper :built-in-wrapper :structure-wrapper :built-in-or-structure-wrapper :std-slots :fsc-slots - :wrapper-cache-number-vector - #+pcl-user-instances :user-wrapper - #+pcl-user-instances :user-slots) + :wrapper-cache-number-vector) (x) (lap-operands (ecase (car operand) (:std-wrapper 'RUNTIME\ STD-WRAPPER) (:fsc-wrapper 'RUNTIME\ FSC-WRAPPER) - #+pcl-user-instances - (:user-wrapper 'RUNTIME\ USER-WRAPPER) (:built-in-wrapper 'RUNTIME\ BUILT-IN-WRAPPER) (:structure-wrapper 'RUNTIME\ STRUCTURE-WRAPPER) (:built-in-or-structure-wrapper 'RUNTIME\ BUILT-IN-OR-STRUCTURE-WRAPPER) (:std-slots 'RUNTIME\ STD-SLOTS) (:fsc-slots 'RUNTIME\ FSC-SLOTS) - #+pcl-user-instances - (:user-slots 'RUNTIME\ USER-SLOTS) (:wrapper-cache-number-vector 'RUNTIME\ WRAPPER-CACHE-NUMBER-VECTOR)) x)) @@ -226,6 +222,11 @@ (:iref (vector index) (lap-operands 'RUNTIME\ IREF vector index)) (:iset (vector index value) (lap-operands 'RUNTIME\ ISET vector index value)) + (:instance-ref (vector index) + (lap-operands 'RUNTIME\ INSTANCE-REF vector index)) + (:instance-set (vector index value) + (lap-operands 'RUNTIME\ INSTANCE-SET vector index value)) + (:cref (vector i) `(RUNTIME\ SVREF ,(lap-operand vector) ,i)) (:lisp-variable (symbol) symbol) (:lisp (form) form) @@ -248,10 +249,15 @@ (proclaim '(declaration pcl-fast-call)) (defmacro RUNTIME\ FUNCALL (fn &rest args) - `(method-function-funcall ,fn ,.args)) + #+CMU `(funcall (the function ,fn) ,.args) + #-CMU `(funcall ,fn ,.args)) (defmacro RUNTIME\ APPLY (fn &rest args) - `(method-function-apply ,fn ,.args)) + #+CMU `(apply (the function ,fn) ,.args) + #-CMU `(apply ,fn ,.args)) + +(defmacro RUNTIME\ EMF-CALL (emf restp &rest required-args+rest-arg) + `(invoke-effective-method-function ,emf ,restp ,@required-args+rest-arg)) (defmacro RUNTIME\ STD-WRAPPER (x) `(std-instance-wrapper ,x)) @@ -259,10 +265,6 @@ (defmacro RUNTIME\ FSC-WRAPPER (x) `(fsc-instance-wrapper ,x)) -#+pcl-user-instances -(defmacro RUNTIME\ USER-WRAPPER (x) - `(get-user-instance-wrapper ,x)) - (defmacro RUNTIME\ BUILT-IN-WRAPPER (x) `(built-in-wrapper-of ,x)) @@ -281,10 +283,6 @@ (defmacro RUNTIME\ FSC-SLOTS (x) `(fsc-instance-slots ,x)) -#+pcl-user-instances -(defmacro RUNTIME\ USER-SLOTS (x) - `(get-user-instance-slots ,x)) - (defmacro RUNTIME\ WRAPPER-CACHE-NUMBER-VECTOR (x) `(wrapper-cache-number-vector ,x)) @@ -294,15 +292,11 @@ (defmacro RUNTIME\ FSC-INSTANCE-P (x) `(fsc-instance-p ,x)) -#+pcl-user-instances -(defmacro RUNTIME\ USER-INSTANCE-P (x) - `(get-user-instance-p ,x)) - (defmacro RUNTIME\ IZEROP (x) - `(zerop (the index ,x))) + `(zerop (the fixnum ,x))) (defmacro RUNTIME\ FIX= (x y) - `(= (the index ,x) (the index ,y))) + `(= (the fixnum ,x) (the fixnum ,y))) ;;; ;;; These are the implementations of the index operands. The portable @@ -313,29 +307,47 @@ ;;; Some compilers are so stupid... ;;; (defmacro RUNTIME\ IREF (vector index) - `(svref (the simple-vector ,vector) (the index ,index))) + #-structure-wrapper + `(svref (the simple-vector ,vector) (the fixnum ,index)) + #+structure-wrapper + `(aref ,vector (the fixnum ,index))) (defmacro RUNTIME\ ISET (vector index value) - `(setf (svref (the simple-vector ,vector) (the index ,index)) ,value)) - -(defmacro RUNTIME\ SVREF (vector index) - `(svref (the simple-vector ,vector) (the index ,index))) + `(setf (svref (the simple-vector ,vector) (the fixnum ,index)) ,value)) + +(defmacro RUNTIME\ INSTANCE-REF (vector index) + #-new-kcl-wrapper + `(svref (the simple-vector ,vector) (the fixnum ,index)) + #+new-kcl-wrapper + `(%instance-ref ,vector (the fixnum ,index))) + +(defmacro RUNTIME\ INSTANCE-SET (vector index value) + #-new-kcl-wrapper + `(setf (svref (the simple-vector ,vector) (the fixnum ,index)) ,value) + #+new-kcl-wrapper + `(setf (%instance-ref ,vector (the fixnum ,index)) ,value)) + +(defmacro RUNTIME\ SVREF (vector fixnum) + #-structure-wrapper + `(svref (the simple-vector ,vector) (the fixnum ,fixnum)) + #+structure-wrapper + `(aref ,vector (the fixnum ,fixnum))) (defmacro RUNTIME\ I+ (index1 index2) - `(the index (+ (the index ,index1) (the index ,index2)))) + `(the fixnum (+ (the fixnum ,index1) (the fixnum ,index2)))) (defmacro RUNTIME\ I- (index1 index2) - `(the index (- (the index ,index1) (the index ,index2)))) + `(the fixnum (- (the fixnum ,index1) (the fixnum ,index2)))) (defmacro RUNTIME\ I1+ (index) - `(the index (1+ (the index ,index)))) + `(the fixnum (1+ (the fixnum ,index)))) (defmacro RUNTIME\ ILOGAND (index1 index2) - #-Lucid `(the index (logand (the index ,index1) (the index ,index2))) + #-Lucid `(the fixnum (logand (the fixnum ,index1) (the fixnum ,index2))) #+Lucid `(%logand ,index1 ,index2)) (defmacro RUNTIME\ ILOGXOR (index1 index2) - `(the index (logxor (the index ,index1) (the index ,index2)))) + `(the fixnum (logxor (the fixnum ,index1) (the fixnum ,index2)))) ;;; ;;; In the portable implementation, indexes are just fixnums. @@ -347,15 +359,11 @@ (defun index->index-value (index) index) (defun make-index-mask (cache-size line-size) - (declare (type index 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)) - (declare (type index cache-size-in-bits line-size-in-bits mask)) - (dotimes (i cache-size-in-bits) - (setq mask (the index (dpb 1 (byte 1 i) mask)))) - (dotimes (i line-size-in-bits) - (setq mask (the index (dpb 0 (byte 1 i) mask)))) + (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)) diff --git a/pcl/quadlap.lisp b/pcl/quadlap.lisp index 8c7f43153..695222bd3 100644 --- a/pcl/quadlap.lisp +++ b/pcl/quadlap.lisp @@ -1,6 +1,6 @@ ;; -[Thu Mar 1 10:54:27 1990 by jkf]- ;; pcl to quad translation -;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/Attic/quadlap.lisp,v 1.4 1992/08/01 15:29:51 ram Exp $ +;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/Attic/quadlap.lisp,v 1.5 1992/11/09 15:21:37 ram Exp $ ;; ;; copyright (c) 1990 Franz Inc. ;; @@ -30,7 +30,7 @@ `(list nil ,constants ,lap nil nil ,cframe-size ,locals nil nil nil)) -(defstruct (preg) +(defstruct preg ;; pseudo reg descritpor treg ; associated treg index ; :index if this is an index type reg @@ -360,7 +360,7 @@ ; can be either simple (both args registers) ; or one arg can be complex and the other simple (case (car op2) - (:iref + ((:iref :instance-ref) ;; assume that this is a lisp store ;;(warn "assuming lisp store in ~s" lap) (let (op1-treg) @@ -424,12 +424,9 @@ (comp::mdparam 'md-function-const0-adj)) op2)) ((:built-in-wrapper :structure-wrapper :built-in-or-structure-wrapper) - (qe call :arg 'pcl::built-in-or-structure-wrapper-fun + (qe call :arg 'pcl::built-in-or-structure-wrapper :u (list (get-treg-of (cadr op1))) :d (list (get-treg-of op2)))) - #+pcl-user-instances - ((:user-wrapper :user-slots) - (warn "Trying to use pcl-user-instances in Sun4 Allegro.")) (:other-wrapper (warn "do other-wrapper")) ((:i+ :i- :ilogand :ilogxor) @@ -451,7 +448,7 @@ (get-treg-of (cadr op1))) :d (list (get-treg-of op2))))) - ((:iref :cref) + ((:iref :cref :instance-ref) (let (op1-treg) (if* (not (vector-preg-p (cadr op1))) then ; must offset before store diff --git a/pcl/slots.lisp b/pcl/slots.lisp index 159da0af6..2bbcab0b6 100644 --- a/pcl/slots.lisp +++ b/pcl/slots.lisp @@ -27,6 +27,15 @@ (in-package 'pcl) +(defmethod wrapper-fetcher ((class standard-class)) + 'std-instance-wrapper) + +(defmethod slots-fetcher ((class standard-class)) + 'std-instance-slots) + +(defmethod raw-instance-allocator ((class standard-class)) + 'allocate-standard-instance) + ;;; ;;; These four functions work on std-instances and fsc-instances. These are ;;; instances for which it is possible to change the wrapper and the slots. @@ -36,832 +45,138 @@ ;;; std-class. Many of these methods call these four functions. ;;; -(defun wrapper-error (&optional (object () object-p)) - (if object-p - (error "What kind of instance is this: ~S" object) - (error "What kind of instance is this?"))) - - -(defmacro get-slots (inst &optional (else-clause '(wrapper-error))) - (once-only (inst) - `(cond ((std-instance-p ,inst) (std-instance-slots ,inst)) - ((fsc-instance-p ,inst) (fsc-instance-slots ,inst)) - #+pcl-user-instances - ((get-user-instance-p ,inst) (get-user-instance-slots ,inst)) - (T ,else-clause)))) - -(defmacro get-slots-or-nil (inst) - `(get-slots ,inst nil)) - (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)) - #+pcl-user-instances - ((user-instance-p inst) - (setf (user-instance-wrapper inst) new)) - (t - (wrapper-error inst)))) - + #+new-kcl-wrapper + (set-structure-def inst new) + #-new-kcl-wrapper + (setf (std-instance-wrapper inst) new)) + ((fsc-instance-p inst) + (setf (fsc-instance-wrapper inst) new)) + (t + (error "What kind of instance is this?")))) + +#+ignore ; can't do this when using #+new-kcl-wrapper (defun set-slots (inst new) (cond ((std-instance-p inst) - (setf (std-instance-slots inst) new)) - ((fsc-instance-p inst) - (setf (fsc-instance-slots inst) new)) - #+pcl-user-instances - ((user-instance-p inst) - (setf (user-instance-slots inst) new)) - (t - (wrapper-error inst)))) - - - -(defmacro get-class-slot-value-1 (object wrapper slot-name - &optional - (ignore-unbound-p NIL) - (ignore-missing-p NIL) - (return-cons-p NIL) - (operation ''slot-value)) - ;; Search for slot-name in the class-slots of the object, returning - ;; its value if found and the slot is bound, calling slot-unbound if - ;; it was unbound (unless ignore-unbound is T), and calling slot-missing - ;; if it wasn't found in the class slots at all. - (once-only (object slot-name) - `(block nil - (locally (declare #.*optimize-speed*) - (let ((slots-left (wrapper-class-slots ,wrapper))) - (tagbody - (if (null slots-left) - (go loop-slot-missing)) - begin-class-loop - (if (eq (caar slots-left) ,slot-name) - ,(cond - (return-cons-p - `(progn - (setf slots-left (car slots-left)) - (go return-slot-value))) - (ignore-unbound-p - `(progn - (setf slots-left (cdar slots-left)) - (go return-slot-value))) - (T - `(if (eq (setf slots-left (cdar slots-left)) - ',*slot-unbound*) - (return - (slot-unbound (wrapper-class ,wrapper) - ,object ,slot-name)) - (go return-slot-value))))) - (if (null (setf slots-left (cdr slots-left))) - (go loop-slot-missing)) - (go begin-class-loop) - loop-slot-missing - ,@(unless ignore-missing-p - `((return (slot-missing (wrapper-class ,wrapper) - ,object - ,slot-name - ,operation)))) - return-slot-value) - slots-left))))) - -(defmacro set-class-slot-value-1 (object wrapper slot-name new-value) - ;; Search for slot-name in the class-slots of the object, setting it - ;; to new-value if found, calling slot-missing otherwise. - (once-only (object slot-name new-value) - `(block nil - (locally (declare #.*optimize-speed*) - (let ((slots-left (wrapper-class-slots ,wrapper))) - (tagbody - (if (null slots-left) - (go loop-slot-missing)) - begin-class-loop - (if (eq (caar slots-left) ,slot-name) - (return (setf (cdar slots-left) ,new-value))) - (if (null (setf slots-left (cdr slots-left))) - (go loop-slot-missing)) - (go begin-class-loop) - loop-slot-missing - (return (slot-missing (wrapper-class ,wrapper) - ,object - ,slot-name - 'setf - ,new-value)))))))) - -(defmacro slot-value-from-wrapper-and-slots - (object slot-name wrapper slots-layout slots get-slots-fn) - "Extra fast and ugly way to return the value of object's slot when given - its wrapper and possibly slots-layout and slots vector." - (once-only (wrapper) - `(block nil - (locally (declare #.*optimize-speed*) - (let ((slots-left ,(if slots-layout - slots-layout - `(wrapper-instance-slots-layout ,wrapper)))) - (tagbody - (if slots-left - (let ((index 0)) - (declare (type index index)) - (tagbody - begin-local-loop - (if (eq (car slots-left) ,slot-name) - (if (eq (setf slots-left - (%svref - ,(if slots - slots - `(,(or get-slots-fn 'get-slots) - ,object)) - index)) - ',*slot-unbound*) - (go loop-slot-unbound) - (go return-slot-value))) - (setf index (the index (1+ index))) - (if (null (setf slots-left (cdr slots-left))) - (go check-class-loop)) - (go begin-local-loop)))) - check-class-loop - (if (null (setf slots-left (wrapper-class-slots ,wrapper))) - (go loop-slot-missing)) - begin-class-loop - (if (eq (caar slots-left) ,slot-name) - (if (eq (setf slots-left (cdar slots-left)) - ',*slot-unbound*) - (go loop-slot-unbound) - (go return-slot-value))) - (if (null (setf slots-left (cdr slots-left))) - (go loop-slot-missing)) - (go begin-class-loop) - loop-slot-missing - (return (slot-missing (wrapper-class ,wrapper) - ,object - ,slot-name - 'slot-value)) - loop-slot-unbound - (return (slot-unbound (wrapper-class ,wrapper) ,object ,slot-name)) - return-slot-value) - slots-left))))) - -(defmacro set-slot-value-from-wrapper-and-slots - (object slot-name wrapper slots-layout slots get-slots-fn new-value) - "Extra fast and ugly way to set the value of object's slot when given its - wrapper and possibly slots-layout and slots vector." - (once-only (wrapper new-value) - `(block nil - (locally (declare #.*optimize-speed*) - (let ((slots-left ,(if slots-layout - slots-layout - `(wrapper-instance-slots-layout ,wrapper)))) - (tagbody - (if slots-left - (let ((index 0)) - (declare (type index index)) - (tagbody - begin-local-loop - (if (eq (car slots-left) ,slot-name) - (progn - (setf (%svref ,(if slots - slots - `(,(or get-slots-fn 'get-slots) - ,object)) - index) - ,new-value) - (go return-slot-value))) - (setf index (the index (1+ index))) - (if (null (setf slots-left (cdr slots-left))) - (go check-class-loop)) - (go begin-local-loop)))) - check-class-loop - (if (null (setf slots-left (wrapper-class-slots ,wrapper))) - (go loop-slot-missing)) - begin-class-loop - (if (eq (caar slots-left) ,slot-name) - (progn - (setf (cdar slots-left) ,new-value) - (go return-slot-value))) - (if (null (setf slots-left (cdr slots-left))) - (go loop-slot-missing)) - (go begin-class-loop) - loop-slot-missing - (return (slot-missing (wrapper-class ,wrapper) - ,object - ,slot-name - 'setf - ,new-value)) - return-slot-value) - ,new-value))))) - -(defmacro slot-boundp-from-wrapper-and-slots - (object slot-name wrapper slots-layout slots get-slots-fn) - "Extra fast and ugly way to return whether object's slot is boundp when - given its wrapper and possibly slots-layout and slots vector." - (once-only (wrapper) - `(block nil - (locally (declare #.*optimize-speed*) - (let ((slots-left ,(if slots-layout - slots-layout - `(wrapper-instance-slots-layout ,wrapper)))) - (tagbody - (if slots-left - (let ((index 0)) - (declare (type index index)) - (tagbody - begin-local-loop - (when (eq (car slots-left) ,slot-name) - (return - (neq (%svref ,(if slots - slots - `(,(or get-slots-fn 'get-slots) - ,object)) - index) - ',*slot-unbound*))) - (setf index (the index (1+ index))) - (if (null (setf slots-left (cdr slots-left))) - (go check-class-loop)) - (go begin-local-loop)))) - check-class-loop - (if (null (setf slots-left (wrapper-class-slots ,wrapper))) - (go loop-slot-missing)) - begin-class-loop - (when (eq (caar slots-left) ,slot-name) - (return (neq (cdar slots-left) ',*slot-unbound*))) - (if (null (setf slots-left (cdr slots-left))) - (go loop-slot-missing)) - (go begin-class-loop) - loop-slot-missing - (return (slot-missing (wrapper-class ,wrapper) - ,object - ,slot-name - 'slot-value)))))))) - - -(defsetf slot-value-from-wrapper-and-slots - set-slot-value-from-wrapper-and-slots) + (setf (std-instance-slots inst) new)) + ((fsc-instance-p inst) + (setf (fsc-instance-slots inst) new)) + (t + (error "What kind of instance is this?")))) + +(defun swap-wrappers-and-slots (i1 i2) + (without-interrupts + (cond ((std-instance-p i1) + #+new-kcl-wrapper + (swap-structure-contents i1 i2) + #-new-kcl-wrapper + (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))) + (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))) + (prototype (class-prototype class))) (set-class-slot-value-1 nv prototype wrapper slot-name))) - -;;; -;;; The following highly optimized methods for accessing the slots -;;; of standard instances and funcallable standard instances aren't -;;; in the MOP, but it would be nice if they were... - TL -;;; - -(defmacro safe-funcallable-standard-instance-slot-value (instance slot-name) - "Highly-optimized macro for returning the slot-value of instances that - are guaranteed to be funcallable-standard-instances with normal slots." - (once-only (instance) - `(locally (declare #.*optimize-speed*) - (slot-value-from-wrapper-and-slots - ,instance ,slot-name - (fast-check-wrapper-validity ,instance fsc-instance-wrapper) - NIL NIL fsc-instance-slots)))) - -(defmacro set-safe-funcallable-standard-instance-slot-value - (instance slot-name new-value) - "Highly-optimized macro for setting the slot-value of instances that - are guaranteed to be funcallable-standard-instances with normal slots." - (once-only (instance) - `(locally (declare #.*optimize-speed*) - (setf (slot-value-from-wrapper-and-slots - ,instance ,slot-name - (fast-check-wrapper-validity ,instance fsc-instance-wrapper) - NIL NIL fsc-instance-slots) - ,new-value)))) - -(defmacro safe-funcallable-standard-instance-slot-boundp (instance slot-name) - "Highly-optimized macro for checking whether a slot is bound for instances - that are guaranteed to be funcallable-standard-instances with normal slots." - (once-only (instance slot-name) - `(locally (declare #.*optimize-speed*) - (slot-boundp-from-wrapper-and-slots - ,instance ,slot-name - (fast-check-wrapper-validity ,instance fsc-instance-wrapper) - NIL NIL fsc-instance-slots)))) - -(defsetf safe-funcallable-standard-instance-slot-value - set-safe-funcallable-standard-instance-slot-value) - - -(defmacro funcallable-standard-instance-slot-value (instance slot-name) - "Highly-optimized macro for returning the slot-value of instances that - are guaranteed to be funcallable-standard-instances." - (cond (*always-safe-to-use-slot-wrapper-optimizations-p* - `(safe-funcallable-standard-instance-slot-value ,instance ,slot-name)) - (*safe-to-use-slot-value-wrapper-optimizations-p* - (once-only (instance slot-name) - `(locally (declare #.*optimize-speed*) - (if *safe-to-use-slot-value-wrapper-optimizations-p* - (safe-funcallable-standard-instance-slot-value ,instance ,slot-name) - (accessor-slot-value ,instance ,slot-name))))) - (T `(accessor-slot-value ,instance ,slot-name)))) - -(defmacro set-funcallable-standard-instance-slot-value - (instance slot-name new-value) - "Highly-optimized macro for setting the slot-value of instances that - are guaranteed to be funcallable-standard-instances." - (cond (*always-safe-to-use-slot-wrapper-optimizations-p* - `(setf (safe-funcallable-standard-instance-slot-value ,instance ,slot-name) - ,new-value)) - (*safe-to-use-set-slot-value-wrapper-optimizations-p* - (once-only (instance slot-name new-value) - `(locally (declare #.*optimize-speed*) - (if *safe-to-use-set-slot-value-wrapper-optimizations-p* - (setf (safe-funcallable-standard-instance-slot-value - ,instance ,slot-name) - ,new-value) - (setf (accessor-slot-value ,instance ,slot-name) ,new-value))))) - (T `(setf (accessor-slot-value ,instance ,slot-name) ,new-value)))) - -(defmacro funcallable-standard-instance-slot-boundp (instance slot-name) - "Highly-optimized macro for checking whether a slot is bound for instances - that are guaranteed to be funcallable-standard-instances." - (cond (*always-safe-to-use-slot-wrapper-optimizations-p* - `(safe-funcallable-standard-instance-slot-boundp ,instance ,slot-name)) - (*safe-to-use-slot-boundp-wrapper-optimizations-p* - (once-only (instance slot-name) - `(locally (declare #.*optimize-speed*) - (if *safe-to-use-slot-boundp-wrapper-optimizations-p* - (safe-funcallable-standard-instance-slot-boundp ,instance ,slot-name) - (accessor-slot-boundp ,instance ,slot-name))))) - (T `(accessor-slot-boundp ,instance ,slot-name)))) - -(defsetf funcallable-standard-instance-slot-value - set-funcallable-standard-instance-slot-value) - - -(defmacro safe-standard-instance-slot-value (instance slot-name) - "Highly-optimized macro for returning the slot-value of instances that - are guaranteed to be standard instances with normal slots." - (once-only (instance) - `(locally (declare #.*optimize-speed*) - (slot-value-from-wrapper-and-slots - ,instance ,slot-name - (fast-check-wrapper-validity ,instance std-instance-wrapper) - NIL NIL std-instance-slots)))) - -(defmacro set-safe-standard-instance-slot-value (instance slot-name new-value) - "Highly-optimized macro for setting the slot-value of instances that - are guaranteed to be standard instances with normal slots." - (once-only (instance) - `(locally (declare #.*optimize-speed*) - (setf (slot-value-from-wrapper-and-slots - ,instance ,slot-name - (fast-check-wrapper-validity ,instance std-instance-wrapper) - NIL NIL std-instance-slots) - ,new-value)))) - -(defmacro safe-standard-instance-slot-boundp (instance slot-name) - "Highly-optimized macro for checking whether a slot is bound for instances - that are guaranteed to be standard-instances with normal slots." - (once-only (instance slot-name) - `(locally (declare #.*optimize-speed*) - (slot-boundp-from-wrapper-and-slots - ,instance ,slot-name - (fast-check-wrapper-validity ,instance std-instance-wrapper) - NIL NIL std-instance-slots)))) - -(defsetf safe-standard-instance-slot-value set-safe-standard-instance-slot-value) - -(defmacro standard-instance-slot-value (instance slot-name) - "Highly-optimized macro for returning the slot-value of instances that - are guaranteed to be standard-instances." - (cond (*always-safe-to-use-slot-wrapper-optimizations-p* - `(safe-standard-instance-slot-value ,instance ,slot-name)) - (*safe-to-use-slot-value-wrapper-optimizations-p* - (once-only (instance slot-name) - `(locally (declare #.*optimize-speed*) - (if *safe-to-use-slot-value-wrapper-optimizations-p* - (safe-standard-instance-slot-value ,instance ,slot-name) - (accessor-slot-value ,instance ,slot-name))))) - (T `(accessor-slot-value ,instance ,slot-name)))) - -(defmacro set-standard-instance-slot-value - (instance slot-name new-value) - "Highly-optimized macro for setting the slot-value of instances that - are guaranteed to be standard-instances." - (cond (*always-safe-to-use-slot-wrapper-optimizations-p* - `(setf (safe-standard-instance-slot-value ,instance ,slot-name) - ,new-value)) - (*safe-to-use-set-slot-value-wrapper-optimizations-p* - (once-only (instance slot-name new-value) - `(locally (declare #.*optimize-speed*) - (if *safe-to-use-set-slot-value-wrapper-optimizations-p* - (setf (safe-standard-instance-slot-value - ,instance ,slot-name) - ,new-value) - (setf (accessor-slot-value ,instance ,slot-name) ,new-value))))) - (T `(setf (accessor-slot-value ,instance ,slot-name) ,new-value)))) - -(defmacro standard-instance-slot-boundp (instance slot-name) - "Highly-optimized macro for checking whether a slot is bound for instances - that are guaranteed to be standard-instances." - (cond (*always-safe-to-use-slot-wrapper-optimizations-p* - `(safe-standard-instance-slot-boundp ,instance ,slot-name)) - (*safe-to-use-slot-boundp-wrapper-optimizations-p* - (once-only (instance slot-name) - `(locally (declare #.*optimize-speed*) - (if *safe-to-use-slot-boundp-wrapper-optimizations-p* - (safe-standard-instance-slot-boundp ,instance ,slot-name) - (accessor-slot-boundp ,instance ,slot-name))))) - (T `(accessor-slot-boundp ,instance ,slot-name)))) - -(defsetf standard-instance-slot-value set-standard-instance-slot-value) - - -#+pcl-user-instances -(progn -(defmacro safe-user-instance-slot-value (instance slot-name) - "Highly-optimized macro for returning the slot-value of instances that - are guaranteed to be user instances with normal slots." - (once-only (instance) - `(locally (declare #.*optimize-speed*) - (slot-value-from-wrapper-and-slots - ,instance ,slot-name - (fast-check-wrapper-validity ,instance get-user-instance-wrapper) - NIL NIL get-user-instance-slots)))) - -(defmacro set-safe-user-instance-slot-value (instance slot-name new-value) - "Highly-optimized macro for setting the slot-value of instances that - are guaranteed to be user instances with normal slots." - (once-only (instance) - `(locally (declare #.*optimize-speed*) - (setf (slot-value-from-wrapper-and-slots - ,instance ,slot-name - (fast-check-wrapper-validity ,instance get-user-instance-wrapper) - NIL NIL get-user-instance-slots) - ,new-value)))) - -(defmacro safe-user-instance-slot-boundp (instance slot-name) - "Highly-optimized macro for checking whether a slot is bound for instances - that are guaranteed to be user-instances with normal slots." - (once-only (instance slot-name) - `(locally (declare #.*optimize-speed*) - (slot-boundp-from-wrapper-and-slots - ,instance ,slot-name - (fast-check-wrapper-validity ,instance get-user-instance-wrapper) - NIL NIL get-user-instance-slots)))) - -(defsetf safe-user-instance-slot-value set-safe-user-instance-slot-value) - - -(defmacro user-instance-slot-value (instance slot-name) - "Highly-optimized macro for returning the slot-value of instances that - are guaranteed to be user-instances." - (cond (*always-safe-to-use-slot-wrapper-optimizations-p* - `(safe-user-instance-slot-value ,instance ,slot-name)) - (*safe-to-use-slot-value-wrapper-optimizations-p* - (once-only (instance slot-name) - `(locally (declare #.*optimize-speed*) - (if *safe-to-use-slot-value-wrapper-optimizations-p* - (safe-user-instance-slot-value ,instance ,slot-name) - (accessor-slot-value ,instance ,slot-name))))) - (T `(accessor-slot-value ,instance ,slot-name)))) - -(defmacro set-user-instance-slot-value - (instance slot-name new-value) - "Highly-optimized macro for setting the slot-value of instances that - are guaranteed to be user-instances." - (cond (*always-safe-to-use-slot-wrapper-optimizations-p* - `(setf (safe-user-instance-slot-value ,instance ,slot-name) ,new-value)) - (*safe-to-use-set-slot-value-wrapper-optimizations-p* - (once-only (instance slot-name new-value) - `(locally (declare #.*optimize-speed*) - (if *safe-to-use-set-slot-value-wrapper-optimizations-p* - (setf (safe-user-instance-slot-value ,instance ,slot-name) - ,new-value) - (setf (accessor-slot-value ,instance ,slot-name) ,new-value))))) - (T `(setf (accessor-slot-value ,instance ,slot-name) ,new-value)))) - -(defmacro user-instance-slot-boundp (instance slot-name) - "Highly-optimized macro for checking whether a slot is bound for instances - that are guaranteed to be user-instances." - (cond (*always-safe-to-use-slot-wrapper-optimizations-p* - `(safe-user-instance-slot-boundp ,instance ,slot-name)) - (*safe-to-use-slot-boundp-wrapper-optimizations-p* - (once-only (instance slot-name) - `(locally (declare #.*optimize-speed*) - (if *safe-to-use-slot-boundp-wrapper-optimizations-p* - (safe-user-instance-slot-boundp ,instance ,slot-name) - (accessor-slot-boundp ,instance ,slot-name))))) - (T `(accessor-slot-boundp ,instance ,slot-name)))) - -(defsetf user-instance-slot-value set-user-instance-slot-value) -) #+pcl-user-instances - -#+(and excl sun4) (values) ;; Weird bug in Allegro CL 3.1.13.1 [Sun4] requires this. - -(defun make-slot-symbol (slot-name type pname) - (unless (symbol-package slot-name) - (slot-symbol-error slot-name)) - (setf (get slot-name pname) - (intern (format nil "~A::~A slot ~a" - (package-name (symbol-package slot-name)) - (symbol-name slot-name) - type) - *slot-accessor-name-package*))) - -(defmacro slot-symbol (slot-name type pname) - (once-only (slot-name) - `(if (symbolp ,slot-name) - (or (get ,slot-name ,pname) - (make-slot-symbol ,slot-name ,type ,pname)) - (slot-symbol-error ,slot-name)))) - -(defun slot-symbol-error (slot-name) - (error "non-symbol slot-names (~S) are not yet implemented" slot-name)) - -(defmacro slot-reader-symbol (slot-name) - `(slot-symbol ,slot-name 'reader 'reader-slot-symbol)) - -(defmacro slot-writer-symbol (slot-name) - `(slot-symbol ,slot-name 'writer 'writer-slot-symbol)) - -(defmacro slot-boundp-symbol (slot-name) - `(slot-symbol ,slot-name 'boundp 'boundp-slot-symbol)) + (defun find-slot-definition (class slot-name) - (declare #.*optimize-speed*) - (macrolet ((find-def (class-internal-slotds slot-name) - `(let ((ptr ,class-internal-slotds)) - (loop (when (null ptr) - (return NIL)) - (when (eq (internal-slotd-name (car ptr)) ,slot-name) - (return (internal-slotd-slot-definition (car ptr)))) - (setf ptr (cdr ptr)))))) - (if (or (eq class *the-class-standard-class*) - (eq class *the-class-funcallable-standard-class*) - (eq class *the-class-standard-effective-slot-definition*)) - (find-def (safe-standard-instance-slot-value class 'internal-slotds) - slot-name) - (find-def (class-internal-slotds class) slot-name)))) - -(defun no-slot-accessor (object slot-name sym operation &optional new-value) - (if (and (not (or (std-instance-p object) - (fsc-instance-p object) - #+pcl-user-instances - (user-instance-p object))) - (typep object 'structure)) - (let ((structure-class (find-class (type-of object) nil))) - (if structure-class - (ecase operation - (slot-value (slot-value object slot-name)) - (setf (setf (slot-value object slot-name) new-value)) - (slot-boundp (slot-boundp object slot-name))) - (error - "Trying to do ~S for slot ~S on ~S, an instance of structure ~S - that was defined before PCL was loaded and that PCL can't make - a class for in this lisp." - (if (eq operation 'setf) '(setf slot-value) operation) - slot-name object (type-of object)))) - (error "Trying to do ~S on ~S, but no class has a slot named ~S - (~s has no function binding) (or maybe your files were - compiled with an old version of PCL: try recompiling.)" - (if (eq operation 'setf) '(setf slot-value) operation) - object slot-name sym))) - -(defun no-slot-value-accessor (object slot-name sym) - (no-slot-accessor object slot-name sym 'slot-value)) - -(defun no-set-slot-value-accessor (object slot-name sym new-value) - (no-slot-accessor object slot-name sym 'setf new-value)) - -(defun no-slot-boundp-accessor (object slot-name sym) - (no-slot-accessor object slot-name sym 'slot-boundp)) - - -(defun slow-slot-value (object slot-name) - (let ((class (class-of object))) - (if (eq class *the-class-standard-effective-slot-definition*) - (safe-standard-instance-slot-value object slot-name) - (let ((slot-definition (find-slot-definition class slot-name))) - (if (null slot-definition) - (slot-missing class object slot-name 'slot-value) - (slot-value-using-class class object slot-definition)))))) - -(defmacro accessor-slot-value (object slot-name-form) - (if (and (constantp slot-name-form) - (let ((slot-name (eval slot-name-form))) - (and (symbolp slot-name) (symbol-package slot-name)))) - (let* ((slot-name (eval slot-name-form)) - (sym (slot-reader-symbol slot-name))) - (once-only (object) - `(if (fboundp ',sym) - (funcall-compiled (symbol-function ',sym) ,object) - (no-slot-value-accessor ,object ',slot-name ',sym)))) - (let ((sym (gensym "READER-SYMBOL"))) - (once-only (object slot-name-form) - `(let ((,sym (slot-reader-symbol ,slot-name-form))) - (declare (type symbol ,sym)) - (if (fboundp ,sym) - (funcall-compiled (symbol-function ,sym) ,object) - (no-slot-value-accessor ,object ,slot-name-form ',sym))))))) - -(defmacro wrapper-optimized-slot-value (object slot-name - &optional - (alternate-sv 'accessor-slot-value)) - (once-only (object slot-name) - `(locally (declare #.*optimize-speed*) - (let ((wrapper NIL) - (slots NIL)) - (if (or (and (std-instance-p ,object) - (setf wrapper (fast-check-wrapper-validity - ,object std-instance-wrapper)) - (setf slots (std-instance-slots ,object))) - (and (fsc-instance-p ,object) - (setf wrapper (fast-check-wrapper-validity - ,object fsc-instance-wrapper)) - (setf slots (fsc-instance-slots ,object))) - #+pcl-user-instances - (and (get-user-instance-p ,object) - (setf wrapper (fast-check-user-wrapper-validity ,object)) - (setf slots (get-user-instance-slots ,object)))) - (slot-value-from-wrapper-and-slots - ,object ,slot-name wrapper NIL slots NIL) - (,alternate-sv ,object ,slot-name)))))) - -(defmacro fast-slot-value (object slot-name - &optional (alternate-sv 'accessor-slot-value)) - "Optimized macro version of slot-value." - (cond (*always-safe-to-use-slot-wrapper-optimizations-p* - `(wrapper-optimized-slot-value ,object ,slot-name ,alternate-sv)) - (*safe-to-use-slot-value-wrapper-optimizations-p* - (once-only (object slot-name) - `(locally (declare #.*optimize-speed*) - (if *safe-to-use-slot-value-wrapper-optimizations-p* - (wrapper-optimized-slot-value ,object ,slot-name ,alternate-sv) - (,alternate-sv ,object ,slot-name))))) - (T `(,alternate-sv ,object ,slot-name)))) + (dolist (slot (class-slots class) nil) + (when (eql slot-name (slot-definition-name slot)) + (return slot)))) (defun slot-value (object slot-name) - (fast-slot-value object slot-name)) - -(define-compiler-macro slot-value (object-form slot-name-form) - `(fast-slot-value ,object-form ,slot-name-form)) - - -(defun slow-set-slot-value (object slot-name new-value) (let* ((class (class-of object)) - (slot-definition (find-slot-definition class slot-name))) + (slot-definition (find-slot-definition class slot-name))) (if (null slot-definition) - (slot-missing class object slot-name 'setf) - (setf (slot-value-using-class class object slot-definition) new-value)))) + (slot-missing class object slot-name 'slot-value) + (slot-value-using-class class object slot-definition)))) -(defsetf slow-slot-value slow-set-slot-value) +(setf (symbol-function 'slot-value-normal) #'slot-value) -(defmacro accessor-set-slot-value (object slot-name-form new-value) +(define-compiler-macro slot-value (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)))) - (let* ((slot-name (eval slot-name-form)) - (sym (slot-writer-symbol slot-name))) - (once-only (object new-value) - `(if (fboundp ',sym) - (funcall-compiled (symbol-function ',sym) ,new-value ,object) - (no-set-slot-value-accessor ,object ',slot-name ',sym ,new-value)))) - (let ((sym (gensym "WRITER-SYM"))) - (once-only (object new-value slot-name-form) - `(let ((,sym (slot-writer-symbol ,slot-name-form))) - (declare (type symbol ,sym)) - (if (fboundp ,sym) - (funcall-compiled (symbol-function ,sym) ,new-value ,object) - (no-set-slot-value-accessor ,object ,slot-name-form ',sym - ,new-value))))))) - -(defmacro wrapper-optimized-set-slot-value (object slot-name new-value - &optional - (alternate-sv - 'accessor-slot-value)) - (once-only (object slot-name) - `(locally (declare #.*optimize-speed*) - (let ((wrapper NIL) - (slots NIL)) - (if (or (and (std-instance-p ,object) - (setf wrapper (fast-check-wrapper-validity - ,object std-instance-wrapper)) - (setf slots (std-instance-slots ,object))) - (and (fsc-instance-p ,object) - (setf wrapper (fast-check-wrapper-validity - ,object fsc-instance-wrapper)) - (setf slots (fsc-instance-slots ,object))) - #+pcl-user-instances - (and (get-user-instance-p ,object) - (setf wrapper (fast-check-user-wrapper-validity ,object)) - (setf slots (get-user-instance-slots ,object)))) - (setf (slot-value-from-wrapper-and-slots - ,object ,slot-name wrapper NIL slots NIL) - ,new-value) - (setf (,alternate-sv ,object ,slot-name) ,new-value)))))) - -(defmacro fast-set-slot-value (object slot-name new-value - &optional - (alternate-sv 'accessor-slot-value)) - "Optimized macro version of set-slot-value." - (cond (*always-safe-to-use-slot-wrapper-optimizations-p* - `(wrapper-optimized-set-slot-value ,object ,slot-name - ,new-value ,alternate-sv)) - (*safe-to-use-slot-value-wrapper-optimizations-p* - (once-only (object slot-name new-value) - `(locally (declare #.*optimize-speed*) - (if *safe-to-use-slot-value-wrapper-optimizations-p* - (wrapper-optimized-set-slot-value ,object ,slot-name - ,new-value ,alternate-sv) - (setf (,alternate-sv ,object ,slot-name) ,new-value))))) - (T `(setf (,alternate-sv ,object ,slot-name) ,new-value)))) - -(defmacro do-fast-set-slot-value (object slot-name new-value) - `(fast-set-slot-value ,object ,slot-name ,new-value)) - -(defsetf accessor-slot-value accessor-set-slot-value) -(defsetf fast-slot-value do-fast-set-slot-value) - - + (let ((slot-name (eval slot-name-form))) + (and (symbolp slot-name) (symbol-package slot-name)))) + `(accessor-slot-value ,object-form ,slot-name-form) + `(slot-value-normal ,object-form ,slot-name-form))) (defun set-slot-value (object slot-name new-value) - (fast-set-slot-value object slot-name new-value)) - -(define-compiler-macro set-slot-value (object-form slot-name-form new-value-form) - `(fast-set-slot-value ,object-form ,slot-name-form ,new-value-form)) - -(eval-when (compile load eval) -(defconstant *optimize-slot-boundp* nil)) - -(defun slow-slot-boundp (object slot-name) (let* ((class (class-of object)) - (slot-definition (find-slot-definition class slot-name))) + (slot-definition (find-slot-definition class slot-name))) (if (null slot-definition) - (slot-missing class object slot-name 'slot-boundp) - (slot-boundp-using-class class object slot-definition)))) + (slot-missing class object slot-name 'setf) + (setf (slot-value-using-class class object slot-definition) + new-value)))) -(defmacro accessor-slot-boundp (object slot-name-form) - (cond ((not *optimize-slot-boundp*) - `(slow-slot-boundp ,object ,slot-name-form)) - ((and (constantp slot-name-form) - (let ((slot-name (eval slot-name-form))) - (and (symbolp slot-name) (symbol-package slot-name)))) - (let* ((slot-name (eval slot-name-form)) - (sym (slot-boundp-symbol slot-name))) - (once-only (object) - `(if (fboundp ',sym) - (funcall-compiled (symbol-function ',sym) ,object) - (no-slot-boundp-accessor ,object ',slot-name ',sym))))) - (T - (let ((sym (gensym "BOUNDP-SYM"))) - (once-only (object slot-name-form) - `(let ((,sym (slot-boundp-symbol ,slot-name-form))) - (declare (type symbol ,sym)) - (if (fboundp ,sym) - (funcall-compiled (symbol-function ,sym) ,object) - (no-slot-boundp-accessor ,object ,slot-name-form ',sym)))))))) +(setf (symbol-function 'set-slot-value-normal) #'set-slot-value) -(defmacro wrapper-optimized-slot-boundp (object slot-name - &optional - (alternate-sv 'accessor-slot-boundp)) - (once-only (object slot-name) - `(locally (declare #.*optimize-speed*) - (let ((wrapper NIL) - (slots NIL)) - (if (or (and (std-instance-p ,object) - (setf wrapper (fast-check-wrapper-validity - ,object std-instance-wrapper)) - (setf slots (std-instance-slots ,object))) - (and (fsc-instance-p ,object) - (setf wrapper (fast-check-wrapper-validity - ,object fsc-instance-wrapper)) - (setf slots (fsc-instance-slots ,object))) - #+pcl-user-instances - (and (get-user-instance-p ,object) - (setf wrapper (fast-check-user-wrapper-validity ,object)) - (setf slots (get-user-instance-slots ,object)))) - (slot-boundp-from-wrapper-and-slots - ,object ,slot-name wrapper NIL slots NIL) - (,alternate-sv ,object ,slot-name)))))) +(define-compiler-macro set-slot-value (object-form slot-name-form new-value-form) + (if (and (constantp slot-name-form) + (let ((slot-name (eval slot-name-form))) + (and (symbolp slot-name) (symbol-package slot-name)))) + `(accessor-set-slot-value ,object-form ,slot-name-form ,new-value-form) + `(set-slot-value-normal ,object-form ,slot-name-form ,new-value-form))) -(defmacro fast-slot-boundp (object slot-name - &optional (alternate-sv 'accessor-slot-boundp)) - "Optimized macro version of slot-boundp." - (cond (*always-safe-to-use-slot-wrapper-optimizations-p* - `(wrapper-optimized-slot-boundp ,object ,slot-name ,alternate-sv)) - (*safe-to-use-slot-boundp-wrapper-optimizations-p* - (once-only (object slot-name) - `(locally (declare #.*optimize-speed*) - (if *safe-to-use-slot-boundp-wrapper-optimizations-p* - (wrapper-optimized-slot-boundp ,object ,slot-name ,alternate-sv) - (,alternate-sv ,object ,slot-name))))) - (T `(,alternate-sv ,object ,slot-name)))) +(defconstant *optimize-slot-boundp* nil) (defun slot-boundp (object slot-name) - (fast-slot-boundp object slot-name)) + (let* ((class (class-of object)) + (slot-definition (find-slot-definition class slot-name))) + (if (null slot-definition) + (slot-missing class object slot-name 'slot-boundp) + (slot-boundp-using-class class object slot-definition)))) -(define-compiler-macro slot-boundp (object-form slot-name-form) - `(fast-slot-boundp ,object-form ,slot-name-form)) +(setf (symbol-function '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))) (defun slot-makunbound (object slot-name) (let* ((class (class-of object)) @@ -871,10 +186,8 @@ (slot-makunbound-using-class class object slot-definition)))) (defun slot-exists-p (object slot-name) - (let* ((class (class-of object)) - (slot-definition (find-slot-definition class slot-name))) - (and slot-definition - (slot-exists-p-using-class class object slot-definition)))) + (let ((class (class-of object))) + (not (null (find-slot-definition class slot-name))))) ;;; ;;; This isn't documented, but is used within PCL in a number of print @@ -885,435 +198,188 @@ (slot-value object slot-name) default)) - + ;;; ;;; ;;; (defun standard-instance-access (instance location) - (%svref (std-instance-slots instance) location)) + (%instance-ref (std-instance-slots instance) location)) (defun funcallable-standard-instance-access (instance location) - (%svref (fsc-instance-slots instance) location)) - -(defun set-standard-instance-access (instance location new-value) - (setf (%svref (std-instance-slots instance) location) new-value)) - -(defun set-funcallable-standard-instance-access (instance location new-value) - (setf (%svref (fsc-instance-slots instance) location) new-value)) - -(defsetf standard-instance-access set-standard-instance-access) -(defsetf funcallable-standard-instance-access set-funcallable-standard-instance-access) - -#+pcl-user-instances -(defun user-instance-access (instance location) - (%svref (user-instance-slots instance) location)) - -#+pcl-user-instances -(defun set-user-instance-access (instance location new-value) - (setf (%svref (user-instance-slots instance) location) new-value)) - -#+pcl-user-instances -(defsetf user-instance-access set-user-instance-access) + (%instance-ref (fsc-instance-slots instance) location)) (defmethod slot-value-using-class ((class std-class) (object standard-object) (slotd standard-effective-slot-definition)) (let* ((location (slot-definition-location slotd)) - (value (typecase location - (fixnum - (cond ((std-instance-p object) - (unless (eq 't (wrapper-state (std-instance-wrapper object))) - (check-wrapper-validity object)) - (%svref (std-instance-slots object) location)) - ((fsc-instance-p object) - (unless (eq 't (wrapper-state (fsc-instance-wrapper object))) - (check-wrapper-validity object)) - (%svref (fsc-instance-slots object) location)) - #+pcl-user-instances - ((user-instance-p object) - (unless (eq 't (wrapper-state (user-instance-wrapper object))) - (check-wrapper-validity object)) - (%svref (user-instance-slots object) location)) - (t (wrapper-error object)))) - (cons - (cdr location)) - (t - (error "The slot ~s has neither :instance nor :class allocation, ~@ + (value (typecase location + (fixnum + (cond ((std-instance-p object) + (unless (eq 't (wrapper-state (std-instance-wrapper object))) + (check-wrapper-validity object)) + (%instance-ref (std-instance-slots object) location)) + ((fsc-instance-p object) + (unless (eq 't (wrapper-state (fsc-instance-wrapper object))) + (check-wrapper-validity object)) + (%instance-ref (fsc-instance-slots object) location)) + (t (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))))) + slotd 'slot-value-using-class))))) (if (eq value *slot-unbound*) - (slot-unbound class object (slot-definition-name slotd)) - value))) + (slot-unbound class object (slot-definition-name slotd)) + value))) (defmethod (setf slot-value-using-class) - (new-value (class std-class) - (object standard-object) - (slotd standard-effective-slot-definition)) + (new-value (class std-class) + (object standard-object) + (slotd standard-effective-slot-definition)) (let ((location (slot-definition-location slotd))) (typecase location (fixnum (cond ((std-instance-p object) - (unless (eq 't (wrapper-state (std-instance-wrapper object))) - (check-wrapper-validity object)) - (setf (%svref (std-instance-slots object) location) new-value)) - ((fsc-instance-p object) - (unless (eq 't (wrapper-state (fsc-instance-wrapper object))) - (check-wrapper-validity object)) - (setf (%svref (fsc-instance-slots object) location) new-value)) - #+pcl-user-instances - ((user-instance-p object) - (unless (eq 't (wrapper-state (user-instance-wrapper object))) - (check-wrapper-validity object)) - (setf (%svref (user-instance-slots object) location) new-value)) - (t (wrapper-error object)))) + (unless (eq 't (wrapper-state (std-instance-wrapper object))) + (check-wrapper-validity object)) + (setf (%instance-ref (std-instance-slots object) location) new-value)) + ((fsc-instance-p object) + (unless (eq 't (wrapper-state (fsc-instance-wrapper object))) + (check-wrapper-validity object)) + (setf (%instance-ref (fsc-instance-slots object) location) new-value)) + (t (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)))))) + slotd '(setf slot-value-using-class)))))) (defmethod slot-boundp-using-class - ((class std-class) - (object standard-object) - (slotd standard-effective-slot-definition)) + ((class std-class) + (object standard-object) + (slotd standard-effective-slot-definition)) (let* ((location (slot-definition-location slotd)) - (value (typecase location - (fixnum - (cond ((std-instance-p object) - (unless (eq 't (wrapper-state (std-instance-wrapper object))) - (check-wrapper-validity object)) - (%svref (std-instance-slots object) location)) - ((fsc-instance-p object) - (unless (eq 't (wrapper-state (fsc-instance-wrapper object))) - (check-wrapper-validity object)) - (%svref (fsc-instance-slots object) location)) - #+pcl-user-instances - ((user-instance-p object) - (unless (eq 't (wrapper-state (user-instance-wrapper object))) - (check-wrapper-validity object)) - (%svref (user-instance-slots object) location)) - (t (wrapper-error object)))) - (cons - (cdr location)) - (t - (error "The slot ~s has neither :instance nor :class allocation, ~@ + (value (typecase location + (fixnum + (cond ((std-instance-p object) + (unless (eq 't (wrapper-state (std-instance-wrapper object))) + (check-wrapper-validity object)) + (%instance-ref (std-instance-slots object) location)) + ((fsc-instance-p object) + (unless (eq 't (wrapper-state (fsc-instance-wrapper object))) + (check-wrapper-validity object)) + (%instance-ref (fsc-instance-slots object) location)) + (t (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))))) + slotd 'slot-boundp-using-class))))) (not (eq value *slot-unbound*)))) (defmethod slot-makunbound-using-class - ((class std-class) - (object standard-object) - (slotd standard-effective-slot-definition)) + ((class std-class) + (object standard-object) + (slotd standard-effective-slot-definition)) (let ((location (slot-definition-location slotd))) (typecase location (fixnum (cond ((std-instance-p object) - (unless (eq 't (wrapper-state (std-instance-wrapper object))) - (check-wrapper-validity object)) - (setf (%svref (std-instance-slots object) location) *slot-unbound*)) - ((fsc-instance-p object) - (unless (eq 't (wrapper-state (fsc-instance-wrapper object))) - (check-wrapper-validity object)) - (setf (%svref (fsc-instance-slots object) location) *slot-unbound*)) - #+pcl-user-instances - ((user-instance-p object) - (unless (eq 't (wrapper-state (user-instance-wrapper object))) - (check-wrapper-validity object)) - (setf (%svref (user-instance-slots object) location) *slot-unbound*)) - (t (wrapper-error object)))) + (unless (eq 't (wrapper-state (std-instance-wrapper object))) + (check-wrapper-validity object)) + (setf (%instance-ref (std-instance-slots object) location) *slot-unbound*)) + ((fsc-instance-p object) + (unless (eq 't (wrapper-state (fsc-instance-wrapper object))) + (check-wrapper-validity object)) + (setf (%instance-ref (fsc-instance-slots object) location) *slot-unbound*)) + (t (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)))) + slotd 'slot-makunbound-using-class)))) nil) -(defmethod slot-exists-p-using-class - ((class std-class) - (object standard-object) - (slotd standard-effective-slot-definition)) - t) - - -(defmacro structure-instance-slot-value (instance slot-name) - "Highly-optimized macro for returning the slot-value of instances that - are guaranteed to be structure instances with normal slots." - `(accessor-slot-value ,instance ,slot-name)) - -(defmacro set-structure-instance-slot-value (instance slot-name new-value) - "Highly-optimized macro for setting the slot-value of instances that - are guaranteed to be structure instances with normal slots." - `(accessor-set-slot-value ,instance ,slot-name ,new-value)) - -(defmacro structure-instance-slot-boundp (instance slot-name) - "Highly-optimized macro for checking whether a slot is bound for instances - that are guaranteed to be structure-instances with normal slots." - `(accessor-slot-boundp ,instance ,slot-name)) - -(defsetf structure-instance-slot-value set-structure-instance-slot-value) - - (defmethod slot-value-using-class ((class structure-class) (object structure-object) (slotd structure-effective-slot-definition)) - (let ((function (slot-definition-internal-reader-function slotd))) - (method-function-funcall function object))) + (let* ((function (slot-definition-internal-reader-function slotd)) + (value (funcall function object))) + #+cmu (declare (type function function)) + (if (eq value *slot-unbound*) + (slot-unbound class object (slot-definition-name slotd)) + value))) (defmethod (setf slot-value-using-class) (new-value (class structure-class) - (object structure-object) - (slotd structure-effective-slot-definition)) + (object structure-object) + (slotd structure-effective-slot-definition)) (let ((function (slot-definition-internal-writer-function slotd))) - (method-function-funcall function new-value object))) + #+cmu (declare (type function function)) + (funcall function new-value object))) (defmethod slot-boundp-using-class - ((class structure-class) - (object structure-object) - (slotd structure-effective-slot-definition)) - t) + ((class structure-class) + (object structure-object) + (slotd structure-effective-slot-definition)) + #-new-kcl-wrapper t + #+new-kcl-wrapper + (let* ((function (slot-definition-internal-reader-function slotd)) + (value (funcall function object))) + #+cmu (declare (type function function)) + (not (eq value *slot-unbound*)))) (defmethod slot-makunbound-using-class - ((class structure-class) - (object structure-object) - (slotd structure-effective-slot-definition)) + ((class structure-class) + (object structure-object) + (slotd structure-effective-slot-definition)) (error "Structure slots can't be unbound")) - + (defmethod slot-missing - ((class t) instance slot-name operation &optional new-value) + ((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)) + (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 "The slot ~S is unbound in the object ~S." slot-name instance)) - -(defun structure-slot-boundp (object) - (declare (ignore object)) - t) - -(declaim (ftype (function (T T T) (values function boolean)) - get-optimized-std-accessor-method-function)) -(defun get-optimized-std-accessor-method-function (class slotd name) - (if (structure-class-p class) - (values - (ecase name - (reader (slot-definition-internal-reader-function slotd)) - (writer (slot-definition-internal-writer-function slotd)) - (boundp #'structure-slot-boundp)) - nil) - (let* ((instance-type (class-instance-type class)) - (slot-name (slot-definition-name slotd)) - (index (slot-definition-location slotd)) - (function (ecase name - (reader #'get-optimized-std-reader-method-function) - (writer #'get-optimized-std-writer-method-function) - (boundp #'get-optimized-std-boundp-method-function))) - (value (funcall-function function instance-type slot-name index))) - (values value (not (null index)))))) - -(defvar *optimized-std-reader-table* (make-hash-table :test 'equal)) -(defvar *optimized-std-writer-table* (make-hash-table :test 'equal)) -(defvar *optimized-std-boundp-table* (make-hash-table :test 'equal)) - -(defun get-optimized-std-reader-method-function (instance-type slot-name index) - (etypecase index - (fixnum - (let ((table-index (list instance-type slot-name index))) - (or (gethash table-index *optimized-std-reader-table*) - (setf (gethash table-index *optimized-std-reader-table*) - (make-optimized-std-reader-method-function - instance-type slot-name index))))) - (cons - (make-optimized-std-reader-method-function - instance-type slot-name index)))) - -(defun get-optimized-std-writer-method-function (instance-type slot-name index) - (etypecase index - (fixnum - (let ((table-index (list instance-type slot-name index))) - (or (gethash table-index *optimized-std-writer-table*) - (setf (gethash table-index *optimized-std-writer-table*) - (make-optimized-std-writer-method-function - instance-type slot-name index))))) - (cons - (make-optimized-std-writer-method-function - instance-type slot-name index)))) - -(defun get-optimized-std-boundp-method-function (instance-type slot-name index) - (etypecase index - (fixnum - (let ((table-index (list instance-type slot-name index))) - (or (gethash table-index *optimized-std-boundp-table*) - (setf (gethash table-index *optimized-std-boundp-table*) - (make-optimized-std-boundp-method-function - instance-type slot-name index))))) - (cons - (make-optimized-std-boundp-method-function - instance-type slot-name index)))) - -(defun make-optimized-std-reader-method-function (instance-type slot-name index) - (declare #.*optimize-speed*) - (set-function-name - (etypecase index - (fixnum (ecase instance-type - (std-instance - #'(lambda (instance) - (let ((value (%svref (std-instance-slots instance) index))) - (if (eq value *slot-unbound*) - (slot-unbound (class-of instance) instance slot-name) - value)))) - (fsc-instance - #'(lambda (instance) - (let ((value (%svref (fsc-instance-slots instance) index))) - (if (eq value *slot-unbound*) - (slot-unbound (class-of instance) instance slot-name) - value)))) - #+pcl-user-instances - (user-instance - (make-optimized-user-reader-method-function slot-name index)))) - (cons #'(lambda (instance) - (let ((value (cdr index))) - (if (eq value *slot-unbound*) - (slot-unbound (class-of instance) instance slot-name) - value))))) - `(reader ,slot-name))) - -(defun make-optimized-std-writer-method-function (instance-type slot-name index) - (declare #.*optimize-speed*) - (set-function-name - (etypecase index - (fixnum (ecase instance-type - (std-instance - #'(lambda (nv instance) - (setf (%svref (std-instance-slots instance) index) nv))) - (fsc-instance - #'(lambda (nv instance) - (setf (%svref (fsc-instance-slots instance) index) nv))) - #+pcl-user-instances - (user-instance - (make-optimized-user-writer-method-function index)))) - (cons #'(lambda (nv instance) - (declare (ignore instance)) - (setf (cdr index) nv)))) - `(writer ,slot-name))) - -(defun make-optimized-std-boundp-method-function (instance-type slot-name index) - (declare #.*optimize-speed*) - (set-function-name - (etypecase index - (fixnum (ecase instance-type - (std-instance - #'(lambda (instance) - (not (eq *slot-unbound* - (%svref (std-instance-slots instance) index))))) - (fsc-instance - #'(lambda (instance) - (not (eq *slot-unbound* - (%svref (fsc-instance-slots instance) index))))) - #+pcl-user-instances - (user-instance - (make-optimized-user-boundp-method-function index)))) - (cons #'(lambda (instance) - (declare (ignore instance)) - (not (eq *slot-unbound* (cdr index)))))) - `(boundp ,slot-name))) - -#+pcl-user-instances -(defun make-optimized-user-reader-method-function (slot-name index) - (declare #.*optimize-speed*) - (progn slot-name) - #'(lambda (instance) - (let ((value (%svref (user-instance-slots instance) index))) - (if (eq value *slot-unbound*) - (slot-unbound (class-of instance) instance slot-name) - value)))) - -#+pcl-user-instances -(defun make-optimized-user-writer-method-function (index) - (declare #.*optimize-speed*) - #'(lambda (nv instance) - (setf (%svref (user-instance-slots instance) index) nv))) - -#+pcl-user-instances -(defun make-optimized-user-boundp-method-function (index) - (declare #.*optimize-speed*) - #'(lambda (instance) - (not (eq *slot-unbound* (%svref (user-instance-slots instance) index))))) - - -(defvar *accessor-from-svuc-table* (make-hash-table :test 'equal)) - -(defun get-accessor-from-svuc-method-function (class slotd sdfun name) - (declare (type real-function sdfun)) - (let ((table-index (list class slotd sdfun name))) - (or (gethash table-index *accessor-from-svuc-table*) - (setf (gethash table-index *accessor-from-svuc-table*) - (make-accessor-from-svuc-method-function - class slotd sdfun name))))) - -(defun make-accessor-from-svuc-method-function (class slotd sdfun name) - (declare #.*optimize-speed*) - (declare (type real-function sdfun)) - (set-function-name - (case name - (reader #'(lambda (instance) - (method-function-funcall sdfun class instance slotd))) - (writer #'(lambda (nv instance) - (method-function-funcall sdfun nv class instance slotd))) - (boundp #'(lambda (instance) - (method-function-funcall sdfun class instance slotd)))) - `(,name ,(class-name class) ,(slot-definition-name slotd)))) - - -(defun make-std-reader-method-function (slot-name) - (declare #.*optimize-speed*) - #'(lambda (instance) - (fast-slot-value instance slot-name slow-slot-value))) - -(defun make-std-writer-method-function (slot-name) - (declare #.*optimize-speed*) - #'(lambda (nv instance) - (fast-set-slot-value instance slot-name nv slow-slot-value))) - -(defun make-std-boundp-method-function (slot-name) - (declare #.*optimize-speed*) - #'(lambda (instance) - (fast-slot-boundp instance slot-name slow-slot-boundp))) - - -(defun make-documented-std-reader-method-function (slot-name) - (declare #.*optimize-speed*) - #'(lambda (args next-methods) - (declare (ignore next-methods)) - (let ((instance (car args))) - (fast-slot-value instance slot-name slow-slot-value)))) - -(defun make-documented-std-writer-method-function (slot-name) - (declare #.*optimize-speed*) - #'(lambda (args next-methods) - (declare (ignore next-methods)) - (let ((instance (cadr args)) - (new-value (car args))) - (fast-set-slot-value instance slot-name new-value slow-slot-value)))) - -(defun make-documented-std-boundp-method-function (slot-name) - (declare #.*optimize-speed*) - #'(lambda (args next-methods) - (declare (ignore next-methods)) - (let ((instance (car args))) - (fast-slot-boundp instance slot-name slow-slot-boundp)))) +(defun slot-unbound-internal (instance position) + (slot-unbound (class-of instance) instance + (etypecase position + (fixnum + (nth position + (wrapper-instance-slots-layout (wrapper-of instance)))) + (cons + (car position))))) + + +(defmethod allocate-instance ((class standard-class) &rest initargs) + (declare (ignore initargs)) + (unless (class-finalized-p class) (finalize-inheritance class)) + (allocate-standard-instance (class-wrapper class))) + +(defmethod allocate-instance ((class structure-class) &rest initargs) + (declare (ignore initargs)) + #-new-kcl-wrapper + (let ((constructor (class-defstruct-constructor class))) + (if constructor + (funcall constructor) + (error "Can't allocate an instance of class ~S" (class-name class)))) + #+new-kcl-wrapper + (allocate-standard-instance (class-wrapper class))) diff --git a/pcl/std-class.lisp b/pcl/std-class.lisp index cc73962d1..f41dd8668 100644 --- a/pcl/std-class.lisp +++ b/pcl/std-class.lisp @@ -33,39 +33,29 @@ (writer (slot-definition-writer-function slotd)) (boundp (slot-definition-boundp-function slotd)))) -(defvar *dfuns-needing-update* NIL) -(defvar *classes-being-updated* NIL) - -(defmethod update-slot-accessor-function ((slotd effective-slot-definition) - type function - &optional (update-accessors-p T)) +(defmethod (setf slot-accessor-function) (function + (slotd effective-slot-definition) type) (ecase type - (reader (setf (slot-definition-reader-function slotd) function) - (when (and update-accessors-p (eq *boot-state* 'complete)) - (dolist (reader (slot-definition-readers slotd)) - (pushnew reader *dfuns-needing-update* :test #'eq)))) - (writer (setf (slot-definition-writer-function slotd) function) - (when (and update-accessors-p (eq *boot-state* 'complete)) - (dolist (writer (slot-definition-writers slotd)) - (pushnew writer *dfuns-needing-update*)))) + (reader (setf (slot-definition-reader-function slotd) function)) + (writer (setf (slot-definition-writer-function slotd) function)) (boundp (setf (slot-definition-boundp-function slotd) function)))) (defconstant *slotd-reader-function-std-p* 1) (defconstant *slotd-writer-function-std-p* 2) (defconstant *slotd-boundp-function-std-p* 4) -(defconstant *slotd-all-function-std-p* 7) +(defconstant *slotd-all-function-std-p* 7) (defmethod slot-accessor-std-p ((slotd effective-slot-definition) type) (let ((flags (slot-value slotd 'accessor-flags))) - (declare (type index flags)) + (declare (type fixnum flags)) (if (eq type 'all) - (= *slotd-all-function-std-p* flags) + (eql *slotd-all-function-std-p* flags) (let ((mask (ecase type (reader *slotd-reader-function-std-p*) (writer *slotd-writer-function-std-p*) (boundp *slotd-boundp-function-std-p*)))) - (declare (type index mask)) - (not (zerop (the index (logand mask flags)))))))) + (declare (type fixnum mask)) + (not (zerop (the fixnum (logand mask flags)))))))) (defmethod (setf slot-accessor-std-p) (value (slotd effective-slot-definition) type) (let ((mask (ecase type @@ -73,73 +63,56 @@ (writer *slotd-writer-function-std-p*) (boundp *slotd-boundp-function-std-p*))) (flags (slot-value slotd 'accessor-flags))) - (declare (type index mask flags)) + (declare (type fixnum mask flags)) (setf (slot-value slotd 'accessor-flags) (if value - (the index (logior mask flags)) - (the index (logand (the index (lognot mask)) flags))))) + (the fixnum (logior mask flags)) + (the fixnum (logand (the fixnum (lognot mask)) flags))))) value) -(defvar *name->class->slotd-table* (make-hash-table)) - (defmethod initialize-internal-slot-functions ((slotd effective-slot-definition)) (let* ((name (slot-value slotd 'name)) - (class (slot-value slotd 'class)) - (old-slotd (and (slot-boundp class 'slots) - (find-slot-definition class name)))) + (class (slot-value slotd 'class))) (let ((table (or (gethash name *name->class->slotd-table*) (setf (gethash name *name->class->slotd-table*) (make-hash-table :test 'eq :size 5))))) (setf (gethash class table) slotd)) (dolist (type '(reader writer boundp)) - (multiple-value-bind (function std-p) - (if (eq *boot-state* 'complete) - (let* ((gf-name (ecase type - (reader 'slot-value-using-class) - (writer '(setf slot-value-using-class)) - (boundp 'slot-boundp-using-class))) - (gf (gdefinition gf-name))) - (get-accessor-method-function gf type class slotd)) - (get-optimized-std-accessor-method-function class slotd type)) - (setf (slot-accessor-std-p slotd type) std-p) - (let ((old-function - (if old-slotd (slot-accessor-function old-slotd type)))) - (update-slot-accessor-function slotd type function - (and old-function (neq function old-function)))))))) - -(defmethod initialize-internal-slot-functions :after - ((slotd standard-effective-slot-definition)) - (let ((name (slot-definition-name slotd))) - (unless *safe-to-use-slot-value-wrapper-optimizations-p* - (initialize-internal-slot-reader-gfs name)) - (unless *safe-to-use-set-slot-value-wrapper-optimizations-p* - (initialize-internal-slot-writer-gfs name)) - (unless *safe-to-use-slot-boundp-wrapper-optimizations-p* - (initialize-internal-slot-boundp-gfs name)))) - -(defmethod (setf slot-definition-reader-function) :after - (new-value (slotd effective-slot-definition)) - (setf (internal-slotd-reader-function (slot-value slotd 'internal-slotd)) - new-value)) - -(defmethod (setf slot-definition-writer-function) :after - (new-value (slotd effective-slot-definition)) - (setf (internal-slotd-writer-function (slot-value slotd 'internal-slotd)) - new-value)) - -(defmethod (setf slot-definition-boundp-function) :after - (new-value (slotd effective-slot-definition)) - (setf (internal-slotd-boundp-function (slot-value slotd 'internal-slotd)) - new-value)) - -(defmethod (setf slot-definition-location) :after - (location (slotd standard-effective-slot-definition)) - (setf (internal-slotd-location (slot-value slotd 'internal-slotd)) - location) - (initialize-internal-slot-functions slotd)) - + (let* ((gf-name (ecase type + (reader 'slot-value-using-class) + (writer '(setf slot-value-using-class)) + (boundp 'slot-boundp-using-class))) + (gf (gdefinition gf-name))) + (compute-slot-accessor-info slotd type gf))) + (initialize-internal-slot-gfs name))) + +(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)) + (old-std-p (and old-slotd (slot-accessor-std-p old-slotd 'all)))) + (multiple-value-bind (function std-p) + (if (eq *boot-state* 'complete) + (get-accessor-method-function gf type class slotd) + (get-optimized-std-accessor-method-function class slotd type)) + #+kcl (si:turbo-closure function) + (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*)))) + +(defmethod slot-definition-allocation ((slotd structure-slot-definition)) + :instance) + +(defmethod shared-initialize :after ((object documentation-mixin) + slot-names + &key (documentation nil documentation-p)) + (declare (ignore slot-names)) + (when documentation-p + (setf (plist-value object 'documentation) documentation))) + (defmethod documentation (object &optional doc-type) (lisp:documentation object doc-type)) @@ -148,57 +121,49 @@ (error "Can't change the documentation of ~S." object)) -(defmethod documentation ((object documentation-mixin) - &optional (doc-type NIL doc-type-p)) - (if doc-type-p - (error - "Doc-type parameter (~S) supplied to documentation called - on PCL object ~S" - doc-type object) - (slot-value object 'documentation))) - -(defmethod (setf documentation) (new-value (object documentation-mixin) - &optional (doc-type NIL doc-type-p)) - (if doc-type-p - (error - "Doc-type parameter (~S) supplied to (setf documentation) called - on PCL object ~S" - doc-type object) - (setf (slot-value object 'documentation) new-value))) - -(defmethod shared-initialize :before ((object documentation-mixin) - slot-names - &key documentation) - (declare (ignore slot-names)) - (unless (legal-documentation-p object documentation) - (error "When initializing the ~A ~S:~%~ - The ~S initialization argument was: ~A.~%~ - It must be a string or nil." - (string-downcase (symbol-name (class-name (class-of object)))) - object :documentation documentation))) +(defmethod documentation ((object documentation-mixin) &optional doc-type) + (declare (ignore doc-type)) + (plist-value object 'documentation)) + +(defmethod (setf documentation) (new-value (object documentation-mixin) &optional doc-type) + (declare (ignore doc-type)) + (setf (plist-value object 'documentation) new-value)) -(defmethod legal-documentation-p ((object documentation-mixin) x) - (or (null x) (stringp x))) +(defmethod documentation ((slotd standard-slot-definition) &optional doc-type) + (declare (ignore doc-type)) + (slot-value slotd 'documentation)) +(defmethod (setf documentation) (new-value (slotd standard-slot-definition) &optional doc-type) + (declare (ignore doc-type)) + (setf (slot-value slotd 'documentation) new-value)) ;;; ;;; Various class accessors that are a little more complicated than can be ;;; done with automatically generated reader methods. ;;; +(defmethod class-finalized-p ((class pcl-class)) + (with-slots (wrapper) class + (not (null wrapper)))) (defmethod class-prototype ((class std-class)) (with-slots (prototype) class - (or prototype - (if (memq class *classes-being-updated*) - (allocate-instance class) - (setq prototype (make-class-prototype class)))))) + (or prototype (setq prototype (allocate-instance class))))) + +(defmethod class-prototype ((class structure-class)) + (with-slots (prototype wrapper defstruct-constructor) class + (or prototype + (setq prototype + (if #-new-kcl-wrapper defstruct-constructor #+new-kcl-wrapper nil + (allocate-instance class) + (allocate-standard-instance wrapper)))))) -(defmethod make-class-prototype ((class std-class)) - (let ((proto (allocate-instance class))) - (shared-initialize proto T :check-initargs-legality-p NIL) - proto)) +(defmethod class-direct-default-initargs ((class slot-class)) + (plist-value class 'direct-default-initargs)) + +(defmethod class-default-initargs ((class slot-class)) + (plist-value class 'default-initargs)) (defmethod class-constructors ((class slot-class)) (plist-value class 'constructors)) @@ -206,24 +171,6 @@ (defmethod class-slot-cells ((class std-class)) (plist-value class 'class-slot-cells)) -(defmethod (setf class-name) (new-value (class std-class)) - (reinitialize-instance class :name new-value)) - -(defmethod slot-unbound :around ((class class) class-instance slot-name) - (let ((documented-reader - (case slot-name - (default-initargs 'class-default-initargs) - (class-precedence-list 'class-precedence-list) - (prototype 'class-prototype) - (slots 'class-slots)))) - (if documented-reader - (if (class-finalized-p class-instance) - (error "Huh? -- ~S slot unbound in ~S when finalized." - slot-name class-instance) - (error "~S called on ~S before it is finalized." - documented-reader class-instance)) - (call-next-method)))) - ;;; ;;; Class accessors that are even a little bit more complicated than those @@ -336,15 +283,7 @@ (dolist (m (car entry)) (gather1 (method-generic-function m))))))))) -(defun map-all-classes (function &optional (root-name 't)) - (declare (type real-function function)) - (labels ((do-class (class) - (mapc #'do-class (class-direct-subclasses class)) - (funcall function class))) - (do-class (find-class root-name)))) - (defun map-specializers (function) - (declare (type real-function function)) (map-all-classes #'(lambda (class) (funcall function (class-eq-specializer class)) (funcall function class))) @@ -359,7 +298,6 @@ nil) (defun map-all-generic-functions (function) - (declare (type real-function function)) (let ((all-generic-functions (make-hash-table :test 'eq))) (map-specializers #'(lambda (specl) (dolist (gf (specializer-direct-generic-functions specl)) @@ -387,7 +325,29 @@ ,(load-truename)) other)) -(declaim (ftype (function (T T) (values T list)) ensure-class-values)) +(setf (symbol-function 'load-defclass) #'real-load-defclass) + +(defun ensure-class (name &rest all) + (apply #'ensure-class-using-class name (find-class name nil) all)) + +(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);*** + (setf class (apply #'make-instance meta :name name initargs) + (find-class name) class + (find-class-predicate name) (symbol-function (class-predicate-name class))) + (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)) + (apply #'reinitialize-instance class initargs) + (inform-type-system-about-class class name) ;*** + class)) + (defun ensure-class-values (class args) (let* ((initargs (copy-list args)) (unsupplied (list 1)) @@ -422,42 +382,19 @@ (and (neq supplied-slots unsupplied) supplied-slots) initargs))))) -(defun ensure-class (name &rest all) - (apply #'ensure-class-using-class name (find-class name nil) all)) - -(defmethod ensure-class-using-class (name (class null) &rest args &key) - (multiple-value-bind (meta initargs) - (ensure-class-values class args) - (setf class (apply #'make-instance meta :name name initargs)) - class)) - -(defmethod ensure-class-using-class (name (class pcl-class) &rest args &key) - (declare (ignore name)) - (multiple-value-bind (meta initargs) - (ensure-class-values class args) - (unless (eq (class-of class) meta) (change-class class meta)) - (apply #'reinitialize-instance class initargs) - class)) - ;;; ;;; ;;; - +#|| ; since it doesn't do anything (defmethod shared-initialize :before ((class std-class) slot-names - &key (name nil name-p)) + &key direct-superclasses) (declare (ignore slot-names)) - (when name-p - (unless (legal-class-name-p name) - (error "~S is not a legal class name." name)) - (when (slot-boundp class 'name) - (setf (find-class (slot-value class 'name)) nil)))) - -(defmethod make-direct-slotd ((class std-class) &rest initargs) - (let ((initargs (list* :class class initargs))) - (apply #'make-instance (direct-slot-definition-class class initargs) initargs))) - + ;; *** error checking + ) +||# + (defmethod shared-initialize :after ((class std-class) slot-names @@ -480,12 +417,11 @@ (setq direct-slots (if direct-slots-p (setf (slot-value class 'direct-slots) - (mapcar #'(lambda (pl) (apply #'make-direct-slotd class pl)) - direct-slots)) + (mapcar #'(lambda (pl) (make-direct-slotd class pl)) direct-slots)) (slot-value class 'direct-slots))) (if direct-default-initargs-p - (setf (slot-value class 'direct-default-initargs) direct-default-initargs) - (setq direct-default-initargs (class-direct-default-initargs class))) + (setf (plist-value class 'direct-default-initargs) direct-default-initargs) + (setq direct-default-initargs (plist-value class 'direct-default-initargs))) (setf (plist-value class 'class-slot-cells) (gathering1 (collecting) (dolist (dslotd direct-slots) @@ -493,24 +429,21 @@ (let ((initfunction (slot-definition-initfunction dslotd))) (gather1 (cons (slot-definition-name dslotd) (if initfunction - (slot-initfunction-funcall initfunction) + (funcall initfunction) *slot-unbound*)))))))) - (let ((name (class-name class))) - (when name - (if predicate-name-p - (progn - (setf (slot-value class 'predicate-name) (car predicate-name)) - (setf (find-class-predicate name) (make-class-predicate class))) - (unless (slot-value class 'predicate-name) - (setf (slot-value class 'predicate-name) - (make-class-predicate-name name)))) - (setf (find-class name) class) - (inform-type-system-about-class class name))) + (setq predicate-name (if predicate-name-p + (setf (slot-value class 'predicate-name) + (car predicate-name)) + (or (slot-value class 'predicate-name) + (setf (slot-value class 'predicate-name) + (make-class-predicate-name (class-name class)))))) (add-direct-subclasses class direct-superclasses) - (add-slot-accessors class direct-slots)) + (update-class class nil) + (make-class-predicate class predicate-name) + (add-slot-accessors class direct-slots)) -(defmethod shared-initialize :before ((class class) slot-names &key) - (declare (ignore slot-names)) +(defmethod shared-initialize :before ((class class) slot-names &key name) + (declare (ignore slot-names name)) (setf (slot-value class 'type) `(class ,class)) (setf (slot-value class 'class-eq-specializer) (make-instance 'class-eq-specializer :class class))) @@ -519,70 +452,127 @@ (remove-direct-subclasses class (class-direct-superclasses class)) (remove-slot-accessors class (class-direct-slots class))) -(defmethod reinitialize-instance :after ((class std-class) +(defmethod reinitialize-instance :after ((class slot-class) &rest initargs &key) - (update-class class nil) (map-dependents class #'(lambda (dependent) (apply #'update-dependent class dependent initargs)))) +(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)) + (if direct-superclasses-p + (setf (slot-value class 'direct-superclasses) + (or direct-superclasses + (setq direct-superclasses + (and (not (eq (class-name class) 'structure-object)) + (list *the-class-structure-object*))))) + (setq direct-superclasses (slot-value class 'direct-superclasses))) + (let* ((name (class-name class)) + (from-defclass-p (slot-value class 'from-defclass-p)) + (defstruct-p (or from-defclass-p (not (structure-type-p name))))) + (if direct-slots-p + (setf (slot-value class 'direct-slots) + (setq direct-slots + (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))) + (setq pl (list* :defstruct-accessor-symbol accessor + pl)))) + (make-direct-slotd class pl)) + direct-slots))) + (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))) + (defstruct `(defstruct (,name + ,@(when include + `((:include ,(class-name include)))) + (:print-function print-std-instance) + (:predicate nil) + (:conc-name ,conc-name) + (:constructor ,constructor ())) + ,@(mapcar #'(lambda (slot) + `(,(slot-definition-name slot) + *slot-unbound*)) + direct-slots))) + (reader-names (mapcar #'(lambda (slotd) + (intern (format nil "~A~A reader" conc-name + (slot-definition-name slotd)))) + direct-slots)) + (writer-names (mapcar #'(lambda (slotd) + (intern (format nil "~A~A writer" conc-name + (slot-definition-name slotd)))) + direct-slots)) + (readers-init + (mapcar #'(lambda (slotd reader-name) + (let ((accessor + (slot-definition-defstruct-accessor-symbol slotd))) + `(defun ,reader-name (obj) + (declare (type ,name obj)) + (,accessor obj)))) + direct-slots reader-names)) + (writers-init + (mapcar #'(lambda (slotd writer-name) + (let ((accessor + (slot-definition-defstruct-accessor-symbol slotd))) + `(defun ,writer-name (nv obj) + (declare (type ,name obj)) + (setf (,accessor obj) nv)))) + direct-slots writer-names)) + (defstruct-form + `(progn + ,defstruct + ,@readers-init ,@writers-init + (declare-structure ',name nil nil)))) + (unless (structure-type-p name) (eval defstruct-form)) + (mapc #'(lambda (dslotd reader-name writer-name) + (let* ((reader (gdefinition reader-name)) + (writer (when (gboundp writer-name) + (gdefinition writer-name)))) + (setf (slot-value dslotd 'internal-reader-function) reader) + (setf (slot-value dslotd 'internal-writer-function) writer))) + direct-slots reader-names writer-names) + (setf (slot-value class 'defstruct-form) defstruct-form) + (setf (slot-value class 'defstruct-constructor) constructor)))) + (add-direct-subclasses class direct-superclasses) + (setf (slot-value class 'class-precedence-list) + (compute-class-precedence-list class)) + (setf (slot-value class 'slots) (compute-slots class)) + #-new-kcl-wrapper + (unless (slot-value class 'wrapper) + (setf (slot-value class 'wrapper) (make-wrapper 0 class))) + #+new-kcl-wrapper + (let ((wrapper (get (class-name class) 'si::s-data))) + (setf (slot-value class 'wrapper) wrapper) + (setf (wrapper-class wrapper) class)) + (update-pv-table-cache-info class) + (setq predicate-name (if predicate-name-p + (setf (slot-value class 'predicate-name) + (car predicate-name)) + (or (slot-value class 'predicate-name) + (setf (slot-value class 'predicate-name) + (make-class-predicate-name (class-name class)))))) + (make-class-predicate class predicate-name) + (add-slot-accessors class direct-slots)) + +(defmethod direct-slot-definition-class ((class structure-class) initargs) + (declare (ignore initargs)) + (find-class 'structure-direct-slot-definition)) +(defmethod finalize-inheritance ((class structure-class)) + nil) ; always finalized -(defun make-class-predicate (class) - (let* ((name (class-predicate-name class)) - (gf (ensure-generic-function name)) - (method-class (find-class 'standard-method nil)) - (method-proto - (if (and method-class (class-finalized-p method-class)) - (class-prototype method-class))) - (store-method-function-p - (call-store-method-function-p gf method-proto nil)) - (store-method-optimized-function-p - (call-store-method-optimized-function-p gf method-proto nil)) - (mlist (if (eq *boot-state* 'complete) - (generic-function-methods gf) - (early-gf-methods gf)))) - (unless mlist - (unless (eq class *the-class-t*) - (let ((default-method - (make-a-method - 'standard-method - () - (list 'object) - (list *the-class-t*) - (when store-method-function-p - #'documented-function-returning-nil) - (when store-method-optimized-function-p - #'function-returning-nil) - NIL - "class predicate default method" - NIL - `(:constant-value NIL)))) - (add-method gf default-method))) - (let ((class-method - (make-a-method - 'standard-method - () - (list 'object) - (list class) - (when store-method-function-p - #'documented-function-returning-t) - (when store-method-optimized-function-p - #'function-returning-t) - NIL - "class predicate class method" - NIL - `(:constant-value T)))) - (add-method gf class-method))) - gf)) - -(defun fix-dfuns-needing-update () - (loop (unless *dfuns-needing-update* (return T)) - (let ((name (pop *dfuns-needing-update*))) - (when (gboundp name) - (update-dfun (gdefinition name)))))) - (defun add-slot-accessors (class dslotds) (fix-slot-accessors class dslotds 'add)) @@ -590,20 +580,19 @@ (fix-slot-accessors class dslotds 'remove)) (defun fix-slot-accessors (class dslotds add/remove) - (flet ((fix (gfspec name dslot r/w) + (flet ((fix (gfspec name r/w) (let ((gf (ensure-generic-function gfspec))) (case r/w (r (if (eq add/remove 'add) - (add-reader-method class gf name dslot) + (add-reader-method class gf name) (remove-reader-method class gf))) (w (if (eq add/remove 'add) - (add-writer-method class gf name dslot) + (add-writer-method class gf name) (remove-writer-method class gf))))))) (dolist (dslotd dslotds) - (let ((name (slot-definition-name dslotd))) - (dolist (r (slot-definition-readers dslotd)) (fix r name dslotd 'r)) - (dolist (w (slot-definition-writers dslotd)) (fix w name dslotd 'w))))) - (fix-dfuns-needing-update)) + (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)))))) (defun add-direct-subclasses (class new) @@ -620,34 +609,27 @@ ;;; ;;; ;;; - -(defvar *notify-finalize* NIL) - (defmethod finalize-inheritance ((class std-class)) - (when *notify-finalize* - (warn "Finalizing ~S" class)) (update-class class t)) -(defmacro assure-finalized (class) - (once-only (class) - `(unless (class-finalized-p ,class) (finalize-inheritance ,class)))) - - +(defun class-has-a-forward-referenced-superclass-p (class) + (or (forward-referenced-class-p class) + (some #'class-has-a-forward-referenced-superclass-p + (class-direct-superclasses class)))) ;;; ;;; 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) - (when (or finalizep (class-finalized-p class)) - (push class *classes-being-updated*) + (when (or finalizep (class-finalized-p class) + (not (class-has-a-forward-referenced-superclass-p class))) (update-cpl class (compute-class-precedence-list class)) - (update-slots class) + (update-slots class (compute-slots class)) (update-gfs-of-class class) (update-inits class (compute-default-initargs class)) - (update-constructors class) - (setf *classes-being-updated* (delete class *classes-being-updated*))) + (update-constructors class)) (unless finalizep (dolist (sub (class-direct-subclasses class)) (update-class sub nil)))) @@ -655,141 +637,98 @@ (when (class-finalized-p class) (unless (equal (class-precedence-list class) cpl) (force-cache-flushes class))) - (fast-set-slot-value class 'class-precedence-list cpl slow-slot-value) + (setf (slot-value class 'class-precedence-list) cpl) (update-class-can-precede-p cpl)) (defun update-class-can-precede-p (cpl) (when cpl - (let* ((first (car cpl)) - (orig-precede-list - (fast-slot-value first 'can-precede-list slow-slot-value)) - (precede-list orig-precede-list)) + (let ((first (car cpl))) (dolist (c (cdr cpl)) - (unless (memq c precede-list) - (setf precede-list (cons c precede-list)))) - (unless (eq precede-list orig-precede-list) - (fast-set-slot-value first 'can-precede-list precede-list - slow-slot-value))) + (pushnew c (slot-value first 'can-precede-list)))) (update-class-can-precede-p (cdr cpl)))) (defun class-can-precede-p (class1 class2) - (memq class2 (class-can-precede-list class1))) - + (member class2 (class-can-precede-list class1))) -(declaim (ftype (function (T T) (values list list)) compute-storage-info)) -(defmethod compute-storage-info ((class std-class) eslotds) +(defun update-slots (class eslotds) (let ((instance-slots ()) (class-slots ())) (dolist (eslotd eslotds) (let ((alloc (slot-definition-allocation eslotd))) (cond ((eq alloc :instance) (push eslotd instance-slots)) ((classp alloc) (push eslotd class-slots))))) - (values (compute-instance-layout class instance-slots) - (compute-class-slots class class-slots)))) - -(defmethod compute-instance-layout ((class std-class) instance-eslotds) - (mapcar #'slot-definition-name - (sort instance-eslotds #'< :key #'slot-definition-location))) - -(defmethod compute-class-slots ((class std-class) eslotds) + ;; + ;; If there is a change in the shape of the instances then the + ;; old class is now obsolete. + ;; + (let* ((nlayout (mapcar #'slot-definition-name + (sort instance-slots #'< :key #'slot-definition-location))) + (nslots (length nlayout)) + (nwrapper-class-slots (compute-class-slots class-slots)) + (owrapper (class-wrapper class)) + (olayout (and owrapper (wrapper-instance-slots-layout owrapper))) + (owrapper-class-slots (and owrapper (wrapper-class-slots owrapper))) + (nwrapper + (cond ((null owrapper) + (make-wrapper nslots class)) + ((and (equal nlayout olayout) + (not + (iterate ((o (list-elements owrapper-class-slots)) + (n (list-elements nwrapper-class-slots))) + (unless (eq (car o) (car n)) (return t))))) + owrapper) + (t + ;; + ;; This will initialize the new wrapper to have the same + ;; state as the old wrapper. We will then have to change + ;; that. This may seem like wasted work (it is), but the + ;; spec requires that we call make-instances-obsolete. + ;; + (make-instances-obsolete class) + (class-wrapper class))))) + (with-slots (wrapper slots) class + #+new-kcl-wrapper + (setf (si::s-data-name nwrapper) (class-name class)) + (setf slots eslotds + (wrapper-instance-slots-layout nwrapper) nlayout + (wrapper-class-slots nwrapper) nwrapper-class-slots + (wrapper-no-of-instance-slots nwrapper) nslots + wrapper nwrapper)) + (unless (eq owrapper nwrapper) + (update-pv-table-cache-info class))))) + +(defun compute-class-slots (eslotds) (gathering1 (collecting) (dolist (eslotd eslotds) (gather1 - (assq (slot-definition-name eslotd) - (class-slot-cells (slot-definition-allocation eslotd))))))) + (assoc (slot-definition-name eslotd) + (class-slot-cells (slot-definition-allocation eslotd))))))) -(defmethod compute-layout ((class std-class) cpl instance-eslotds) +(defun compute-layout (cpl instance-eslotds) (let* ((names (gathering1 (collecting) (dolist (eslotd instance-eslotds) - (gather1 (slot-definition-name eslotd))))) + (when (eq (slot-definition-allocation eslotd) :instance) + (gather1 (slot-definition-name eslotd)))))) (order ())) (labels ((rwalk (tail) (when tail (rwalk (cdr tail)) - (dolist (ss (class-direct-slots (car tail))) + (dolist (ss (class-slots (car tail))) (let ((n (slot-definition-name ss))) - (when (memq n names) + (when (member n names) (setq order (cons n order) names (remove n names)))))))) - (rwalk cpl) - (nreverse order)))) - -(defun update-slots (class) - (let* ((owrapper - (class-wrapper class)) - (nwrapper - (or owrapper - (progn - ;; The class isn't really totally finalized, but the - ;; class finalization functions have to think it is. - (fast-set-slot-value class 'finalized-p T slow-slot-value) - (setf (fast-slot-value class 'prototype) nil) - (setf (fast-slot-value class 'wrapper) (make-wrapper class))))) - (eslotds - (compute-slots class))) - (multiple-value-bind (nlayout nwrapper-class-slots) - (compute-storage-info class eslotds) - (declare (type list nlayout nwrapper-class-slots)) - ;; - ;; If there is a change in the shape of the instances then the - ;; old class is now obsolete. - ;; - (let* ((olayout (and owrapper (wrapper-instance-slots-layout owrapper))) - (owrapper-class-slots (and owrapper (wrapper-class-slots owrapper))) - (make-instances-obsolete-p - (not (or (null owrapper) - (and (equal nlayout olayout) - (not - (iterate ((o (list-elements owrapper-class-slots)) - (n (list-elements nwrapper-class-slots))) - (unless (eq (car o) (car n)) (return t))))))))) - (declare (type list olayout owrapper-class-slots) - (type boolean make-instances-obsolete-p)) - (when (or (null owrapper) make-instances-obsolete-p) - (let ((internal-slotds ()) - (side-effect-internal-slotds ())) - (dolist (eslotd eslotds) - (let ((internal-slotd (slot-definition-internal-slotd eslotd))) - (push internal-slotd internal-slotds) - (unless (slot-definition-initfunction-side-effect-free-p eslotd) - (push internal-slotd side-effect-internal-slotds)))) - (setf (slow-slot-value class 'slots) eslotds - (slow-slot-value class 'internal-slotds) - (nreverse internal-slotds) - (slow-slot-value class 'side-effect-internal-slotds) - (nreverse side-effect-internal-slotds))) - (setf ;; nwrapper is already the same as the class-wrapper - (wrapper-instance-slots-layout nwrapper) nlayout - (wrapper-allocate-static-slot-storage-copy nwrapper) - (%allocate-origional-static-slot-storage-copy (length nlayout)) - (wrapper-class-slots nwrapper) nwrapper-class-slots) - (unless owrapper - (setf (wrapper-unreserved-field nwrapper) NIL))) - (when make-instances-obsolete-p - (make-instances-obsolete class)) - (initialize-allocate-static-slot-storage-copy class))))) - -(defmethod initialize-allocate-static-slot-storage-copy ((class std-class)) - (let* ((dummy-instance (allocate-instance class)) - (side-effect-free-slots - (let ((collect nil)) - (dolist (slot (class-slots class) collect) - (when (slot-definition-initfunction-side-effect-free-p slot) - (push (slot-definition-name slot) collect))))) - (wrapper (class-wrapper class)) - (old-allocate-static-slot-storage-copy - (wrapper-allocate-static-slot-storage-copy wrapper))) - (shared-initialize dummy-instance side-effect-free-slots - :check-initargs-legality-p NIL) - (setf (wrapper-allocate-static-slot-storage-copy wrapper) - (or (get-slots-or-nil dummy-instance) - old-allocate-static-slot-storage-copy)))) + (rwalk (if (slot-boundp (car cpl) 'slots) + cpl + (cdr cpl))) + (reverse (append names order))))) (defun update-gfs-of-class (class) - (when (let ((cpl (class-precedence-list class))) - (or (memq *the-class-slot-class* cpl) - (memq *the-class-standard-effective-slot-definition* cpl))) + (when (and (class-finalized-p class) + (let ((cpl (class-precedence-list class))) + (or (member *the-class-slot-class* cpl) + (member *the-class-standard-effective-slot-definition* cpl)))) (let ((gf-table (make-hash-table :test 'eq))) (labels ((collect-gfs (class) (dolist (gf (specializer-direct-generic-functions class)) @@ -802,7 +741,7 @@ gf-table))))) (defun update-inits (class inits) - (setf (slot-value class 'default-initargs) inits)) + (setf (plist-value class 'default-initargs) inits)) ;;; @@ -833,6 +772,10 @@ (declare (ignore initargs)) (find-class 'standard-direct-slot-definition)) +(defun make-direct-slotd (class initargs) + (let ((initargs (list* :class class initargs))) + (apply #'make-instance (direct-slot-definition-class class initargs) initargs))) + ;;; ;;; ;;; @@ -844,7 +787,7 @@ ;; The list is in most-specific-first order. ;; (let ((name-dslotds-alist ())) - (dolist (c (slot-value class 'class-precedence-list)) + (dolist (c (class-precedence-list class)) (let ((dslotds (class-direct-slots c))) (dolist (d dslotds) (let* ((name (slot-definition-name d)) @@ -854,66 +797,54 @@ (push (list name d) name-dslotds-alist)))))) (mapcar #'(lambda (direct) (compute-effective-slot-definition class - (car direct) (nreverse (cdr direct)))) name-dslotds-alist))) (defmethod compute-slots :around ((class std-class)) (let ((eslotds (call-next-method)) - (cpl (slot-value class 'class-precedence-list)) + (cpl (class-precedence-list class)) (instance-slots ()) - (class-slots ()) - (other-slots ())) + (class-slots ())) (dolist (eslotd eslotds) (let ((alloc (slot-definition-allocation eslotd))) (cond ((eq alloc :instance) (push eslotd instance-slots)) - ((classp alloc) (push eslotd class-slots)) - (T (push eslotd other-slots))))) - (let ((nlayout (compute-layout class cpl instance-slots))) - (declare (type list nlayout)) + ((classp alloc) (push eslotd class-slots))))) + (let ((nlayout (compute-layout cpl instance-slots))) (dolist (eslotd instance-slots) (setf (slot-definition-location eslotd) - (posq (slot-definition-name eslotd) nlayout)))) + (position (slot-definition-name eslotd) nlayout)))) (dolist (eslotd class-slots) (setf (slot-definition-location eslotd) - (assq (slot-definition-name eslotd) - (class-slot-cells (slot-definition-allocation eslotd))))) - (dolist (eslotd other-slots) - (initialize-internal-slot-functions eslotd)) + (assoc (slot-definition-name eslotd) + (class-slot-cells (slot-definition-allocation eslotd))))) + (mapc #'initialize-internal-slot-functions eslotds) eslotds)) -(defmethod compute-effective-slot-definition ((class standard-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 - :location (slot-definition-location 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 ((class funcallable-standard-class) - name dslotds) +(defmethod compute-slots ((class structure-class)) + (mapcan #'(lambda (superclass) + (mapcar #'(lambda (dslotd) + (compute-effective-slot-definition class + (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 slot-class) 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 - :location (slot-definition-location 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)) + (class (effective-slot-definition-class class initargs))) + (apply #'make-instance class initargs))) (defmethod effective-slot-definition-class ((class std-class) initargs) (declare (ignore initargs)) - *the-class-standard-effective-slot-definition*) + (find-class 'standard-effective-slot-definition)) + +(defmethod effective-slot-definition-class ((class structure-class) initargs) + (declare (ignore initargs)) + (find-class 'structure-effective-slot-definition)) (defmethod compute-effective-slot-definition-initargs ((class slot-class) direct-slotds) @@ -922,16 +853,10 @@ (initform nil) (initargs nil) (allocation nil) - (documentation nil) (type t) (namep nil) (initp nil) - (allocp nil) - (readers nil) - (writers nil) - (initfunction-side-effect-free-p nil)) - (declare (type boolean namep initp allocp - initfunction-side-effect-free-p)) + (allocp nil)) (dolist (slotd direct-slotds) (when slotd @@ -939,11 +864,9 @@ (setq name (slot-definition-name slotd) namep t)) (unless initp - (setq initform (slot-definition-initform slotd)) (when (slot-definition-initfunction slotd) - (setq initfunction (slot-definition-initfunction slotd) - initfunction-side-effect-free-p - (slot-definition-initfunction-side-effect-free-p slotd) + (setq initform (slot-definition-initform slotd) + initfunction (slot-definition-initfunction slotd) initp t))) (unless allocp (setq allocation (slot-definition-allocation slotd) @@ -952,162 +875,65 @@ (let ((slotd-type (slot-definition-type slotd))) (setq type (cond ((eq type 't) slotd-type) ((*subtypep type slotd-type) type) - ((*subtypep slotd-type type) slotd-type) - (t `(and ,type ,slotd-type))))) - (unless documentation - (setq documentation - (fast-slot-value slotd 'documentation slow-slot-value))) - (dolist (reader (slot-definition-readers slotd)) - (pushnew reader readers :test #'eq)) - (dolist (writer (slot-definition-writers slotd)) - (pushnew writer writers :test #'eq)))) + (t `(and ,type ,slotd-type))))))) (list :name name :initform initform :initfunction initfunction - :initfunction-side-effect-free-p initfunction-side-effect-free-p :initargs initargs :allocation allocation :type type - :class class - :documentation documentation - :readers readers - :writers writers))) - - + :class class))) + +(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)))) ;;; ;;; NOTE: For bootstrapping considerations, these can't use make-instance ;;; to make the method object. They have to use make-a-method which ;;; is a specially bootstrapped mechanism for making standard methods. ;;; - -(defmethod add-reader-method ((class slot-class) - generic-function - slot-name - &optional - direct-slot) - (let* - ((reader-class - (reader-method-class class direct-slot)) - (reader-prototype - (when reader-class - (assure-finalized reader-class) - (class-prototype reader-class))) - (method - (make-a-method - (if reader-class (class-name reader-class) 'standard-reader-method) - () - (list (or (class-name class) 'standard-object)) - (list class) - (when (call-store-method-function-p generic-function reader-prototype nil) - (make-documented-reader-method-function - class generic-function reader-prototype slot-name)) - (when (call-store-method-optimized-function-p - generic-function reader-prototype nil) - (if (eq *boot-state* 'complete) - (make-optimized-reader-method-function - class generic-function reader-prototype slot-name) - (make-std-reader-method-function slot-name))) - NIL - "automatically generated reader method" - slot-name - `(,@(when direct-slot (list :slot-definition direct-slot)) - :needs-next-methods-p NIL)))) - (add-method generic-function method))) - -(defmethod add-writer-method ((class slot-class) - generic-function - slot-name - &optional - direct-slot) - (let* - ((writer-class - (writer-method-class class direct-slot)) - (writer-prototype - (when writer-class - (assure-finalized writer-class) - (class-prototype writer-class))) - (method - (make-a-method - (if writer-class (class-name writer-class) 'standard-writer-method) - () - (list 'new-value (or (class-name class) 'standard-object)) - (list *the-class-t* class) - (when (call-store-method-function-p generic-function writer-prototype nil) - (make-documented-writer-method-function - class generic-function writer-prototype slot-name)) - (when (call-store-method-optimized-function-p - generic-function writer-prototype nil) - (if (eq *boot-state* 'complete) - (make-optimized-writer-method-function - class generic-function writer-prototype slot-name) - (make-std-writer-method-function slot-name))) - NIL - "automatically generated writer method" - slot-name - `(,@(when direct-slot (list :slot-definition direct-slot)) - :needs-next-methods-p NIL)))) - (add-method generic-function method))) - -(defmethod add-boundp-method ((class slot-class) - generic-function - slot-name - &optional - direct-slot) - (let* - ((boundp-class - (boundp-method-class class direct-slot)) - (boundp-prototype - (when boundp-class - (assure-finalized boundp-class) - (class-prototype boundp-class))) - (method - (make-a-method - (if boundp-class (class-name boundp-class) 'standard-boundp-method) - () - (list (or (class-name class) 'standard-object)) - (list class) - (when (call-store-method-function-p generic-function boundp-prototype nil) - (make-documented-boundp-method-function - class generic-function boundp-prototype slot-name)) - (when (call-store-method-optimized-function-p - generic-function boundp-prototype nil) - (if (eq *boot-state* 'complete) - (make-optimized-boundp-method-function - class generic-function boundp-prototype slot-name) - (make-std-boundp-method-function slot-name))) - NIL - "automatically generated boundp method" - slot-name - `(,@(when direct-slot (list :slot-definition direct-slot)) - :needs-next-methods-p NIL)))) - (add-method generic-function method))) - - -(defmethod reader-method-class ((class T) - direct-slot - &rest initargs) - ;; To handle the case when a reader method is added before - ;; standard-reader-method is defined. +(defmethod reader-method-class ((class slot-class) direct-slot &rest initargs) (declare (ignore direct-slot initargs)) - NIL) - -(defmethod writer-method-class ((class T) - direct-slot - &rest initargs) - ;; To handle the case when a writer method is added before - ;; standard-writer-method is defined. + (find-class 'standard-reader-method)) + +(defmethod add-reader-method ((class slot-class) generic-function slot-name) + (add-method generic-function + (make-a-method 'standard-reader-method + () + (list (or (class-name class) 'object)) + (list class) + (make-reader-method-function class slot-name) + "automatically generated reader method" + slot-name))) + +(defmethod writer-method-class ((class slot-class) direct-slot &rest initargs) (declare (ignore direct-slot initargs)) - NIL) - -(defmethod boundp-method-class ((class T) - direct-slot - &rest initargs) - ;; To handle the case when a boundp method is added before - ;; standard-boundp-method is defined. - (declare (ignore direct-slot initargs)) - NIL) - + (find-class 'standard-writer-method)) + +(defmethod add-writer-method ((class slot-class) generic-function slot-name) + (add-method generic-function + (make-a-method 'standard-writer-method + () + (list 'new-value (or (class-name class) 'object)) + (list *the-class-t* class) + (make-writer-method-function class slot-name) + "automatically generated writer method" + slot-name))) + +(defmethod add-boundp-method ((class slot-class) generic-function slot-name) + (add-method generic-function + (make-a-method 'standard-boundp-method + () + (list (or (class-name class) 'object)) + (list class) + (make-boundp-method-function class slot-name) + "automatically generated boundp method" + slot-name))) (defmethod remove-reader-method ((class slot-class) generic-function) (let ((method (get-method generic-function () (list class) nil))) @@ -1138,225 +964,14 @@ ;;; *** have to give the optimize-slot-value method the user might have ;;; *** defined for this metclass a chance to run. ;;; +(defmethod make-reader-method-function ((class slot-class) slot-name) + (make-std-reader-method-function (class-name class) slot-name)) -(defvar *documented-reader-method-function-makers* NIL) -(defvar *documented-writer-method-function-makers* NIL) -(defvar *documented-boundp-method-function-makers* NIL) - -(defmethod make-documented-reader-method-function ((class slot-class) - generic-function - reader-method-prototype - slot-name) - ;; Make the documented reader-method-function. To do this correctly for - ;; all cases, we must build the reader method function by passing it - ;; through make-method-lambda in case the user does something funky - ;; with their method lambdas. - ;; Since there usually won't be many different kinds of method - ;; lambdas for readers, this method actually dynamically builds a function - ;; to make the documented-reader-method-function from each particular - ;; method lambda returned and stores it in - ;; *documented-reader-method-functions-makers* to be re-used each time - ;; the reader lambda is the same. - (multiple-value-bind (method-lambda initargs) - (call-make-method-lambda generic-function - reader-method-prototype - '(lambda (instance) - (funcall #'slot-value instance slot-name)) - ()) - (declare (ignore initargs)) - (funcall-compiled - (or (cdr (assoc method-lambda - *documented-reader-method-function-makers* - :test #'equal)) - (let ((reader-function-maker-name - (gensym "MAKE-DOCUMENTED-READER-METHOD-FUNCTION")) - (compiled-lambda - (compile-lambda - `(lambda (slot-name) (function ,method-lambda))))) - (declare (type compiled-function compiled-lambda)) - (setf (symbol-function reader-function-maker-name) - compiled-lambda) - (let ((func (eval `(function ,reader-function-maker-name)))) - (push (cons method-lambda func) - *documented-reader-method-function-makers*) - func))) - slot-name))) - -(defmethod make-documented-writer-method-function ((class slot-class) - generic-function - writer-method-prototype - slot-name) - ;; Make the documented writer-method-function. To do this correctly for - ;; all cases, we must build the writer method function by passing it - ;; through make-method-lambda in case the user does something funky - ;; with their method lambdas. - ;; Since there usually won't be many different kinds of method - ;; lambdas for writers, this method actually dynamically builds a function - ;; to make the documented-writer-method-function from each particular - ;; method lambda returned and stores it in - ;; *documented-writer-method-functions-makers* to be re-used each time - ;; the writer lambda is the same. - (multiple-value-bind (method-lambda initargs) - (call-make-method-lambda generic-function - writer-method-prototype - '(lambda (nv instance) - (funcall #'set-slot-value instance slot-name nv)) - ()) - (declare (ignore initargs)) - (funcall-compiled - (or (cdr (assoc method-lambda - *documented-writer-method-function-makers* - :test #'equal)) - (let ((writer-function-maker-name - (gensym "MAKE-DOCUMENTED-WRITER-METHOD-FUNCTION")) - (compiled-lambda - (compile-lambda - `(lambda (slot-name) (function ,method-lambda))))) - (declare (type compiled-function compiled-lambda)) - (setf (symbol-function writer-function-maker-name) - compiled-lambda) - (let ((func (eval `(function ,writer-function-maker-name)))) - (push (cons method-lambda func) - *documented-writer-method-function-makers*) - func))) - slot-name))) - -(defmethod make-documented-boundp-method-function ((class slot-class) - generic-function - boundp-method-prototype - slot-name) - ;; Make the documented boundp-method-function. To do this correctly for - ;; all cases, we must build the boundp method function by passing it - ;; through make-method-lambda in case the user does something funky - ;; with their method lambdas. - ;; Since there usually won't be many different kinds of method - ;; lambdas for boundps, this method actually dynamically builds a function - ;; to make the documented-boundp-method-function from each particular - ;; method lambda returned and stores it in - ;; *documented-boundp-method-functions-makers* to be re-used each time - ;; the boundp lambda is the same. - (multiple-value-bind (method-lambda initargs) - (call-make-method-lambda generic-function - boundp-method-prototype - '(lambda (instance) - (funcall #'slot-value instance slot-name)) - ()) - (declare (ignore initargs)) - (funcall-compiled - (or (cdr (assoc method-lambda - *documented-boundp-method-function-makers* - :test #'equal)) - (let ((boundp-function-maker-name - (gensym "MAKE-DOCUMENTED-READER-METHOD-FUNCTION")) - (compiled-lambda - (compile-lambda - `(lambda (slot-name) (function ,method-lambda))))) - (declare (type compiled-function compiled-lambda)) - (setf (symbol-function boundp-function-maker-name) - compiled-lambda) - (let ((func (eval `(function ,boundp-function-maker-name)))) - (push (cons method-lambda func) - *documented-boundp-method-function-makers*) - func))) - slot-name))) - -(defmethod make-optimized-reader-method-function ((class slot-class) - generic-function - reader-method-prototype - slot-name) - (declare (ignore generic-function reader-method-prototype)) - (make-std-reader-method-function slot-name)) - -(defmethod make-optimized-writer-method-function ((class slot-class) - generic-function - writer-method-prototype - slot-name) - (declare (ignore generic-function writer-method-prototype)) - (make-std-writer-method-function slot-name)) - -(defmethod make-optimized-boundp-method-function ((class slot-class) - generic-function - boundp-method-prototype - slot-name) - (declare (ignore generic-function boundp-method-prototype)) - (make-std-boundp-method-function slot-name)) - -(defmethod make-optimized-reader-method-function ((class standard-class) - generic-function - reader-method-prototype - slot-name) - (declare (ignore generic-function reader-method-prototype)) - (make-standard-instance-reader-method-function slot-name)) - -(defmethod make-optimized-writer-method-function ((class standard-class) - generic-function - writer-method-prototype - slot-name) - (declare (ignore generic-function writer-method-prototype)) - (make-standard-instance-writer-method-function slot-name)) - -(defmethod make-optimized-boundp-method-function ((class standard-class) - generic-function - boundp-method-prototype - slot-name) - (declare (ignore generic-function boundp-method-prototype)) - (make-standard-instance-boundp-method-function slot-name)) - - -(defun make-standard-instance-reader-method-function (slot-name) - (declare #.*optimize-speed*) - #'(lambda (instance) - (standard-instance-slot-value instance slot-name))) - -(defun make-standard-instance-writer-method-function (slot-name) - (declare #.*optimize-speed*) - #'(lambda (nv instance) - (setf (standard-instance-slot-value instance slot-name) nv))) - -(defun make-standard-instance-boundp-method-function (slot-name) - (declare #.*optimize-speed*) - #'(lambda (instance) - (standard-instance-slot-boundp instance slot-name))) - - - -(defvar *internal-reader-gf-table* (make-hash-table :test 'eql)) -(defvar *internal-writer-gf-table* (make-hash-table :test 'eql)) -(defvar *internal-boundp-gf-table* (make-hash-table :test 'eql)) - -(defun get-reader-function (slot-name) - (or (gethash slot-name *internal-reader-gf-table*) - (error "No class has a slot named ~s" slot-name))) - -(defun get-writer-function (slot-name) - (or (gethash slot-name *internal-writer-gf-table*) - (error "No class has a slot named ~s" slot-name))) - -(defun get-boundp-function (slot-name) - (or (gethash slot-name *internal-boundp-gf-table*) - (error "No class has a slot named ~s" slot-name))) - -(defun initialize-internal-slot-reader-gfs (slot-name) - (unless (gethash slot-name *internal-reader-gf-table*) - (let* ((name (slot-reader-symbol slot-name)) - (gf (setf (gethash slot-name *internal-reader-gf-table*) - (ensure-generic-function name)))) - (add-reader-method *the-class-slot-object* gf slot-name)))) - -(defun initialize-internal-slot-writer-gfs (slot-name) - (unless (gethash slot-name *internal-writer-gf-table*) - (let* ((name (slot-writer-symbol slot-name)) - (gf (setf (gethash slot-name *internal-writer-gf-table*) - (ensure-generic-function name)))) - (add-writer-method *the-class-slot-object* gf slot-name)))) - -(defun initialize-internal-slot-boundp-gfs (slot-name) - (unless (or (not *optimize-slot-boundp*) - (gethash slot-name *internal-boundp-gf-table*)) - (let* ((name (slot-boundp-symbol slot-name)) - (gf (setf (gethash slot-name *internal-boundp-gf-table*) - (ensure-generic-function name)))) - (add-boundp-method *the-class-slot-object* gf slot-name)))) +(defmethod make-writer-method-function ((class slot-class) slot-name) + (make-std-writer-method-function (class-name class) slot-name)) + +(defmethod make-boundp-method-function ((class slot-class) slot-name) + (make-std-boundp-method-function (class-name class) slot-name)) ;;;; inform-type-system-about-class @@ -1372,7 +987,6 @@ (defmethod inform-type-system-about-class ((class std-class) name) (inform-type-system-about-std-class name)) - ;;; ;;; These 4 definitions appear here for bootstrapping reasons. Logically, @@ -1430,18 +1044,15 @@ ;; means do what FLUSH does and then some. ;; (when (eq state 't) - (let ((nwrapper (make-wrapper class))) + (let ((nwrapper (make-wrapper (wrapper-no-of-instance-slots owrapper) + class))) (setf (wrapper-instance-slots-layout nwrapper) (wrapper-instance-slots-layout owrapper)) (setf (wrapper-class-slots nwrapper) (wrapper-class-slots owrapper)) - (setf (wrapper-allocate-static-slot-storage-copy nwrapper) - (wrapper-allocate-static-slot-storage-copy owrapper)) - (setf (wrapper-unreserved-field nwrapper) - (wrapper-unreserved-field owrapper)) - (without-interrupts-simple + (without-interrupts (setf (slot-value class 'wrapper) nwrapper) - (invalidate-wrapper owrapper 'flush nwrapper)) + (invalidate-wrapper owrapper ':flush nwrapper)) (update-constructors class))))) ;??? *** (defun flush-cache-trap (owrapper nwrapper instance) @@ -1456,22 +1067,17 @@ ;;; update-instance-for-redefined-class mechanism. ;;; (defmethod make-instances-obsolete ((class std-class)) - (let ((owrapper (class-wrapper class)) - (nwrapper (make-wrapper class))) + (let* ((owrapper (class-wrapper class)) + (nwrapper (make-wrapper (wrapper-no-of-instance-slots owrapper) + class))) (setf (wrapper-instance-slots-layout nwrapper) (wrapper-instance-slots-layout owrapper)) (setf (wrapper-class-slots nwrapper) (wrapper-class-slots owrapper)) - (setf (wrapper-allocate-static-slot-storage-copy nwrapper) - (wrapper-allocate-static-slot-storage-copy owrapper)) - (setf (wrapper-unreserved-field nwrapper) - (wrapper-unreserved-field owrapper)) - (without-interrupts-simple + (without-interrupts (setf (slot-value class 'wrapper) nwrapper) - (invalidate-wrapper owrapper 'obsolete nwrapper) - class) - (dolist (generic-function (class-cached-in-generic-functions class)) - (update-dfun generic-function)))) + (invalidate-wrapper owrapper ':obsolete nwrapper) + class))) (defmethod make-instances-obsolete ((class symbol)) (make-instances-obsolete (find-class class))) @@ -1508,11 +1114,7 @@ ;; -- --> local add ;; -- --> shared -- ;; - (unless (or (std-instance-p instance) (fsc-instance-p instance)) - (error "Trying to obsolete instance ~S of type ~S, but only know how - to obsolete instances of type STD-INSTANCE or FSC-INSTANCE." - instance (instance-type instance))) - (let* ((class (wrapper-class nwrapper)) + (let* ((class (wrapper-class* nwrapper)) (guts (allocate-instance class)) ;??? allocate-instance ??? (olayout (wrapper-instance-slots-layout owrapper)) (nlayout (wrapper-instance-slots-layout nwrapper)) @@ -1522,8 +1124,6 @@ (added ()) (discarded ()) (plist ())) - (declare (list olayout nlayout oclass-slots added discarded plist) - (simple-vector oslots nslots)) ;; ;; Go through all the old local slots. ;; @@ -1531,10 +1131,10 @@ (opos (interval :from 0))) (let ((npos (posq name nlayout))) (if npos - (setf (svref nslots npos) (svref oslots opos)) + (setf (instance-ref nslots npos) (instance-ref oslots opos)) (progn (push name discarded) - (unless (eq (svref oslots opos) *slot-unbound*) - (setf (getf plist name) (svref oslots opos))))))) + (unless (eq (instance-ref oslots opos) *slot-unbound*) + (setf (getf plist name) (instance-ref oslots opos))))))) ;; ;; Go through all the old shared slots. ;; @@ -1543,7 +1143,7 @@ (val (cdr oclass-slot-and-val))) (let ((npos (posq name nlayout))) (if npos - (setf (svref nslots npos) (cdr oclass-slot-and-val)) + (setf (instance-ref nslots npos) (cdr oclass-slot-and-val)) (progn (push name discarded) (unless (eq val *slot-unbound*) (setf (getf plist name) val))))))) @@ -1555,9 +1155,7 @@ (assq nlocal oclass-slots)) (push nlocal added))) - (without-interrupts-simple - (set-wrapper instance nwrapper) - (set-slots instance nslots)) + (swap-wrappers-and-slots instance guts) (update-instance-for-redefined-class instance added @@ -1570,19 +1168,29 @@ ;;; ;;; ;;; -(defmacro change-class-internal (wrapper-fetcher slots-fetcher alloc) - `(let* ((old-class (class-of instance)) - (copy (,alloc old-class)) - (guts (,alloc new-class)) - (new-wrapper (,wrapper-fetcher guts)) - (old-wrapper (class-wrapper old-class)) - (old-layout (wrapper-instance-slots-layout old-wrapper)) - (new-layout (wrapper-instance-slots-layout new-wrapper)) - (old-slots (,slots-fetcher instance)) - (new-slots (,slots-fetcher guts)) - (old-class-slots (wrapper-class-slots old-wrapper))) - (declare (list old-layout new-layout old-class-slots) - (simple-vector old-slots new-slots)) +(defmacro copy-instance-internal (instance) + `(#+new-kcl-wrapper if #-new-kcl-wrapper progn + #+new-kcl-wrapper (not (std-instance-p ,instance)) + (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) + #+new-kcl-wrapper + (copy-structure-header ,instance))) + +(defun change-class-internal (instance new-class) + (let* ((old-class (class-of instance)) + (copy (copy-instance-internal instance)) + (guts (allocate-instance new-class)) + (new-wrapper (get-wrapper guts)) + (old-wrapper (class-wrapper old-class)) + (old-layout (wrapper-instance-slots-layout old-wrapper)) + (new-layout (wrapper-instance-slots-layout new-wrapper)) + (old-slots (get-slots instance)) + (new-slots (get-slots guts)) + (old-class-slots (wrapper-class-slots old-wrapper))) ;; ;; "The values of local slots specified by both the class Cto and @@ -1593,8 +1201,8 @@ (new-position (interval :from 0))) (let ((old-position (posq new-slot old-layout))) (when old-position - (setf (svref new-slots new-position) - (svref old-slots old-position))))) + (setf (instance-ref new-slots new-position) + (instance-ref old-slots old-position))))) ;; ;; "The values of slots specified as shared in the class Cfrom and @@ -1603,15 +1211,11 @@ (iterate ((slot-and-val (list-elements old-class-slots))) (let ((position (posq (car slot-and-val) new-layout))) (when position - (setf (svref new-slots position) (cdr slot-and-val))))) + (setf (instance-ref new-slots position) (cdr slot-and-val))))) ;; Make the copy point to the old instance's storage, and make the ;; old instance point to the new storage. - (without-interrupts-simple - (setf (,slots-fetcher copy) old-slots) - - (setf (,wrapper-fetcher instance) new-wrapper) - (setf (,slots-fetcher instance) new-slots)) + (swap-wrappers-and-slots instance guts) (update-instance-for-different-class copy instance) instance)) @@ -1624,9 +1228,7 @@ instance new-class 'standard-class)) - (change-class-internal std-instance-wrapper - std-instance-slots - allocate-instance)) + (change-class-internal instance new-class)) (defmethod change-class ((instance standard-object) (new-class funcallable-standard-class)) @@ -1636,9 +1238,7 @@ instance new-class 'funcallable-standard-class)) - (change-class-internal fsc-instance-wrapper - fsc-instance-slots - allocate-instance)) + (change-class-internal instance new-class)) (defmethod change-class ((instance t) (new-class-name symbol)) (change-class instance (find-class new-class-name))) @@ -1660,6 +1260,11 @@ (declare (ignore slot-names initargs)) (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)) ()) +(defmethod class-direct-default-initargs ((class built-in-class)) ()) +(defmethod class-default-initargs ((class built-in-class)) ()) + (defmethod validate-superclass ((c class) (s built-in-class)) (eq s *the-class-t*)) @@ -1670,7 +1275,7 @@ ;;; (defmethod validate-superclass ((c slot-class) - (f forward-referenced-class)) + (f forward-referenced-class)) 't) @@ -1686,35 +1291,6 @@ (delete dependent (plist-value metaobject 'dependents)))) (defmethod map-dependents ((metaobject dependent-update-mixin) function) - (declare (type real-function function)) (dolist (dependent (plist-value metaobject 'dependents)) (funcall function dependent))) - -(declaim (ftype (function (T T) boolean) class-on-class-precedence-list-p)) -(defun class-on-class-precedence-list-p (class1 class2) - ;; Return whether class1 is on class2's class-precedence-list - ;; without finalizing it. - (if (class-finalized-p class2) - (not (null (memq class1 (fast-slot-value class2 'class-precedence-list)))) - (let ((direct-superclasses (class-direct-superclasses class2))) - (if (memq class1 direct-superclasses) - T - (dolist (superclass direct-superclasses NIL) - (if (class-on-class-precedence-list-p class1 superclass) - (return T))))))) - -(declaim (ftype (function (T) boolean) class-standard-p)) -(defun class-standard-p (class) - ;; Return whether class is standard without finalizing it. - (if (class-finalized-p class) - (not (null (memq *the-class-standard-object* - (fast-slot-value class 'class-precedence-list)))) - (let ((direct-superclasses (class-direct-superclasses class))) - (if (memq *the-class-standard-object* direct-superclasses) - T - (dolist (superclass direct-superclasses NIL) - (if (class-standard-p superclass) - (return T))))))) - - diff --git a/pcl/sys-package.lisp b/pcl/sys-package.lisp index 88249cf04..82af68aec 100644 --- a/pcl/sys-package.lisp +++ b/pcl/sys-package.lisp @@ -28,9 +28,9 @@ PCL::SLOT-DEFINITION-WRITERS PCL::CLASS-OF PCL::NO-APPLICABLE-METHOD PCL::STANDARD-WRITER-METHOD PCL::ENSURE-CLASS-USING-CLASS PCL::ENSURE-GENERIC-FUNCTION - PCL::FIND-METHOD-COMBINATION PCL::MAP-DEPENDENTS - PCL::SLOT-MISSING PCL::SPECIALIZER PCL::CALL-NEXT-METHOD - PCL::ENSURE-GENERIC-FUNCTION-USING-CLASS + PCL::FIND-METHOD-COMBINATION PCL::UPDATE-DEPENDENT + PCL::MAP-DEPENDENTS PCL::SLOT-MISSING PCL::SPECIALIZER + PCL::CALL-NEXT-METHOD PCL::ENSURE-GENERIC-FUNCTION-USING-CLASS PCL::SLOT-MAKUNBOUND-USING-CLASS PCL::MAKE-INSTANCES-OBSOLETE PCL::INTERN-EQL-SPECIALIZER PCL::REMOVE-DIRECT-SUBCLASS PCL::METHOD-GENERIC-FUNCTION PCL::METHOD-QUALIFIERS @@ -41,7 +41,7 @@ PCL::METHOD-LAMBDA-LIST PCL::DEFGENERIC PCL::REMOVE-DIRECT-METHOD PCL::STANDARD-DIRECT-SLOT-DEFINITION PCL::GENERIC-FUNCTION-METHODS PCL::VALIDATE-SUPERCLASS - PCL::REINITIALIZE-INSTANCE PCL::SLOT-EXISTS-P-USING-CLASS + PCL::REINITIALIZE-INSTANCE PCL::STANDARD-METHOD PCL::STANDARD-ACCESSOR-METHOD PCL::FUNCALLABLE-STANDARD-INSTANCE PCL::FUNCTION-KEYWORDS PCL::STANDARD PCL::FIND-METHOD PCL::EXTRACT-SPECIALIZER-NAMES @@ -88,9 +88,9 @@ PCL::REMOVE-METHOD PCL::READER-METHOD-CLASS PCL::CALL-METHOD PCL::CLASS-PROTOTYPE PCL::CLASS-NAME PCL::FIND-CLASS PCL::DEFCLASS PCL::COMPUTE-APPLICABLE-METHODS - PCL::DESCRIBE-OBJECT PCL::SLOT-VALUE-USING-CLASS - PCL::METHOD-COMBINATION PCL::EQL-SPECIALIZER-INSTANCE - PCL::GENERIC-LABELS PCL::METHOD PCL::SLOT-DEFINITION-READERS + PCL::SLOT-VALUE-USING-CLASS PCL::METHOD-COMBINATION + PCL::EQL-SPECIALIZER-INSTANCE PCL::GENERIC-LABELS PCL::METHOD + PCL::SLOT-DEFINITION-READERS PCL::CLASS-DIRECT-DEFAULT-INITARGS PCL::CLASS-DIRECT-SUBCLASSES PCL::CLASS-DIRECT-SUPERCLASSES PCL::SET-FUNCALLABLE-INSTANCE-FUNCTION)) @@ -115,7 +115,7 @@ WALKER::NESTED-WALK-FORM WALKER::VARIABLE-DECLARATION WALKER::WALK-FORM-EXPAND-MACROS-P WALKER::VARIABLE-LEXICAL-P WALKER::VARIABLE-SPECIAL-P WALKER::WALK-FORM - WALKER::VARIABLE-GLOBALLY-SPECIAL-P)) + WALKER::MACROEXPAND-ALL WALKER::VARIABLE-GLOBALLY-SPECIAL-P)) ;;; Definitions for package SLOT-ACCESSOR-NAME of type SHADOW (LISP::IN-PACKAGE "SLOT-ACCESSOR-NAME") @@ -127,7 +127,8 @@ (LISP::IN-PACKAGE "PCL") (LISP::SHADOW '(PCL::DOTIMES PCL::DOCUMENTATION)) (LISP::SHADOWING-IMPORT 'LISP::NIL) -(LISP::IMPORT '(SYSTEM::STRUCTUREP)) +(LISP::IMPORT + '(SYSTEM::STRUCTURE-REF SYSTEM::STRUCTURE-DEF SYSTEM::STRUCTUREP)) ;;; Definitions for package ITERATE of type SHADOW (LISP::IN-PACKAGE "ITERATE") diff --git a/pcl/sys-proclaim.lisp b/pcl/sys-proclaim.lisp index 3e8bef09d..97d2f9f0c 100644 --- a/pcl/sys-proclaim.lisp +++ b/pcl/sys-proclaim.lisp @@ -1,1162 +1,1050 @@ -(IN-PACKAGE "PCL") +(IN-PACKAGE "USER") +(PROCLAIM '(FTYPE (FUNCTION (*) FIXNUM) PCL::ZERO)) (PROCLAIM - '(FTYPE (FUNCTION (FIXNUM T FIXNUM) FIXNUM) - COMPUTE-PRIMARY-CACHE-LOCATION-FROM-LOCATION)) + '(FTYPE (FUNCTION (T FIXNUM *) FIXNUM) + PCL::COMPUTE-PRIMARY-CACHE-LOCATION-FROM-LOCATION)) (PROCLAIM - '(FTYPE (FUNCTION (T) FIXNUM) ARG-INFO-NUMBER-REQUIRED - COUNT-NON-NILS CHECKING-LIMIT-FN CACHE-COUNT - N-N-ACCESSORS-LIMIT-FN ARG-INFO-NKEYS CACHING-LIMIT-FN - WRAPPER-FIELD ONE-INDEX-LIMIT-FN CPD-COUNT)) + '(FTYPE (FUNCTION (T) FUNCTION) PCL::CACHE-LIMIT-FN + PCL::METHOD-CALL-FUNCTION PCL::FAST-METHOD-CALL-FUNCTION)) (PROCLAIM - '(FTYPE (FUNCTION (FIXNUM) T) NEXT-WRAPPER-FIELD DFUN-ARG-SYMBOL - SLOT-VECTOR-SYMBOL ALLOCATE-CACHE-VECTOR)) -(PROCLAIM '(FTYPE (FUNCTION (T) FIELD-TYPE) CACHE-FIELD)) + '(FTYPE (FUNCTION (T) FIXNUM) PCL::DEFAULT-LIMIT-FN + PCL::PV-CACHE-LIMIT-FN PCL::CACHE-COUNT + PCL::ARG-INFO-NUMBER-REQUIRED PCL::ONE-INDEX-LIMIT-FN + PCL::N-N-ACCESSORS-LIMIT-FN PCL::CHECKING-LIMIT-FN + PCL::CACHING-LIMIT-FN PCL::CACHE-NLINES + PCL::CACHE-MAX-LOCATION PCL::CACHE-SIZE PCL::CACHE-MASK + PCL::PV-TABLE-PV-SIZE PCL::FAST-INSTANCE-BOUNDP-INDEX + PCL::EARLY-CLASS-SIZE)) +(PROCLAIM '(FTYPE (FUNCTION (T) PCL::FIELD-TYPE) PCL::CACHE-FIELD)) +(PROCLAIM '(FTYPE (FUNCTION (FIXNUM) T) PCL::POWER-OF-TWO-CEILING)) (PROCLAIM - '(FTYPE (FUNCTION (T) LIST) INTERNAL-SLOTD-INITARGS CACHE-OVERFLOW)) -(PROCLAIM '(FTYPE (FUNCTION (T) REAL-FUNCTION) CACHE-LIMIT-FN)) -(PROCLAIM '(FTYPE (FUNCTION (T) SIMPLE-VECTOR) CACHE-VECTOR)) -(PROCLAIM '(FTYPE (FUNCTION (T) SYMBOL) INTERNAL-SLOTD-NAME)) + '(FTYPE (FUNCTION (T) LIST) PCL::CACHE-OVERFLOW + PCL::PV-TABLE-SLOT-NAME-LISTS PCL::PV-TABLE-CALL-LIST)) +(PROCLAIM '(FTYPE (FUNCTION (T) (MEMBER NIL T)) PCL::CACHE-VALUEP)) +(PROCLAIM '(FTYPE (FUNCTION (T) SIMPLE-VECTOR) PCL::CACHE-VECTOR)) (PROCLAIM - '(FTYPE (FUNCTION (T) (VALUES T T)) MAKE-CLASS-PREDICATE-NAME - MAKE-KEYWORD LAP-REG GET-METHOD-FROM-IDENTIFIER - METHOD-FUNCTION-PLIST DEFSTRUCT-FORM)) -(PROCLAIM - '(FTYPE (FUNCTION (FIXNUM T) T) MAKE-CAXR MAKE-CDXR - %CCLOSURE-ENV-NTHCDR)) + '(FTYPE (FUNCTION (T) (VALUES T T)) PCL::MAKE-CLASS-PREDICATE-NAME + PCL::MAKE-KEYWORD)) +(PROCLAIM '(FTYPE (FUNCTION (FIXNUM T) T) PCL::%CCLOSURE-ENV-NTHCDR)) (PROCLAIM '(FTYPE (FUNCTION (FIXNUM FIXNUM T) FIXNUM) - COMPUTE-PRIMARY-CACHE-LOCATION)) -(PROCLAIM - '(FTYPE (FUNCTION (FIXNUM) FIXNUM) COMPUTE-LINE-SIZE - POWER-OF-TWO-CEILING DEFAULT-LIMIT-FN)) + PCL::COMPUTE-PRIMARY-CACHE-LOCATION)) +(PROCLAIM '(FTYPE (FUNCTION (T) (INTEGER 1 512)) PCL::CACHE-LINE-SIZE)) +(PROCLAIM '(FTYPE (FUNCTION (T) (INTEGER 1 256)) PCL::CACHE-NKEYS)) (PROCLAIM - '(FTYPE (FUNCTION (T) INDEX) CACHE-NLINES CACHE-MASK - CACHE-MAX-LOCATION CACHE-SIZE)) -(PROCLAIM '(FTYPE (FUNCTION (T) (INTEGER 1 512)) CACHE-LINE-SIZE)) -(PROCLAIM '(FTYPE (FUNCTION (T) (INTEGER 1 256)) CACHE-NKEYS)) + '(FTYPE (FUNCTION (T) (OR PCL::CACHE NULL)) PCL::PV-TABLE-CACHE)) (PROCLAIM - '(FTYPE (FUNCTION (T) (OR INDEX NULL)) ARG-INFO-NUMBER-OPTIONAL)) + '(FTYPE (FUNCTION (T T T) *) PCL::OPTIMIZE-SLOT-VALUE-BY-CLASS-P + PCL::ACCESSOR-VALUES1 WALKER::WALK-LET-IF + PCL::EMIT-READER/WRITER + PCL::EMIT-ONE-OR-N-INDEX-READER/WRITER PCL::GENERATING-LISP + PCL::SET-SLOT-VALUE PCL::EMIT-READER/WRITER-FUNCTION + PCL::EMIT-ONE-OR-N-INDEX-READER/WRITER-FUNCTION + PCL::ACCESSOR-VALUES-INTERNAL PCL::CONVERT-METHODS + PCL::|(FAST-METHOD COMPUTE-DISCRIMINATING-FUNCTION-ARGLIST-INFO + (STANDARD-GENERIC-FUNCTION))| PCL::SLOT-VALUE-USING-CLASS-DFUN + PCL::SLOT-BOUNDP-USING-CLASS-DFUN PCL::LOAD-LONG-DEFCOMBIN + PCL::CACHE-MISS-VALUES + PCL::|(FAST-METHOD METHOD-FUNCTION (STANDARD-METHOD))| + PCL::|(FAST-METHOD COMPUTE-DISCRIMINATING-FUNCTION + (STANDARD-GENERIC-FUNCTION))| + PCL::|(FAST-METHOD FUNCTION-KEYWORDS (STANDARD-METHOD))| + PCL::|(FAST-METHOD METHOD-PRETTY-ARGLIST (STANDARD-METHOD))| + PCL::GET-CLASS-SLOT-VALUE-1 ITERATE::EXPAND-INTO-LET + WALKER::WALK-FORM-INTERNAL ITERATE::RENAME-VARIABLES + PCL::ACCESSOR-VALUES ITERATE::WALK-GATHERING-BODY + PCL::MAKE-OPTIMIZED-STD-READER-METHOD-FUNCTION + PCL::MAKE-OPTIMIZED-STD-WRITER-METHOD-FUNCTION + PCL::MAKE-OPTIMIZED-STD-BOUNDP-METHOD-FUNCTION + PCL::CONSTANT-VALUE-MISS PCL::CACHING-MISS + PCL::CHECKING-MISS + PCL::GET-OPTIMIZED-STD-ACCESSOR-METHOD-FUNCTION + PCL::GET-OPTIMIZED-STD-SLOT-VALUE-USING-CLASS-METHOD-FUNCTION + PCL::|(FAST-METHOD CLASS-PROTOTYPE (STD-CLASS))| + PCL::|(FAST-METHOD CLASS-PROTOTYPE (STRUCTURE-CLASS))| + PCL::|(FAST-METHOD METHOD-LAMBDA-LIST (TRACED-METHOD))| + PCL::|(FAST-METHOD METHOD-SPECIALIZERS (TRACED-METHOD))| + PCL::|(FAST-METHOD METHOD-QUALIFIERS (TRACED-METHOD))| + PCL::|(FAST-METHOD ACCESSOR-METHOD-SLOT-NAME (TRACED-METHOD))| + PCL::MAKE-FINAL-N-N-ACCESSOR-DFUN + PCL::MAKE-FINAL-CACHING-DFUN + PCL::MAKE-FINAL-CONSTANT-VALUE-DFUN + PCL::|(FAST-METHOD MAKE-INSTANCES-OBSOLETE (SYMBOL))|)) (PROCLAIM - '(FTYPE (FUNCTION (T) (OR FUNCTION NULL)) - INTERNAL-SLOTD-INITFUNCTION)) + '(FTYPE (FUNCTION (T T T T) *) PCL::REAL-MAKE-METHOD-LAMBDA + PCL::|(FAST-METHOD CHANGE-CLASS (T SYMBOL))| + PCL::GET-ACCESSOR-METHOD-FUNCTION + PCL::EMIT-CHECKING-OR-CACHING + PCL::|(FAST-METHOD REINITIALIZE-INSTANCE :AFTER (SLOT-CLASS))| + PCL::BOOTSTRAP-ACCESSOR-DEFINITION + PCL::EMIT-CHECKING-OR-CACHING-FUNCTION + PCL::|(FAST-METHOD NO-APPLICABLE-METHOD (T))| + PCL::|(FAST-METHOD SLOT-ACCESSOR-FUNCTION (EFFECTIVE-SLOT-DEFINITION T))| + PCL::|(FAST-METHOD COMPUTE-EFFECTIVE-SLOT-DEFINITION (SLOT-CLASS T))| + PCL::|(FAST-METHOD LEGAL-QUALIFIERS-P (STANDARD-METHOD T))| + PCL::|(FAST-METHOD LEGAL-SPECIALIZERS-P (STANDARD-METHOD T))| + PCL::SETF-SLOT-VALUE-USING-CLASS-DFUN + PCL::LOAD-SHORT-DEFCOMBIN + PCL::|(FAST-METHOD COMPUTE-APPLICABLE-METHODS-USING-CLASSES + (GENERIC-FUNCTION T))| PCL::SET-CLASS-SLOT-VALUE-1 + PCL::MAKE-SHARED-INITIALIZE-FORM-LIST + PCL::|(FAST-METHOD CLASS-SLOT-VALUE (STD-CLASS T))| + PCL::GENERATE-DISCRIMINATION-NET PCL::ORDER-SPECIALIZERS + PCL::MAKE-ONE-CLASS-ACCESSOR-DFUN PCL::ACCESSOR-MISS + PCL::|(FAST-METHOD ALLOCATE-INSTANCE (STRUCTURE-CLASS))| + PCL::GET-ACCESSOR-FROM-SVUC-METHOD-FUNCTION + PCL::|(FAST-METHOD DESCRIBE-OBJECT (T T))| + PCL::|(FAST-METHOD DOCUMENTATION (STANDARD-SLOT-DEFINITION))| + PCL::|(FAST-METHOD DESCRIBE-OBJECT (SLOT-OBJECT T))| + PCL::|(FAST-METHOD SLOTS-TO-INSPECT (SLOT-CLASS SLOT-OBJECT))| + PCL::|(FAST-METHOD DESCRIBE-OBJECT (STANDARD-GENERIC-FUNCTION T))| + PCL::|(FAST-METHOD DESCRIBE-OBJECT (CLASS T))| + PCL::|(FAST-METHOD MAKE-INSTANCE (SYMBOL))| + PCL::|(FAST-METHOD DEFAULT-INITARGS (SLOT-CLASS T))| + PCL::|(FAST-METHOD INITIALIZE-INSTANCE (SLOT-OBJECT))| + PCL::|(FAST-METHOD MAYBE-UPDATE-CONSTRUCTORS (GENERIC-FUNCTION METHOD))| + PCL::MAKE-FINAL-ONE-INDEX-ACCESSOR-DFUN + PCL::MAKE-FINAL-CHECKING-DFUN)) (PROCLAIM - '(FTYPE (FUNCTION (T T *) *) GET-EFFECTIVE-METHOD-FUNCTION - SLOT-VALUE-OR-DEFAULT COMPUTE-SECONDARY-DISPATCH-FUNCTION - MAKE-DOCUMENTED-STANDARD-METHOD-LAMBDA MAKE-ACCESSOR-TABLE - LOAD-DEFGENERIC MAKE-EFFECTIVE-METHOD-FUNCTION - MAKE-CHECKING-DFUN MAKE-N-N-ACCESSOR-DFUN - TYPES-FROM-ARGUMENTS NESTED-WALK-FORM)) + '(FTYPE (FUNCTION (T T T T T) *) + PCL::|(FAST-METHOD SHARED-INITIALIZE :AFTER (CLASS-EQ-SPECIALIZER T))| + PCL::|(FAST-METHOD SHARED-INITIALIZE :AFTER (EQL-SPECIALIZER T))| + PCL::|(FAST-METHOD SHARED-INITIALIZE :BEFORE (CLASS T))| + PCL::ADD-METHOD-DECLARATIONS PCL::WALK-METHOD-LAMBDA + PCL::|(FAST-METHOD (SETF SLOT-ACCESSOR-FUNCTION) + (T EFFECTIVE-SLOT-DEFINITION T))| + PCL::|(FAST-METHOD SHARED-INITIALIZE :BEFORE (STANDARD-METHOD T))| + PCL::|(FAST-METHOD SHARED-INITIALIZE :AFTER (STANDARD-ACCESSOR-METHOD T))| + PCL::|(FAST-METHOD SHARED-INITIALIZE :BEFORE (STANDARD-GENERIC-FUNCTION T))| + PCL::COMPUTE-DISCRIMINATING-FUNCTION-ARGLIST-INFO-INTERNAL + PCL::|(FAST-METHOD SHARED-INITIALIZE :AFTER (STANDARD-SLOT-DEFINITION T))| + PCL::|(FAST-METHOD (SETF CLASS-SLOT-VALUE) (T STD-CLASS T))| + PCL::|(FAST-METHOD SLOT-VALUE-USING-CLASS + (STD-CLASS STANDARD-OBJECT STANDARD-EFFECTIVE-SLOT-DEFINITION))| + PCL::MAKE-TWO-CLASS-ACCESSOR-DFUN + PCL::|(FAST-METHOD SLOT-VALUE-USING-CLASS + (STRUCTURE-CLASS STRUCTURE-OBJECT + STRUCTURE-EFFECTIVE-SLOT-DEFINITION))| + PCL::|(FAST-METHOD COMPUTE-EFFECTIVE-METHOD + (GENERIC-FUNCTION LONG-METHOD-COMBINATION T))| + PCL::|(FAST-METHOD (SETF DOCUMENTATION) (T STANDARD-SLOT-DEFINITION))| + PCL::|(FAST-METHOD ADD-READER-METHOD (SLOT-CLASS T T))| + PCL::|(FAST-METHOD ADD-WRITER-METHOD (SLOT-CLASS T T))| + PCL::|(FAST-METHOD ADD-BOUNDP-METHOD (SLOT-CLASS T T))| + PCL::|(FAST-METHOD UPDATE-INSTANCE-FOR-DIFFERENT-CLASS + (STANDARD-OBJECT STANDARD-OBJECT))| + PCL::|(FAST-METHOD SHARED-INITIALIZE (SLOT-OBJECT T))|)) (PROCLAIM - '(FTYPE (FUNCTION (T T T) *) ITERATE::EXPAND-INTO-LET - CONSTANT-VALUE-MISS MAKE-FINAL-N-N-ACCESSOR-DFUN - MAKE-FINAL-CACHING-DFUN LOAD-LONG-DEFCOMBIN - ITERATE::RENAME-VARIABLES - GET-OPTIMIZED-STD-ACCESSOR-METHOD-FUNCTION - GET-OPTIMIZED-STD-READER-METHOD-FUNCTION - MAKE-OPTIMIZED-STD-WRITER-METHOD-FUNCTION - GET-OPTIMIZED-STD-WRITER-METHOD-FUNCTION - GET-OPTIMIZED-STD-BOUNDP-METHOD-FUNCTION SET-SLOT-VALUE - MAKE-OPTIMIZED-STD-READER-METHOD-FUNCTION - MAKE-OPTIMIZED-STD-BOUNDP-METHOD-FUNCTION - SLOT-VALUE-USING-CLASS-DFUN CONVERT-METHODS - WALKER::WALK-FORM-INTERNAL - GENERATE-DISCRIMINATION-NET-INTERNAL-DO-COLUMN - NET-CODE-CONVERTER CACHE-MISS-VALUES - ITERATE::WALK-GATHERING-BODY SLOT-BOUNDP-USING-CLASS-DFUN - CHECKING-MISS ACCESSOR-VALUES WALKER::WALK-LET-IF - MAKE-FINAL-CONSTANT-VALUE-DFUN CACHING-MISS)) + '(FTYPE (FUNCTION (T T *) *) PCL::TYPES-FROM-ARGUMENTS + PCL::MAKE-ACCESSOR-TABLE + PCL::COMPUTE-SECONDARY-DISPATCH-FUNCTION + PCL::GET-SIMPLE-INITIALIZATION-FUNCTION + PCL::GET-COMPLEX-INITIALIZATION-FUNCTIONS + PCL::MAKE-CHECKING-DFUN + PCL::MAKE-DEFAULT-INITARGS-FORM-LIST + PCL::SLOT-VALUE-OR-DEFAULT PCL::MAKE-N-N-ACCESSOR-DFUN + PCL::GET-EFFECTIVE-METHOD-FUNCTION PCL::LOAD-DEFGENERIC + PCL::MAKE-EFFECTIVE-METHOD-FUNCTION + WALKER:NESTED-WALK-FORM)) (PROCLAIM '(FTYPE (FUNCTION (T T T T T T T) *) - ITERATE::ITERATE-TRANSFORM-BODY EXPAND-DEFMETHOD-INTERNAL - MAKE-LAP-CLOSURE-GENERATOR)) + ITERATE::ITERATE-TRANSFORM-BODY + PCL::|(FAST-METHOD UPDATE-INSTANCE-FOR-REDEFINED-CLASS + (STANDARD-OBJECT T T T))|)) (PROCLAIM - '(FTYPE (FUNCTION (T T T T) *) SIMPLE-SLOTS-GENERATOR-INTERNAL - ORDER-SPECIALIZERS MAKE-ONE-CLASS-ACCESSOR-DFUN - GET-ACCESSOR-METHOD-FUNCTION LOAD-SHORT-DEFCOMBIN - GENERATE-DISCRIMINATION-NET MAKE-FINAL-CHECKING-DFUN - FINALIZE-LAP-GENERATION EARLY-MAKE-METHOD-LAMBDA - MAKE-METHOD-LAMBDA-AND-OPTIMIZED-LAMBDA - NO-METHODS-GENERATOR-INTERNAL - SETF-SLOT-VALUE-USING-CLASS-DFUN - MAKE-OPTIMIZED-STANDARD-METHOD-LAMBDA - MAKE-FINAL-ONE-INDEX-ACCESSOR-DFUN ACCESSOR-MISS - MAKE-ACCESSOR-FROM-SVUC-METHOD-FUNCTION)) + '(FTYPE (FUNCTION (T T T T T T *) *) PCL::REAL-MAKE-A-METHOD)) (PROCLAIM - '(FTYPE (FUNCTION (T T T T T) *) - COMPUTE-DISCRIMINATING-FUNCTION-ARGLIST-INFO-INTERNAL - MAKE-TWO-CLASS-ACCESSOR-DFUN - GENERATE-DISCRIMINATION-NET-INTERNAL-DO-METHODS)) -(PROCLAIM - '(FTYPE (FUNCTION (T T T *) *) WALKER::WALK-DECLARATIONS - GET-SECONDARY-DISPATCH-FUNCTION - MAKE-ONE-INDEX-ACCESSOR-DFUN)) + '(FTYPE (FUNCTION (T T T T T T) *) PCL::REAL-LOAD-DEFCLASS + PCL::CACHE-MISS-VALUES-INTERNAL + PCL::GENERATE-DISCRIMINATION-NET-INTERNAL + PCL::|(FAST-METHOD (SETF SLOT-VALUE-USING-CLASS) + (T STRUCTURE-CLASS STRUCTURE-OBJECT + STRUCTURE-EFFECTIVE-SLOT-DEFINITION))| + PCL::MAKE-LONG-METHOD-COMBINATION-FUNCTION + PCL::DO-SHORT-METHOD-COMBINATION PCL::MEMF-CODE-CONVERTER)) (PROCLAIM '(FTYPE (FUNCTION (T T T T *) *) ITERATE::RENAME-LET-BINDINGS - NO-SLOT-ACCESSOR)) + PCL::MAKE-EFFECTIVE-METHOD-FUNCTION-SIMPLE1)) (PROCLAIM - '(FTYPE (FUNCTION (T T T T T T) *) - GENERATE-DISCRIMINATION-NET-INTERNAL - MAKE-LONG-METHOD-COMBINATION-FUNCTION - GENERAL-GENERATOR-INTERNAL)) -(PROCLAIM - '(FTYPE (FUNCTION (T T T T T T T T) *) - BOOTSTRAP-INITIALIZE-STRUCTURE-CLASS)) -(PROCLAIM - '(FTYPE (FUNCTION (T T T T T T T T T T) *) - BOOTSTRAP-INITIALIZE-BUILT-IN-CLASS)) -(PROCLAIM - '(FTYPE (FUNCTION (T) BOOLEAN) CACHE-VALUEP - GF-PRECOMPUTE-DFUN-AND-EMF-P GF-INFO-C-A-M-EMF-STD-P - ARG-INFO-KEY/REST-P)) -(PROCLAIM - '(FTYPE (FUNCTION (T) COMPILED-FUNCTION) - INTERNAL-SLOTD-READER-FUNCTION - INTERNAL-SLOTD-WRITER-FUNCTION - INTERNAL-SLOTD-BOUNDP-FUNCTION)) -(PROCLAIM '(FTYPE (FUNCTION (T STREAM T) T) PRINT-DFUN-INFO)) + '(FTYPE (FUNCTION (T T T *) *) WALKER::WALK-DECLARATIONS + PCL::MAKE-ONE-INDEX-ACCESSOR-DFUN + PCL::GET-SECONDARY-DISPATCH-FUNCTION)) +(PROCLAIM '(FTYPE (FUNCTION (T STREAM T) T) PCL::PRINT-DFUN-INFO)) (PROCLAIM - '(FTYPE (FUNCTION (T T *) T) EMIT-GET-CLASS-SLOT - EMIT-SET-CLASS-SLOT DEFOPCODE-1 CPL-ERROR + '(FTYPE (FUNCTION (T T *) T) PCL::CPL-ERROR + PCL::METHOD-FUNCTION-GET + PCL:ENSURE-GENERIC-FUNCTION-USING-CLASS + PCL::GET-CACHE-FROM-CACHE PCL::EMIT-MISS + PCL::GET-METHOD-FUNCTION-PV-CELL + PCL::NAMED-OBJECT-PRINT-FUNCTION PCL::RECORD-DEFINITION WALKER::CONVERT-MACRO-TO-LAMBDA - ENSURE-GENERIC-FUNCTION-USING-CLASS PROCLAIM-FUNCTION - RECORD-DEFINITION DEFOPERAND-1 PROBE-CACHE - REAL-ENSURE-GF-USING-CLASS--GENERIC-FUNCTION - REAL-ENSURE-GF-USING-CLASS--NULL MAP-CACHE - FIND-CLASS-PREDICATE-FROM-CELL NAMED-OBJECT-PRINT-FUNCTION - GET-EFFECTIVE-METHOD-FUNCTION1 PLIST-VALUE)) + PCL::PRECOMPUTE-EFFECTIVE-METHODS + PCL::COMPUTE-SECONDARY-DISPATCH-FUNCTION1 PCL::PROBE-CACHE + PCL::MAP-CACHE PCL::INITIALIZE-INFO + PCL::GET-EFFECTIVE-METHOD-FUNCTION1 + PCL::MAKE-EFFECTIVE-METHOD-FUNCTION-SIMPLE + PCL::MAKE-EMF-FROM-METHOD + PCL::EXPAND-EFFECTIVE-METHOD-FUNCTION + PCL::FIND-CLASS-FROM-CELL PCL::REAL-ADD-METHOD + PCL::FIND-CLASS-PREDICATE-FROM-CELL PCL::GET-DECLARATION + PCL::REAL-ENSURE-GF-USING-CLASS--GENERIC-FUNCTION + PCL::REAL-ENSURE-GF-USING-CLASS--NULL)) (PROCLAIM - '(FTYPE (FUNCTION (T T T T T T T T *) T) EARLY-MAKE-A-METHOD - REAL-MAKE-A-METHOD EARLY-ADD-NAMED-METHOD - REAL-ADD-NAMED-METHOD)) -(PROCLAIM '(FTYPE (FUNCTION (T T T FIXNUM) T) FILL-CACHE-FROM-CACHE-P)) -(PROCLAIM - '(FTYPE (FUNCTION (T T T T T T T T T T T T T T) T) - ADD-LEXICAL-FUNCTIONS-TO-OPTIMIZED-STANDARD-METHOD-LAMBDA)) -(PROCLAIM '(FTYPE (FUNCTION (T T T T T T *) T) EMIT-DLAP)) + '(FTYPE (FUNCTION (T T T) T) PCL::GET-NEW-FUNCTION-GENERATOR + PCL::|(FAST-METHOD SPECIALIZER-METHOD-TABLE (EQL-SPECIALIZER))| + PCL::|(FAST-METHOD SPECIALIZER-METHOD-TABLE (CLASS-EQ-SPECIALIZER))| + WALKER::WALK-TAGBODY-1 PCL::NOTE-PV-TABLE-REFERENCE + WALKER::WALK-LAMBDA + PCL::|(FAST-METHOD SPECIALIZER-DIRECT-METHODS (SPECIALIZER-WITH-OBJECT))| + PCL::|(FAST-METHOD SPECIALIZER-DIRECT-GENERIC-FUNCTIONS + (SPECIALIZER-WITH-OBJECT))| WALKER::WALK-COMPILER-LET + PCL::|(FAST-METHOD CLASS-DIRECT-SLOTS (BUILT-IN-CLASS))| + WALKER::WALK-UNEXPECTED-DECLARE WALKER::WALK-FLET + PCL::|(FAST-METHOD CLASS-SLOTS (BUILT-IN-CLASS))| + WALKER::WALK-IF WALKER::WALK-LABELS WALKER::WALK-LET + PCL::|(FAST-METHOD CLASS-DIRECT-DEFAULT-INITARGS (BUILT-IN-CLASS))| + PCL::FLUSH-CACHE-TRAP WALKER::WALK-LET* + PCL::OBSOLETE-INSTANCE-TRAP WALKER::WALK-MACROLET + WALKER::WALK-MULTIPLE-VALUE-SETQ + PCL::|(FAST-METHOD CLASS-DEFAULT-INITARGS (BUILT-IN-CLASS))| + WALKER::WALK-MULTIPLE-VALUE-BIND WALKER::WALK-SETQ + WALKER::WALK-SYMBOL-MACROLET WALKER::WALK-TAGBODY + WALKER::WALK-DO WALKER::WALK-DO* WALKER::WALK-PROG + WALKER::WALK-PROG* WALKER::WALK-NAMED-LAMBDA + PCL::OPTIMIZE-GF-CALL-INTERNAL PCL::SKIP-FAST-SLOT-ACCESS-P + PCL::SKIP-OPTIMIZE-SLOT-VALUE-BY-CLASS-P + PCL::EXPAND-DEFGENERIC + PCL::|(FAST-METHOD RAW-INSTANCE-ALLOCATOR (FUNCALLABLE-STANDARD-CLASS))| + PCL::EMIT-SLOT-READ-FORM PCL::EMIT-BOUNDP-CHECK + PCL::FIX-SLOT-ACCESSORS + PCL::MAKE-METHOD-INITARGS-FORM-INTERNAL + PCL::|(FAST-METHOD FINALIZE-INHERITANCE (STRUCTURE-CLASS))| + PCL::EMIT-GREATER-THAN-1-DLAP + PCL::|(FAST-METHOD FINALIZE-INHERITANCE (STD-CLASS))| + PCL::EMIT-1-T-DLAP + PCL::|(FAST-METHOD COMPUTE-DEFAULT-INITARGS (SLOT-CLASS))| + PCL::|(FAST-METHOD WRAPPER-FETCHER (FUNCALLABLE-STANDARD-CLASS))| + PCL::|(FAST-METHOD COMPUTE-SLOTS (STD-CLASS))| + PCL::|(FAST-METHOD COMPUTE-SLOTS :AROUND (STD-CLASS))| + PCL::|(FAST-METHOD COMPUTE-SLOTS (STRUCTURE-CLASS))| + PCL::|(FAST-METHOD COMPUTE-SLOTS :AROUND (STRUCTURE-CLASS))| + PCL::|(FAST-METHOD SLOTS-FETCHER (FUNCALLABLE-STANDARD-CLASS))| + PCL::MAKE-METHOD-SPEC + PCL::NEW-ARG-INFO-FROM-GENERIC-FUNCTION PCL::PRINT-CACHE + PCL::SET-FUNCTION-NAME-1 + PCL::|(FAST-METHOD METHOD-QUALIFIERS (STANDARD-METHOD))| + PCL::|SETF PCL METHOD-FUNCTION-GET| PCL::INVALIDATE-WRAPPER + PCL::PRINT-STD-INSTANCE PCL::|SETF PCL PLIST-VALUE| + PCL::TRACE-METHOD-INTERNAL PCL::ONE-INDEX-DFUN-INFO + PCL::|(FAST-METHOD GENERIC-FUNCTION-LAMBDA-LIST (GENERIC-FUNCTION))| + PCL::|(FAST-METHOD GF-FAST-METHOD-FUNCTION-P (STANDARD-GENERIC-FUNCTION))| + PCL::CONVERT-TABLE + PCL::|(FAST-METHOD SPECIALIZER-CLASS (CLASS))| + PCL::DECLARE-STRUCTURE PCL::LOAD-PRECOMPILED-IIS-ENTRY + PCL::|(FAST-METHOD SPECIALIZER-CLASS (EQL-SPECIALIZER))| + WALKER::WITH-AUGMENTED-ENVIRONMENT-INTERNAL + PCL::ONE-CLASS-DFUN-INFO + PCL::|(FAST-METHOD ACCESSOR-METHOD-CLASS (STANDARD-ACCESSOR-METHOD))| + PCL::|(FAST-METHOD ACCESSOR-METHOD-CLASS (STANDARD-WRITER-METHOD))| + PCL::|(FAST-METHOD GENERIC-FUNCTION-PRETTY-ARGLIST + (STANDARD-GENERIC-FUNCTION))| ITERATE::OPTIMIZE-ITERATE-FORM + PCL::|(FAST-METHOD COMPUTE-CLASS-PRECEDENCE-LIST (SLOT-CLASS))| + PCL::MAKE-DFUN-CALL + PCL::|(FAST-METHOD WRAPPER-FETCHER (STANDARD-CLASS))| + PCL::|(FAST-METHOD SLOTS-FETCHER (STANDARD-CLASS))| + PCL::|(FAST-METHOD RAW-INSTANCE-ALLOCATOR (STANDARD-CLASS))| + PCL::COMPUTE-PRECEDENCE PCL::FIRST-FORM-TO-LISP + ITERATE::OPTIMIZE-GATHERING-FORM WALKER::RECONS + ITERATE::SIMPLE-EXPAND-GATHERING-FORM + ITERATE::RENAME-AND-CAPTURE-VARIABLES + PCL::MAKE-TOP-LEVEL-FORM WALKER::RELIST-INTERNAL + ITERATE::VARIABLE-SAME-P PCL::ENTRY-IN-CACHE-P + PCL::MAKE-OPTIMIZED-STD-SLOT-VALUE-USING-CLASS-METHOD-FUNCTION + PCL::MAKE-OPTIMIZED-STD-SETF-SLOT-VALUE-USING-CLASS-METHOD-FUNCTION + PCL::MAKE-OPTIMIZED-STD-SLOT-BOUNDP-USING-CLASS-METHOD-FUNCTION + PCL::|(FAST-METHOD INITIALIZE-INTERNAL-SLOT-FUNCTIONS + (EFFECTIVE-SLOT-DEFINITION))| + PCL::WRAP-METHOD-GROUP-SPECIFIER-BINDINGS + PCL::|(FAST-METHOD SLOT-DEFINITION-ALLOCATION (STRUCTURE-SLOT-DEFINITION))| + PCL::MAP-ALL-ORDERS + PCL::|(FAST-METHOD CLASS-FINALIZED-P (PCL-CLASS))| + PCL::|(FAST-METHOD CLASS-DIRECT-DEFAULT-INITARGS (SLOT-CLASS))| + PCL::|(FAST-METHOD CLASS-DEFAULT-INITARGS (SLOT-CLASS))| + PCL::|(FAST-METHOD CLASS-CONSTRUCTORS (SLOT-CLASS))| + PCL::|(FAST-METHOD CLASS-SLOT-CELLS (STD-CLASS))| + PCL::CAN-OPTIMIZE-ACCESS PCL::OPTIMIZE-SLOT-VALUE + PCL::OPTIMIZE-SET-SLOT-VALUE PCL::OPTIMIZE-SLOT-BOUNDP + SYSTEM::APPLY-DISPLAY-FUN + PCL::|(FAST-METHOD UPDATE-CONSTRUCTORS (SLOT-CLASS))| + PCL::|(FAST-METHOD UPDATE-CONSTRUCTORS (CLASS))| + PCL::TRACE-EMF-CALL-INTERNAL + PCL::|(FAST-METHOD MAKE-INSTANCES-OBSOLETE (STD-CLASS))| + PCL::GET-FUNCTION-GENERATOR + PCL::|(FAST-METHOD SPECIALIZER-DIRECT-METHODS (CLASS))| + WALKER:VARIABLE-DECLARATION PCL::COMPUTE-STD-CPL-PHASE-3 + PCL::|(FAST-METHOD SPECIALIZER-DIRECT-GENERIC-FUNCTIONS (CLASS))|)) (PROCLAIM - '(FTYPE (FUNCTION (T T T T T T T T T T) T) LOAD-DEFMETHOD-INTERNAL - LOAD-DEFMETHOD)) + '(FTYPE (FUNCTION (T T T T) T) WALKER::WALK-LET/LET* + WALKER::WALK-PROG/PROG* + PCL::|(FAST-METHOD CHANGE-CLASS (STANDARD-OBJECT STANDARD-CLASS))| + WALKER::WALK-DO/DO* WALKER::WALK-BINDINGS-2 + PCL::|(FAST-METHOD CHANGE-CLASS (STANDARD-OBJECT FUNCALLABLE-STANDARD-CLASS))| + PCL::|(FAST-METHOD ADD-DIRECT-METHOD (SPECIALIZER-WITH-OBJECT METHOD))| + PCL::|(FAST-METHOD REMOVE-DIRECT-METHOD (SPECIALIZER-WITH-OBJECT METHOD))| + PCL::OPTIMIZE-READER PCL::OPTIMIZE-WRITER + PCL::|(FAST-METHOD VALIDATE-SUPERCLASS (CLASS BUILT-IN-CLASS))| + PCL::|(FAST-METHOD VALIDATE-SUPERCLASS (SLOT-CLASS FORWARD-REFERENCED-CLASS))| + PCL::FILL-CACHE-P + PCL::|(FAST-METHOD ADD-DEPENDENT (DEPENDENT-UPDATE-MIXIN T))| + PCL::ADJUST-CACHE PCL::EXPAND-CACHE + PCL::|(FAST-METHOD REMOVE-DEPENDENT (DEPENDENT-UPDATE-MIXIN T))| + PCL::|(FAST-METHOD REINITIALIZE-INSTANCE :BEFORE (SLOT-CLASS))| + PCL::|(FAST-METHOD MAP-DEPENDENTS (DEPENDENT-UPDATE-MIXIN T))| + PCL::|(FAST-METHOD DIRECT-SLOT-DEFINITION-CLASS (STRUCTURE-CLASS T))| + PCL::|(FAST-METHOD PRINT-OBJECT (STANDARD-METHOD-COMBINATION T))| + PCL::|(FAST-METHOD DIRECT-SLOT-DEFINITION-CLASS (STD-CLASS T))| + PCL::|(FAST-METHOD VALIDATE-SUPERCLASS + (FUNCALLABLE-STANDARD-CLASS STANDARD-CLASS))| + PCL::|(FAST-METHOD LEGAL-DOCUMENTATION-P (STANDARD-METHOD T))| + PCL::INITIALIZE-INSTANCE-SIMPLE + PCL::|(FAST-METHOD LEGAL-LAMBDA-LIST-P (STANDARD-METHOD T))| + PCL::|(FAST-METHOD LEGAL-METHOD-FUNCTION-P (STANDARD-METHOD T))| + PCL::|(FAST-METHOD LEGAL-QUALIFIER-P (STANDARD-METHOD T))| + PCL::|(FAST-METHOD LEGAL-SLOT-NAME-P (STANDARD-METHOD T))| + PCL::|(FAST-METHOD ALLOCATE-INSTANCE (FUNCALLABLE-STANDARD-CLASS))| + PCL::MAYBE-EXPAND-ACCESSOR-FORM + PCL::|(FAST-METHOD LEGAL-SPECIALIZER-P (STANDARD-METHOD T))| + PCL::|(FAST-METHOD PRINT-OBJECT (GENERIC-FUNCTION T))| + PCL::|(FAST-METHOD MAKE-READER-METHOD-FUNCTION + (FUNCALLABLE-STANDARD-CLASS T))| + PCL::LOAD-PRECOMPILED-DFUN-CONSTRUCTOR PCL::GET-CACHE + PCL::|(FAST-METHOD MAKE-WRITER-METHOD-FUNCTION + (FUNCALLABLE-STANDARD-CLASS T))| + PCL::|(FAST-METHOD INITIALIZE-INSTANCE :AFTER (STANDARD-GENERIC-FUNCTION))| + PCL::|(FAST-METHOD REINITIALIZE-INSTANCE :AFTER (STANDARD-GENERIC-FUNCTION))| + PCL::|(FAST-METHOD COMPUTE-APPLICABLE-METHODS (GENERIC-FUNCTION T))| + PCL::|(FAST-METHOD SAME-SPECIALIZER-P (SPECIALIZER SPECIALIZER))| + PCL::GET-WRAPPERS-FROM-CLASSES + PCL::|(FAST-METHOD SAME-SPECIALIZER-P (CLASS CLASS))| + PCL::|(FAST-METHOD SAME-SPECIALIZER-P + (CLASS-EQ-SPECIALIZER CLASS-EQ-SPECIALIZER))| + PCL::|(FAST-METHOD PRINT-OBJECT (T T))| + PCL::|(FAST-METHOD SAME-SPECIALIZER-P (EQL-SPECIALIZER EQL-SPECIALIZER))| + PCL::|(FAST-METHOD PRINT-OBJECT (CLASS T))| + PCL::|(FAST-METHOD PRINT-OBJECT (SLOT-DEFINITION T))| + PCL::|(FAST-METHOD INFORM-TYPE-SYSTEM-ABOUT-CLASS (STRUCTURE-CLASS T))| + PCL::TWO-CLASS-DFUN-INFO PCL::SET-MAKE-INSTANCE-FUNCTION + PCL::|(FAST-METHOD UPDATE-GF-DFUN (STD-CLASS T))| + PCL::|(FAST-METHOD PRINT-OBJECT (STANDARD-METHOD T))| + PCL::|(FAST-METHOD PRINT-OBJECT (STANDARD-ACCESSOR-METHOD T))| + PCL::|(FAST-METHOD REINITIALIZE-INSTANCE (STANDARD-METHOD))| + WALKER::WALK-TEMPLATE PCL::EXPAND-DEFCLASS + PCL::BOOTSTRAP-SET-SLOT + PCL::|(FAST-METHOD ALLOCATE-INSTANCE (STANDARD-CLASS))| + PCL::|(FAST-METHOD SLOT-ACCESSOR-STD-P (EFFECTIVE-SLOT-DEFINITION T))| + PCL::|(FAST-METHOD DOCUMENTATION (T))| + PCL::|(FAST-METHOD DOCUMENTATION (DOCUMENTATION-MIXIN))| + PCL::|(FAST-METHOD EFFECTIVE-SLOT-DEFINITION-CLASS (STD-CLASS T))| + PCL::|(FAST-METHOD EFFECTIVE-SLOT-DEFINITION-CLASS (STRUCTURE-CLASS T))| + PCL::|(FAST-METHOD COMPUTE-EFFECTIVE-SLOT-DEFINITION-INITARGS (SLOT-CLASS T))| + PCL::|(FAST-METHOD COMPUTE-EFFECTIVE-SLOT-DEFINITION-INITARGS :AROUND + (STRUCTURE-CLASS T))| PCL::MAKE-EFFECTIVE-METHOD-FUNCTION1 + PCL::MAKE-EFFECTIVE-METHOD-FUNCTION-INTERNAL + PCL::MAKE-EFFECTIVE-METHOD-FUNCTION-TYPE + PCL::|(FAST-METHOD REMOVE-READER-METHOD (SLOT-CLASS T))| + PCL::|(FAST-METHOD REMOVE-WRITER-METHOD (SLOT-CLASS T))| + PCL::EMIT-CHECKING-OR-CACHING-FUNCTION-PRELIMINARY + PCL::MEMF-TEST-CONVERTER + PCL::|(FAST-METHOD REMOVE-BOUNDP-METHOD (SLOT-CLASS T))| + PCL::|(FAST-METHOD MAKE-READER-METHOD-FUNCTION (SLOT-CLASS T))| + PCL::|(FAST-METHOD ADD-DIRECT-SUBCLASS (CLASS CLASS))| + PCL::|(FAST-METHOD MAKE-WRITER-METHOD-FUNCTION (SLOT-CLASS T))| + PCL::|(FAST-METHOD MAKE-INSTANCE (CLASS))| + PCL::|(FAST-METHOD REMOVE-DIRECT-SUBCLASS (CLASS CLASS))| + PCL::EXPAND-SYMBOL-MACROLET-INTERNAL + PCL::|(FAST-METHOD MAKE-BOUNDP-METHOD-FUNCTION (SLOT-CLASS T))| + PCL::|(FAST-METHOD INFORM-TYPE-SYSTEM-ABOUT-CLASS (STD-CLASS T))| + PCL::|(FAST-METHOD ADD-DIRECT-METHOD (CLASS METHOD))| + PCL::|(FAST-METHOD REINITIALIZE-INSTANCE (SLOT-OBJECT))| + PCL::|(FAST-METHOD REMOVE-DIRECT-METHOD (CLASS METHOD))| + PCL::|(FAST-METHOD COMPATIBLE-META-CLASS-CHANGE-P (T T))| + PCL::|(FAST-METHOD VALIDATE-SUPERCLASS (CLASS CLASS))|)) (PROCLAIM - '(FTYPE (FUNCTION (T T T T T T T T T T T T T) T) - BOOTSTRAP-INITIALIZE-STANDARD-CLASS)) -(PROCLAIM '(FTYPE (FUNCTION (T T T FIXNUM T T *) T) SET-ARG-INFO)) + '(FTYPE (FUNCTION (T T T T T) T) + PCL::REAL-MAKE-METHOD-INITARGS-FORM PCL::MAKE-FGEN + WALKER::WALK-BINDINGS-1 + PCL::|(FAST-METHOD SHARED-INITIALIZE :BEFORE (BUILT-IN-CLASS T))| + PCL::COMPUTE-PV-SLOT + PCL::|(FAST-METHOD ENSURE-CLASS-USING-CLASS (T NULL))| + PCL::|(FAST-METHOD ENSURE-CLASS-USING-CLASS (T PCL-CLASS))| + PCL::OPTIMIZE-INSTANCE-ACCESS + PCL::BOOTSTRAP-MAKE-SLOT-DEFINITIONS + PCL::OPTIMIZE-ACCESSOR-CALL + PCL::BOOTSTRAP-ACCESSOR-DEFINITIONS + PCL::|(FAST-METHOD SHARED-INITIALIZE :AFTER (STD-CLASS T))| + PCL::|(FAST-METHOD SHARED-INITIALIZE :AFTER (STRUCTURE-CLASS T))| + PCL::|(FAST-METHOD COMPUTE-EFFECTIVE-METHOD + (GENERIC-FUNCTION STANDARD-METHOD-COMBINATION T))| + PCL::MAKE-PARAMETER-REFERENCES PCL::UPDATE-SLOTS-IN-PV + PCL::|(FAST-METHOD SHARED-INITIALIZE :BEFORE (STANDARD-ACCESSOR-METHOD T))| + PCL::|(FAST-METHOD SHARED-INITIALIZE :AFTER (STANDARD-METHOD T))| + PCL::|(FAST-METHOD REMOVE-NAMED-METHOD (T T))| + PCL::|(FAST-METHOD SHARED-INITIALIZE :AFTER (STRUCTURE-SLOT-DEFINITION T))| + PCL::MAKE-EMF-CACHE PCL::MAKE-INSTANCE-FUNCTION-COMPLEX + PCL::MAKE-INSTANCE-FUNCTION-SIMPLE + WALKER::WALK-TEMPLATE-HANDLE-REPEAT + PCL::|(FAST-METHOD SLOT-BOUNDP-USING-CLASS + (STD-CLASS STANDARD-OBJECT STANDARD-EFFECTIVE-SLOT-DEFINITION))| + PCL::|(FAST-METHOD SLOT-MAKUNBOUND-USING-CLASS + (STD-CLASS STANDARD-OBJECT STANDARD-EFFECTIVE-SLOT-DEFINITION))| + PCL::|(FAST-METHOD SLOT-BOUNDP-USING-CLASS + (STRUCTURE-CLASS STRUCTURE-OBJECT + STRUCTURE-EFFECTIVE-SLOT-DEFINITION))| + PCL::|(FAST-METHOD SLOT-MAKUNBOUND-USING-CLASS + (STRUCTURE-CLASS STRUCTURE-OBJECT + STRUCTURE-EFFECTIVE-SLOT-DEFINITION))| + PCL::|(FAST-METHOD SLOT-UNBOUND (T T T))| + PCL::|(FAST-METHOD (SETF SLOT-ACCESSOR-STD-P) + (T EFFECTIVE-SLOT-DEFINITION T))| + PCL::|(FAST-METHOD COMPUTE-SLOT-ACCESSOR-INFO + (EFFECTIVE-SLOT-DEFINITION T T))| + PCL::|(FAST-METHOD SHARED-INITIALIZE :AFTER (DOCUMENTATION-MIXIN T))| + PCL::|(FAST-METHOD FIND-METHOD-COMBINATION + (GENERIC-FUNCTION (EQL STANDARD) T))| + PCL::|(FAST-METHOD (SETF DOCUMENTATION) (T T))| + PCL::|(FAST-METHOD COMPUTE-EFFECTIVE-METHOD + (GENERIC-FUNCTION SHORT-METHOD-COMBINATION T))| + PCL::|(FAST-METHOD (SETF DOCUMENTATION) (T DOCUMENTATION-MIXIN))| + PCL::|(FAST-METHOD READER-METHOD-CLASS (SLOT-CLASS T))| + PCL::|(FAST-METHOD WRITER-METHOD-CLASS (SLOT-CLASS T))| + PCL::EXPAND-EMF-CALL-METHOD + PCL::OPTIMIZE-GENERIC-FUNCTION-CALL + PCL::MAKE-FINAL-ORDINARY-DFUN-INTERNAL + PCL::LOAD-FUNCTION-GENERATOR)) (PROCLAIM - '(FTYPE (FUNCTION (T T T T T T T T T T T T T T T) T) - ADD-LEXICAL-FUNCTIONS-TO-DOCUMENTED-STANDARD-METHOD-LAMBDA)) -(PROCLAIM '(FTYPE (FUNCTION (T T FIXNUM) T) COMPUTE-STD-CPL-PHASE-3)) + '(FTYPE (FUNCTION (T T T T T T *) T) PCL::MAKE-DEFMETHOD-FORM + PCL::MAKE-DEFMETHOD-FORM-INTERNAL PCL::LOAD-DEFMETHOD + PCL::EARLY-MAKE-A-METHOD PCL::SET-ARG-INFO)) (PROCLAIM - '(FTYPE (FUNCTION (T T T T T T T) T) EXPAND-DEFMETHOD - MAKE-LAP-CLOSURE-GENERATOR-LAMBDA)) + '(FTYPE (FUNCTION (T T T T *) T) PCL::FILL-DFUN-CACHE + PCL::EARLY-ADD-NAMED-METHOD PCL::REAL-ADD-NAMED-METHOD)) (PROCLAIM - '(FTYPE (FUNCTION (T T T T T) T) - |CONSTRUCTOR-CODE-GENERATOR PCL SIMPLE-SLOTS| - LOAD-CONSTRUCTOR MAKE-FINAL-ORDINARY-DFUN-INTERNAL - BOOTSTRAP-MAKE-SLOT-DEFINITIONS MAKE-LAP-PROG - EMIT-1-NIL-DLAP DLAP-WRAPPER-MOVES OPTIMIZE-SLOT-VALUE - OPTIMIZE-SET-SLOT-VALUE OPTIMIZE-SLOT-BOUNDP - GET-SECONDARY-DISPATCH-FUNCTION2 - |CONSTRUCTOR-CODE-GENERATOR PCL GENERAL| - WALKER::WALK-TEMPLATE-HANDLE-REPEAT - MAKE-PARAMETER-REFERENCES - |CONSTRUCTOR-CODE-GENERATOR PCL NO-METHODS| - |CONSTRUCTOR-CODE-GENERATOR PCL FALLBACK| - WALKER::WALK-BINDINGS-1 MAKE-LAP-PROG-INTERNAL - MAKE-EMF-CACHE BUILD-WITH-ACCESSOR-S-V MAKE-FGEN - LOAD-FUNCTION-GENERATOR)) + '(FTYPE (FUNCTION (T T T *) T) WALKER::WALK-ARGLIST + PCL::CAN-OPTIMIZE-ACCESS1 PCL::EMIT-FETCH-WRAPPER + PCL::CHECK-INITARGS-1 PCL::MAKE-EMF-CALL PCL::FILL-CACHE + PCL::CHECK-INITARGS-2-PLIST PCL::REAL-GET-METHOD + PCL::CHECK-INITARGS-2-LIST PCL::GET-METHOD)) (PROCLAIM - '(FTYPE (FUNCTION (T T T) T) SYSTEM::APPLY-DISPLAY-FUN - PRINT-INTERNAL-SLOTD ONE-INDEX-DFUN-INFO |LAP Opcode NEQ| - WALKER::WALK-DO* CHECK-OPCODE-ARG WALKER::WALK-IF - EMIT-1-WRAPPER-COMPUTE-PRIMARY-CACHE-LOCATION - GET-NEW-FUNCTION-GENERATOR CHECK-INITARGS-1 - SET-FUNCALLABLE-STANDARD-INSTANCE-ACCESS MAKE-SLOT-SYMBOL - SORT-METHODS ITERATE::OPTIMIZE-GATHERING-FORM - SORT-APPLICABLE-METHODS - ITERATE::SIMPLE-EXPAND-GATHERING-FORM - WRAP-METHOD-GROUP-SPECIFIER-BINDINGS - EARLY-STORE-METHOD-FUNCTION-P SET-FUNCTION-NAME-1 - EARLY-STORE-METHOD-OPTIMIZED-FUNCTION-P - EARLY-STORE-CLOSURE-GENERATOR-P PRINT-STD-INSTANCE - TRACE-FUNCTION-INTERNAL WALKER::WALK-SETQ MAKE-METHOD-SPEC - OPTIMIZE-SLOT-VALUE-BY-CLASS-P - ITERATE::OPTIMIZE-ITERATE-FORM SET-STANDARD-INSTANCE-ACCESS - WALKER::WALK-FLET |LAP Opcode EQ| WALKER::WALK-PROG - SKIP-FAST-SLOT-ACCESS-P SKIP-OPTIMIZE-SLOT-VALUE-BY-CLASS-P - CHECK-OPERAND-ARG WALKER::WALK-MULTIPLE-VALUE-BIND - WALKER::WALK-LABELS WALKER::WALK-TAGBODY-1 - |LAP Opcode FIX=| WALKER::WALK-SYMBOL-MACROLET - WALKER::WALK-PROG* SET-USER-INSTANCE-ACCESS - WALKER::WALK-LAMBDA FLUSH-CACHE-TRAP BOOTSTRAP-GET-SLOT - OBSOLETE-INSTANCE-TRAP UPDATE-STRUCTURE-CLASS - WALKER::WALK-TAGBODY |SETF PCL METHOD-FUNCTION-GET| - FIX-SLOT-ACCESSORS |SETF PCL PLIST-VALUE| - WALKER::WALK-NAMED-LAMBDA SLOW-SET-SLOT-VALUE - WALKER::WALK-COMPILER-LET WALKER::WALK-LET - |LAP Operand ISET| WALKER::WALK-MULTIPLE-VALUE-SETQ - WALKER::RELIST-INTERNAL CAN-OPTIMIZE-ACCESS - ITERATE::VARIABLE-SAME-P OPTIMIZE-GENERIC-FUNCTION-CALL - GET-FUNCTION-GENERATOR EMIT-LOCK-COUNT-TEST - ONE-CLASS-DFUN-INFO WALKER::RECONS WALKER::WALK-LET* - MAKE-TOP-LEVEL-FORM WALKER::WALK-MACROLET MAP-ALL-ORDERS - EXPAND-DEFGENERIC SET-CONSTRUCTOR-CODE INVALIDATE-WRAPPER - EMIT-CHECK-1-CLASS-WRAPPER - WALKER::WITH-AUGMENTED-ENVIRONMENT-INTERNAL - EARLY-STORE-OPTIMIZED-METHOD-LAMBDA-P CONVERT-TABLE - MAKE-DFUN-CALL - EMIT-N-WRAPPER-COMPUTE-PRIMARY-CACHE-LOCATION - NEW-ARG-INFO-FROM-GENERIC-FUNCTION COMPUTE-PRECEDENCE - WALKER::WALK-DO ITERATE::RENAME-AND-CAPTURE-VARIABLES - PRINT-CACHE WALKER::WALK-UNEXPECTED-DECLARE - VARIABLE-DECLARATION)) + '(FTYPE (FUNCTION (T T T T T T T) T) PCL::EXPAND-DEFMETHOD + PCL::LOAD-DEFMETHOD-INTERNAL + PCL::|(FAST-METHOD SLOT-MISSING (T T T T))|)) (PROCLAIM '(FTYPE (FUNCTION (T T T T T T) T) + PCL::BOOTSTRAP-MAKE-SLOT-DEFINITION PCL::EMIT-SLOT-ACCESS + PCL::OPTIMIZE-GF-CALL PCL::LOAD-DEFCLASS WALKER::WALK-TEMPLATE-HANDLE-REPEAT-1 - BOOTSTRAP-MAKE-SLOT-DEFINITION MAKE-EARLY-CLASS-DEFINITION - LOAD-DEFCLASS EMIT-DLAP-INTERNAL EMIT-ADJUST-LOCATION - EMIT-GREATER-THAN-1-DLAP EMIT-1-T-DLAP - OPTIMIZE-STD-INSTANCE-ACCESS REAL-LOAD-DEFCLASS - DO-SHORT-METHOD-COMBINATION BUILD-MAYBE-SAFE-W-O-S-V)) + PCL::MAKE-EARLY-CLASS-DEFINITION + PCL::|(FAST-METHOD (SETF SLOT-VALUE-USING-CLASS) + (T STD-CLASS STANDARD-OBJECT STANDARD-EFFECTIVE-SLOT-DEFINITION))|)) +(PROCLAIM + '(FTYPE (FUNCTION (T T T T T T T T) T) + PCL::GET-SECONDARY-DISPATCH-FUNCTION2)) (PROCLAIM - '(FTYPE (FUNCTION (T T T T) T) ADJUST-CACHE EXPAND-CACHE - MAKE-STD-CLOSURE-GENERATOR-FORM WALKER::WALK-BINDINGS-2 - EXPAND-SYMBOL-MACROLET-INTERNAL - EMIT-CHECK-1-WRAPPER-IN-CACHE CHECK-INITARGS - BUILD-W-S-V-FIND-SLOT-INDICES EMIT-CHECK-2-CLASS-WRAPPER - GET-ACCESSOR-FROM-SVUC-METHOD-FUNCTION TWO-CLASS-DFUN-INFO - EXPAND-DEFCLASS LOAD-PRECOMPILED-DFUN-CONSTRUCTOR - WALKER::WALK-LET/LET* MAKE-CONSTRUCTOR BOOTSTRAP-SET-SLOT - WALKER::WALK-TEMPLATE EXPAND-DEFCONSTRUCTOR - WALKER::WALK-PROG/PROG* EMIT-CHECK-CACHE-LINE - BOOTSTRAP-ACCESSOR-DEFINITIONS EMIT-CHECK-CACHE-ENTRY - WALKER::WALK-DO/DO* FILL-CACHE-P)) + '(FTYPE (FUNCTION (T T T T T *) T) PCL::EMIT-DLAP + PCL::GET-MAKE-INSTANCE-FUNCTION-INTERNAL + PCL::GET-SECONDARY-DISPATCH-FUNCTION1)) (PROCLAIM - '(FTYPE (FUNCTION (T T T T *) T) EMIT-FETCH-WRAPPER - FILL-DFUN-CACHE)) + '(FTYPE (FUNCTION (T T T FIXNUM) T) PCL::FILL-CACHE-FROM-CACHE-P)) (PROCLAIM - '(FTYPE (FUNCTION (T T T *) T) GET-METHOD FILL-CACHE - REAL-GET-METHOD EMIT-GET-SLOT EMIT-SET-SLOT - BUILD-WITH-OPTIMIZED-SLOTS-FORM - GET-SECONDARY-DISPATCH-FUNCTION1 WALKER::WALK-ARGLIST - RECORD-UPDATER)) -(PROCLAIM '(FTYPE (FUNCTION (FIXNUM FIXNUM) FIXNUM) MAKE-INDEX-MASK)) + '(FTYPE (FUNCTION (T T T T T T T T T *) T) + PCL::BOOTSTRAP-INITIALIZE-CLASS)) (PROCLAIM - '(FTYPE (FUNCTION NIL *) RENEW-SYS-FILES EMIT-N-N-READERS - COUNT-ALL-DFUNS EMIT-N-N-WRITERS)) + '(FTYPE (FUNCTION NIL *) PCL::COUNT-ALL-DFUNS PCL::EMIT-N-N-READERS + PCL::EMIT-N-N-WRITERS PCL::RENEW-SYS-FILES)) (PROCLAIM - '(FTYPE (FUNCTION NIL T) IN-THE-COMPILER-P RESET-CONSTRUCTORS - BEFORE-PRECOMPILE-RANDOM-CODE-SEGMENTS BOOTSTRAP-META-BRAID - DEFAULT-METHOD-ONLY-DFUN-INFO MAKE-ARG-INFO - |LAP Opcode EXIT-LAP-IN-LISP| DISABLE-CONSTRUCTORS - RESET-PCL-PACKAGE SHOW-FREE-CACHE-VECTORS - INITIAL-DISPATCH-DFUN-INFO FLOAT-ZERO - SHOW-DFUN-CONSTRUCTORS |LAP Opcode BREAK| - ENABLE-CONSTRUCTORS EARLY-INITIALIZE-SLOT-GFS - %%ALLOCATE-INSTANCE--CLASS CACHES-TO-ALLOCATE - ALLOCATE-FUNCALLABLE-INSTANCE-1 - ALLOCATE-FUNCALLABLE-INSTANCE-2 MAKE-CPD - GET-EFFECTIVE-METHOD-GENSYM DISPATCH-DFUN-INFO - FIX-DFUNS-NEEDING-UPDATE NO-METHODS-DFUN-INFO - |LAP Opcode BEEP| MAKE-CACHE BOOTSTRAP-BUILT-IN-CLASSES - EARLY-INITIALIZE-CLASS-PREDICATES LIST-ALL-DFUNS)) + '(FTYPE (FUNCTION NIL T) + PCL::INITIALIZE-CHECKING-OR-CACHING-FUNCTION-LIST + PCL::SHOW-EMF-CALL-TRACE PCL::MAKE-CACHE PCL::MAKE-CPD + PCL::BOOTSTRAP-META-BRAID PCL::EARLY-INITIALIZE-SLOT-GFS + PCL::EARLY-INITIALIZE-CLASS-PREDICATES + PCL::BOOTSTRAP-BUILT-IN-CLASSES PCL::UPDATE-DISPATCH-DFUNS + PCL::SHOW-FREE-CACHE-VECTORS PCL::NO-METHODS-DFUN-INFO + PCL::IN-THE-COMPILER-P PCL::STRUCTURE-FUNCTIONS-EXIST-P + PCL::%%ALLOCATE-INSTANCE--CLASS + PCL::ALLOCATE-FUNCALLABLE-INSTANCE-2 + PCL::ALLOCATE-FUNCALLABLE-INSTANCE-1 + PCL::DEFAULT-METHOD-ONLY-DFUN-INFO + PCL::INITIAL-DISPATCH-DFUN-INFO PCL::INITIAL-DFUN-INFO + PCL::MAKE-ARG-INFO PCL::DISPATCH-DFUN-INFO + PCL::SHOW-DFUN-CONSTRUCTORS PCL::CACHES-TO-ALLOCATE + PCL::RESET-PCL-PACKAGE PCL::GET-EFFECTIVE-METHOD-GENSYM + PCL::LIST-ALL-DFUNS)) (PROCLAIM - '(FTYPE (FUNCTION (*) *) INVALID-METHOD-ERROR - METHOD-COMBINATION-ERROR UNTRACE-METHOD - FINALIZE-ALL-CLASSES LIST-LARGE-CACHES)) -(PROCLAIM '(FTYPE (FUNCTION (FIXNUM T T) *) COMPUTE-CACHE-PARAMETERS)) -(PROCLAIM '(FTYPE (FUNCTION (FIXNUM T *) *) FIND-FREE-CACHE-LINE)) -(PROCLAIM '(FTYPE (FUNCTION (T FIXNUM T) *) EMIT-READER/WRITER)) + '(FTYPE (FUNCTION (*) *) PCL::LIST-LARGE-CACHES + PCL:INVALID-METHOD-ERROR PCL:METHOD-COMBINATION-ERROR + PCL::UNTRACE-METHOD)) +(PROCLAIM '(FTYPE (FUNCTION (FIXNUM T *) *) PCL::FIND-FREE-CACHE-LINE)) (PROCLAIM - '(FTYPE (FUNCTION (*) T) |__si::MAKE-TWO-CLASS| TRUE - |__si::MAKE-ONE-INDEX-DFUN-INFO| WRAPPER-ERROR - |__si::MAKE-ARG-INFO| |__si::MAKE-STD-INSTANCE| - |__si::MAKE-CHECKING| |__si::MAKE-CACHING| - WALKER::UNBOUND-LEXICAL-FUNCTION |__si::MAKE-NO-METHODS| - |__si::MAKE-CLASS-PRECEDENCE-DESCRIPTION| FALSE - FIX-EARLY-GENERIC-FUNCTIONS |__si::MAKE-N-N| - |__si::MAKE-DEFAULT-METHOD-ONLY| FLATTEN-LAP - |__si::MAKE-CONSTANT-VALUE| STRING-APPEND - NULL-WRAPPERS-METHOD-FUNCTION |__si::MAKE-INITIAL-DISPATCH| - |STRUCTURE-OBJECT class constructor| - CALLED-FIN-WITHOUT-FUNCTION |__si::MAKE-DISPATCH| - |__si::MAKE-ONE-CLASS| MAKE-PROGN - |__si::MAKE-ACCESSOR-DFUN-INFO| |__si::MAKE-ONE-INDEX| ZERO - MAKE-INTERNAL-SLOTD |__si::MAKE-DFUN-INFO| - |__si::MAKE-CACHE|)) + '(FTYPE (FUNCTION (FIXNUM T T) *) PCL::COMPUTE-CACHE-PARAMETERS)) (PROCLAIM - '(FTYPE (FUNCTION (T) *) IN-COMPILER-FORCE-COMPILE - SLOT-INITFUNCTION-STORAGE-FORM COMPILE-INITFUNCTION - MAKE-DISPATCH-DFUN EMIT-CONSTANT-VALUE - COMPUTE-APPLICABLE-METHODS-EMF MAKE-FINAL-DISPATCH-DFUN - PARSE-METHOD-GROUP-SPECIFIER ANALYZE-LAMBDA-LIST - PARSE-DEFMETHOD EMIT-ONE-CLASS-READER PCL-DESCRIBE - COMPUTE-CONSTANT-VECTOR EMIT-ONE-INDEX-READERS - EMIT-ONE-CLASS-WRITER EMIT-ONE-INDEX-WRITERS - MAP-CONSTRUCTORS METHOD-FUNCTION-STORAGE-FORM - COMPILE-FUNCTION EMIT-TWO-CLASS-READER - DEFAULT-CODE-CONVERTER EARLY-COLLECT-INHERITANCE - EMIT-TWO-CLASS-WRITER GET-DISPATCH-FUNCTION CCLOSUREP)) + '(FTYPE (FUNCTION (*) T) PCL::MAKE-METHOD-CALL + PCL::MAKE-FAST-METHOD-CALL PCL::MAKE-FAST-INSTANCE-BOUNDP + PCL::PV-WRAPPERS-FROM-PV-ARGS PCL::MAKE-PV-TABLE + PCL::|__si::MAKE-ARG-INFO| PCL::|__si::MAKE-PV-TABLE| + PCL::FIX-EARLY-GENERIC-FUNCTIONS PCL::|__si::MAKE-CACHE| + PCL::|__si::MAKE-NO-METHODS| PCL::|__si::MAKE-STD-INSTANCE| + PCL::CALLED-FIN-WITHOUT-FUNCTION + WALKER::UNBOUND-LEXICAL-FUNCTION PCL::MAKE-INITIALIZE-INFO + PCL::UPDATE-MAKE-INSTANCE-FUNCTION-TABLE + PCL::|__si::MAKE-DFUN-INFO| + PCL::|__si::MAKE-DEFAULT-METHOD-ONLY| + PCL::|__si::MAKE-ACCESSOR-DFUN-INFO| PCL::MAKE-PROGN + PCL::|__si::MAKE-ONE-INDEX-DFUN-INFO| PCL::|__si::MAKE-N-N| + PCL::|__si::MAKE-CLASS-PRECEDENCE-DESCRIPTION| + PCL::|__si::MAKE-ONE-CLASS| PCL::|__si::MAKE-TWO-CLASS| + PCL::|__si::MAKE-ONE-INDEX| PCL::|__si::MAKE-CHECKING| + PCL::|__si::MAKE-CACHING| PCL::|__si::MAKE-CONSTANT-VALUE| + PCL::INTERN-PV-TABLE PCL::TRUE PCL::|__si::MAKE-DISPATCH| + PCL::STRING-APPEND PCL::|__si::MAKE-INITIAL| PCL::FALSE + PCL::|__si::MAKE-INITIAL-DISPATCH| + PCL::|STRUCTURE-OBJECT class constructor|)) (PROCLAIM - '(FTYPE (FUNCTION (FIXNUM T T T) T) GET-WRAPPERS-FROM-CLASSES)) -(PROCLAIM '(FTYPE (FUNCTION (T FIXNUM *) T) GET-CACHE-FROM-CACHE)) -(PROCLAIM '(FTYPE (FUNCTION (FIXNUM T T FIXNUM) T) GET-CACHE)) + '(FTYPE (FUNCTION (T) *) PCL::METHOD-PROTOTYPE-FOR-GF + PCL::FIND-WRAPPER PCL::PARSE-DEFMETHOD + PCL::PROTOTYPES-FOR-MAKE-METHOD-LAMBDA + PCL::FORCE-CACHE-FLUSHES PCL::STRUCTURE-WRAPPER + PCL::EMIT-ONE-CLASS-READER PCL::EMIT-ONE-CLASS-WRITER + PCL::EMIT-TWO-CLASS-READER PCL::EMIT-TWO-CLASS-WRITER + PCL::EMIT-ONE-INDEX-READERS PCL::EMIT-ONE-INDEX-WRITERS + PCL::EARLY-METHOD-FUNCTION PCL::EMIT-IN-CHECKING-CACHE-P + PCL::EMIT-CONSTANT-VALUE + PCL::COMPUTE-APPLICABLE-METHODS-EMF PCL::NET-CODE-CONVERTER + PCL::STRUCTURE-SLOTD-INIT-FORM PCL::MAKE-DISPATCH-DFUN + PCL::INSURE-CACHING-DFUN PCL::%FBOUNDP PCL::CCLOSUREP + PCL::EARLY-COLLECT-INHERITANCE PCL::TYPE-FROM-SPECIALIZER + PCL::*NORMALIZE-TYPE PCL::UNPARSE-TYPE + PCL::CONVERT-TO-SYSTEM-TYPE PCL::PCL-DESCRIBE + PCL::PARSE-METHOD-GROUP-SPECIFIER PCL::ANALYZE-LAMBDA-LIST + COMPILER::CAN-USE-PRINT-CIRCLE-P PCL::GF-LAMBDA-LIST + PCL::SPECIALIZER-FROM-TYPE PCL::CLASS-EQ-TYPE + PCL::FIND-STRUCTURE-CLASS PCL::GENERIC-FUNCTION-NAME-P + PCL::GET-DISPATCH-FUNCTION PCL::DEFAULT-CODE-CONVERTER + PCL::MAKE-FINAL-DISPATCH-DFUN)) (PROCLAIM - '(FTYPE (FUNCTION (T) T) SIMPLE-EVAL-ACCESS-P UNDEFMETHOD-1 - ALL-STANDARD-ACCESSES-P MAP-ALL-GENERIC-FUNCTIONS - |LAP Operand WRAPPER-CACHE-NUMBER-VECTOR| - STRUCTURE-SLOTD-READER-FUNCTION LOOKUP-FGEN - |LAP Operand OTHER-WRAPPER| TWO-CLASS-ACCESSOR-TYPE - STORE-FGEN GFS-OF-TYPE DEFAULT-METHOD-ONLY-CACHE - REALLY-FUNCTION-P METHOD-FUNCTION-METHOD - FTYPE-DECLARATION-FROM-LAMBDA-LIST EARLY-COLLECT-CPL - DFUN-INFO-P ARG-INFO-PRECEDENCE GET-WRITER-FUNCTION - EARLY-METHOD-QUALIFIERS LAP-OPERAND CPD-CLASS - TWO-CLASS-WRAPPER1 |LAP Opcode JMP| STORE-DEFSTRUCT-FORM - FLUSH-CACHE-VECTOR-INTERNAL FREE-CACHE CACHE-P - |LAP Operand LISP-VARIABLE| MAKE-STD-WRITER-METHOD-FUNCTION - PROCLAIM-CLOSURE EXPAND-LONG-DEFCOMBIN ONE-CLASS-CACHE - INITIALIZE-INTERNAL-SLOT-BOUNDP-GFS *NORMALIZE-TYPE - MAKE-FIND-CLASS-CELL STRUCTURE-SLOTD-WRITER-FUNCTION - FUNCTION-RETURNING-T DEFAULT-TEST-CONVERTER - INTERNAL-SLOTD-SLOT-DEFINITION ECD-CLASS-NAME GBOUNDP - CONSTANT-VALUE-CACHE CACHING-DFUN-INFO INTERNAL-SLOTD-P - MAKE-TYPE-PREDICATE FUNCTION-FTYPE-DECLAIMED-P - INTERNAL-SLOTD-LOCATION STRUCTURE-TYPE-INCLUDED-TYPE-NAME - NET-TEST-CONVERTER UPDATE-ALL-C-A-M-GF-INFO - SYSTEM::NEXT-STACK-FRAME EARLY-GF-NAME - INITIAL-DISPATCH-CACHE FUNCALLABLE-INSTANCE-P - TWO-CLASS-CACHE GDEFINITION EARLY-COLLECT-SLOTS - NO-METHODS-P CACHING-P - MAKE-STRUCTURE-INSTANCE-READER-METHOD-FUNCTION - |LAP Operand CVAR| KNOWN-STRUCTURE-TYPE-P - STRUCTURE-SLOTD-NAME UNTRACE-METHOD-FUNCTION-NAMES - INDEX-VALUE->INDEX NON-PCL-SHARED-INITIALIZE-METHODS-P - ONE-CLASS-ACCESSOR-TYPE EXPAND-SHORT-DEFCOMBIN - CLASS-FROM-TYPE |LAP Opcode LABEL| ONE-CLASS-INDEX - LIST-DFUN EARLY-CLASS-ORIGINAL-STATIC-SLOT-STORAGE-COPY - TWO-CLASS-P GET-CACHE-VECTOR - MAKE-FUNCALLABLE-STANDARD-INSTANCE-WRITER-METHOD-FUNCTION - DEFAULT-CONSTANT-CONVERTER DEFSTRUCT-FORM-CLASS-NAME - KEYWORD-SPEC-NAME ARG-INFO-APPLYP - DEFSTRUCT-FORM-CONSTRUCTOR CONVERT-TO-SYSTEM-TYPE - CLASS-PREDICATE DFUN-INFO-CACHE LAP-OPCODE - EARLY-METHOD-FUNCTION MAKE-CLASS-PREDICATE - USER-INSTANCE-SLOTS USE-CONSTANT-VALUE-DFUN-P - FUNCTION-PRETTY-ARGLIST ECD-OTHER-INITARGS - INTERN-FUNCTION-NAME CACHING-CACHE CLASS-STANDARD-P - EARLY-METHOD-STANDARD-ACCESSOR-P |LAP Operand STD-WRAPPER| - N-N-P STRUCTURE-OBJECT-P GF-INFO-STATIC-C-A-M-EMF - PARSE-SPECIALIZERS ITERATE::VARIABLES-FROM-LET - ALLOCATE-REGISTER CLASS-INSTANCE-TYPE - UPDATE-GF-SIMPLE-ACCESSOR-TYPE DNET-METHODS-P - DEFAULT-METHOD-ONLY-P FORCE-CACHE-FLUSHES - |LAP Operand STD-SLOTS| |LAP Opcode RETURN| - COMPILER::CAN-USE-PRINT-CIRCLE-P ECD-METACLASS N-N-CACHE - REDIRECT-EARLY-FUNCTION-INTERNAL LAMBDA-LIST-REQUIRED-ARGS - INITIALIZE-INTERNAL-SLOT-READER-GFS - REALLY-COMPILED-FUNCTION-P |LAP Operand BUILT-IN-WRAPPER| - MAKE-CLASS-EQ-PREDICATE ARG-INFO-METATYPES INSTANCE-TYPE - CPD-AFTER DEFAULT-CONSTANTP - INITIALIZE-INTERNAL-SLOT-WRITER-GFS TRACE-METHODS - TWO-CLASS-INDEX NO-METHODS-CACHE - EARLY-COLLECT-DEFAULT-INITARGS STRUCTURE-WRAPPER - MAKE-OPTIMIZED-USER-BOUNDP-METHOD-FUNCTION DISPATCH-P - UNPARSE-TYPE-LIST N-N-ACCESSOR-TYPE ACCESSOR-DFUN-INFO-P - CLASS-PRECEDENCE-DESCRIPTION-P ONE-CLASS-WRAPPER0 - METHODS-CONTAIN-EQL-SPECIALIZER-P - UPDATE-CLASS-CAN-PRECEDE-P TYPE-CLASS ARG-INFO-KEYWORDS - FGEN-TEST MAKE-STD-READER-METHOD-FUNCTION - DEFSTRUCT-FORM-CONC-NAME EMIT-MISS FREE-CACHE-VECTOR - UNENCAPSULATED-FDEFINITION CHECK-WRAPPER-VALIDITY - MAKE-EQL-PREDICATE UNPARSE-TYPE DLAP-WRAPPERS EARLY-GET-CPL - FGEN-GENERATOR-LAMBDA STRUCTURE-TYPE-INTERNAL-SLOTDS - CHECKING-P |LAP Operand ARG| FIND-CYCLE-REASONS CPD-SUPERS - %CCLOSURE-ENV TWO-CLASS-WRAPPER0 COMPUTE-STD-CPL-PHASE-2 - WALKER::ENV-WALK-FUNCTION GET-BOUNDP-FUNCTION - |LAP Operand STRUCTURE-WRAPPER| GET-READER-FUNCTION - |LAP Operand REG| ARG-INFO-LAMBDA-LIST |LAP Operand I1+| - DEFSTRUCT-FORM-PREDICATE-NAME ARG-INFO-VALID-P - USER-INSTANCE-P WRAPPER-OF %STD-INSTANCE-WRAPPER - INITIAL-DISPATCH-P - MAKE-OPTIMIZED-USER-WRITER-METHOD-FUNCTION - MAKE-DEFAULT-METHOD-GROUP-DESCRIPTION MAKE-INITIAL-DFUN - GET-SETF-FUNCTION-NAME USER-INSTANCE-WRAPPER DISPATCH-CACHE - |LAP Operand USER-WRAPPER| EXTRACT-LAMBDA-LIST - UPDATE-GFS-OF-CLASS FIND-WRAPPER EXTRACT-SPECIALIZER-NAMES - DEFAULT-SECONDARY-DISPATCH-FUNCTION FORMAT-CYCLE-REASONS - FUNCTION-RETURNING-NIL DO-STANDARD-DEFSETFS-FOR-DEFCLASS - ITERATE::SEQUENCE-ACCESSOR |LAP Operand LISP| EARLY-GF-P - WALKER::ENV-LEXICAL-VARIABLES ONE-INDEX-DFUN-INFO-CACHE - MAKE-STD-DOCUMENTED-METHOD-FUNCTION LEGAL-CLASS-NAME-P - STANDARD-SVUC-METHOD GET-BUILT-IN-CLASS-SYMBOL - METHOD-PROTOTYPE-FOR-GF |LAP Opcode GO| - MAKE-STD-BOUNDP-METHOD-FUNCTION WALKER::ENV-DECLARATIONS - DEALLOCATE-REGISTER WALKER::ENV-WALK-FORM UPDATE-GF-INFO - ONE-INDEX-DFUN-INFO-ACCESSOR-TYPE CHECKING-CACHE - INTERN-EQL-SPECIALIZER GMAKUNBOUND DO-STANDARD-DEFSETF-1 - FGEN-GENSYMS INFORM-TYPE-SYSTEM-ABOUT-STD-CLASS + '(FTYPE (FUNCTION (T) T) PCL::FGEN-GENERATOR PCL::FGEN-SYSTEM + PCL::STORE-FGEN PCL::MAKE-PV-TYPE-DECLARATION + PCL::MAKE-CALLS-TYPE-DECLARATION PCL::CHECK-CACHE + PCL::FGEN-GENSYMS PCL::MAKE-CONSTANT-FUNCTION + PCL::FGEN-GENERATOR-LAMBDA PCL::FUNCTION-RETURNING-T + PCL::METHOD-CALL-P PCL::FIND-CYCLE-REASONS + PCL::MAP-ALL-GENERIC-FUNCTIONS PCL::MAKE-PERMUTATION-VECTOR + PCL::FAST-METHOD-CALL-P PCL::ALLOCATE-CACHE-VECTOR + PCL::FLUSH-CACHE-VECTOR-INTERNAL PCL::FORMAT-CYCLE-REASONS + PCL::FAST-INSTANCE-BOUNDP-P PCL::METHOD-FUNCTION-PV-TABLE + PCL::METHOD-FUNCTION-METHOD + PCL::DO-STANDARD-DEFSETFS-FOR-DEFCLASS + PCL::GET-CACHE-VECTOR + PCL::METHOD-FUNCTION-NEEDS-NEXT-METHODS-P + PCL::WRAPPER-FIELD PCL::FREE-CACHE-VECTOR + PCL::METHOD-FUNCTION-PLIST PCL::SORT-SLOTS + PCL::MAP-SPECIALIZERS + PCL::FTYPE-DECLARATION-FROM-LAMBDA-LIST + PCL::ONE-INDEX-DFUN-INFO-CACHE PCL::SORT-CALLS + PCL::ONE-INDEX-DFUN-INFO-ACCESSOR-TYPE PCL::DFUN-ARG-SYMBOL + PCL::N-N-CACHE PCL::GF-DFUN-CACHE PCL::N-N-ACCESSOR-TYPE + PCL::GDEFINITION PCL::GF-DFUN-INFO PCL::ONE-CLASS-CACHE + PCL::EVAL-FORM PCL::EARLY-GF-NAME + PCL::ONE-CLASS-ACCESSOR-TYPE + PCL::SLOT-INITARGS-FROM-STRUCTURE-SLOTD + PCL::ONE-CLASS-INDEX + PCL:EXTRACT-LAMBDA-LIST PCL::SYMBOL-PKG-NAME + PCL::TWO-CLASS-CACHE PCL:EXTRACT-SPECIALIZER-NAMES + PCL::ARG-INFO-PRECEDENCE PCL::TWO-CLASS-ACCESSOR-TYPE + PCL::ARG-INFO-METATYPES PCL::TWO-CLASS-INDEX + PCL::INITIALIZE-INFO-KEY PCL::INTERNED-SYMBOL-P + PCL::ARG-INFO-NUMBER-OPTIONAL PCL::TWO-CLASS-WRAPPER0 + PCL::INITIALIZE-INFO-WRAPPER PCL::FREE-CACHE + PCL::CLASS-HAS-A-FORWARD-REFERENCED-SUPERCLASS-P + PCL::ARG-INFO-KEY/REST-P PCL::ONE-INDEX-CACHE + PCL::ARG-INFO-KEYWORDS PCL::ONE-INDEX-ACCESSOR-TYPE + PCL::GF-INFO-SIMPLE-ACCESSOR-TYPE PCL::ONE-INDEX-INDEX + PCL::UPDATE-GFS-OF-CLASS PCL::GF-PRECOMPUTE-DFUN-AND-EMF-P + PCL::CHECKING-CACHE PCL::GF-INFO-STATIC-C-A-M-EMF + PCL::CACHING-CACHE PCL::GF-INFO-C-A-M-EMF-STD-P + PCL::CONSTANT-VALUE-CACHE PCL::UPDATE-CLASS-CAN-PRECEDE-P + PCL::GF-INFO-FAST-MF-P PCL::COMPUTE-CLASS-SLOTS + PCL::ARG-INFO-LAMBDA-LIST PCL:INTERN-EQL-SPECIALIZER + PCL::ARG-INFO-P PCL::ARG-INFO-VALID-P PCL::ARG-INFO-NKEYS + PCL::COMPILE-IIS-FUNCTIONS PCL::ARG-INFO-APPLYP + PCL::WRAPPER-FOR-STRUCTURE PCL::PV-TABLEP + PCL::UPDATE-GF-INFO PCL::MAKE-PV-TABLE-TYPE-DECLARATION + PCL::BUILT-IN-WRAPPER-OF PCL::CACHE-P + PCL::BUILT-IN-OR-STRUCTURE-WRAPPER1 + PCL::RESET-INITIALIZE-INFO PCL::UPDATE-PV-TABLE-CACHE-INFO + PCL::UPDATE-C-A-M-GF-INFO + PCL::UPDATE-GF-SIMPLE-ACCESSOR-TYPE + PCL::INITIALIZE-INFO-CACHED-VALID-P PCL::EARLY-CLASS-NAME + PCL::NO-METHODS-P PCL::STANDARD-SVUC-METHOD + PCL::INTERN-FUNCTION-NAME + PCL::INITIALIZE-INFO-CACHED-RI-VALID-P + PCL::STRUCTURE-SVUC-METHOD PCL::COMPILE-LAMBDA-UNCOMPILED + PCL::INITIALIZE-INFO-CACHED-INITARGS-FORM-LIST + PCL::COMPILE-LAMBDA-DEFERRED + PCL::INITIALIZE-INFO-CACHED-NEW-KEYS + PCL::INITIALIZE-INFO-CACHED-DEFAULT-INITARGS-FUNCTION + PCL::UNDEFMETHOD-1 + PCL::INITIALIZE-INFO-CACHED-SHARED-INITIALIZE-T-FUNCTION + PCL::METHOD-LL->GENERIC-FUNCTION-LL + PCL::COMPUTE-MCASE-PARAMETERS + PCL::INITIALIZE-INFO-CACHED-SHARED-INITIALIZE-NIL-FUNCTION + PCL::INITIALIZE-INFO-CACHED-CONSTANTS PCL::COPY-CACHE + PCL::NET-TEST-CONVERTER + PCL::INITIALIZE-INFO-CACHED-COMBINED-INITIALIZE-FUNCTION + PCL::COMPUTE-LINE-SIZE + PCL::ACCESSOR-DFUN-INFO-ACCESSOR-TYPE + PCL::UPDATE-ALL-C-A-M-GF-INFO + PCL::ONE-INDEX-DFUN-INFO-INDEX PCL::ONE-CLASS-WRAPPER0 + PCL::EXTRACT-PARAMETERS PCL::TWO-CLASS-WRAPPER1 + PCL::EXTRACT-REQUIRED-PARAMETERS + PCL::FUNCTION-PRETTY-ARGLIST PCL::CHECKING-FUNCTION + PCL::CLASS-FROM-TYPE PCL::DNET-METHODS-P + PCL::PROCLAIM-INCOMPATIBLE-SUPERCLASSES + PCL::FUNCALLABLE-INSTANCE-P PCL::DEFAULT-STRUCTUREP + PCL::DEFAULT-STRUCTURE-INSTANCE-P PCL::GFS-OF-TYPE + PCL::DEFAULT-STRUCTURE-TYPE PCL::STRUCTURE-TYPE + PCL::STRUCTURE-TYPE-INCLUDED-TYPE-NAME + PCL::RESET-CLASS-INITIALIZE-INFO + PCL::STRUCTURE-TYPE-SLOT-DESCRIPTION-LIST + PCL::CONSTANT-SYMBOL-P PCL::STRUCTURE-SLOTD-NAME + PCL::MAKE-INSTANCE-FUNCTION-SYMBOL + PCL::STRUCTURE-SLOTD-ACCESSOR-SYMBOL + PCL::MAKE-LAZY-GET-MAKE-INSTANCE-FUNCTION + PCL::%STD-INSTANCE-WRAPPER + PCL::STRUCTURE-SLOTD-WRITER-FUNCTION + PCL::%STD-INSTANCE-SLOTS PCL::STRUCTURE-SLOTD-TYPE + PCL::STD-INSTANCE-P PCL::CONSTANT-VALUE-P + PCL::USE-CACHING-DFUN-P + PCL::COMPLICATED-INSTANCE-CREATION-METHOD + PCL::MAKE-FUNCTION-INLINE + PCL::SLOT-VECTOR-SYMBOL PCL::CACHING-DFUN-INFO + PCL::COMPUTE-APPLICABLE-METHODS-EMF-STD-P + PCL::CONSTANT-VALUE-DFUN-INFO + PCL::STRUCTURE-TYPE-INTERNAL-SLOTDS WALKER::ENV-LOCK + PCL::CPD-CLASS WALKER::ENV-LEXICAL-VARIABLES + PCL::RESET-CLASS-INITIALIZE-INFO-1 WALKER::ENV-DECLARATIONS + ITERATE::VARIABLES-FROM-LET WALKER::GET-IMPLEMENTATION-DEPENDENT-WALKER-TEMPLATE - ARG-INFO-P WALKER::ENV-LOCK SPECIALIZER-FROM-TYPE - GET-CONS-GLOBAL-VARIABLE MAKE-CONSTANT-FUNCTION - MAKE-CALL-METHODS STRUCTURE-TYPE-SLOT-DESCRIPTION-LIST - VARIABLE-GLOBALLY-SPECIAL-P ONE-INDEX-P - STRUCTURE-SVUC-METHOD COMPUTE-APPLICABLE-METHODS-EMF-STD-P - MAKE-FUNCTION-INLINE |LAP Opcode PRINT| CHECKING-FUNCTION - ONE-INDEX-CACHE MAKE-DEFCLASS-DIRECT-SLOTS-FROM-DEFSTRUCT - UPDATE-C-A-M-GF-INFO PROTOTYPE-OF-GENERIC-FUNCTION - ONE-INDEX-ACCESSOR-TYPE %STD-INSTANCE-SLOTS ONE-INDEX-INDEX - ECD-SUPERCLASS-NAMES EXTRACT-REQUIRED-PARAMETERS - CLASS-EQ-TYPE EXTRACT-PARAMETERS UPDATE-SLOTS - CONSTANT-VALUE-DFUN-INFO - MAKE-STANDARD-INSTANCE-BOUNDP-METHOD-FUNCTION - MAKE-STRUCTURE-INSTANCE-WRITER-METHOD-FUNCTION - GENERIC-CLOBBERS-FUNCTION GF-DFUN-INFO MAKE-INITFUNCTION - |LAP Operand BUILT-IN-OR-STRUCTURE-WRAPPER| - |LAP Operand FSC-SLOTS| CANONICAL-SLOT-NAME - UNPARSE-SPECIALIZERS - MAKE-FUNCALLABLE-STANDARD-INSTANCE-BOUNDP-METHOD-FUNCTION - ONE-INDEX-DFUN-INFO-P FGEN-SYSTEM - MAKE-DOCUMENTED-STD-READER-METHOD-FUNCTION STD-INSTANCE-P - BUILT-IN-WRAPPER-OF - NON-PCL-OR-AFTER-SHARED-INITIALIZE-METHODS-P - SLOT-DEFINITION-DEFSTRUCT-SLOT-DESCRIPTION - LAP-REG-INITIAL-VALUE-FORM GET-BUILT-IN-WRAPPER-SYMBOL - WALKER::GET-WALKER-TEMPLATE STRUCTURE-SLOTD-ACCESSOR-SYMBOL - |LAP Operand CDR| - MAKE-STANDARD-INSTANCE-WRITER-METHOD-FUNCTION - EARLY-CLASS-DEFINITION ACCESSOR-DFUN-INFO-CACHE - MAKE-STANDARD-INSTANCE-READER-METHOD-FUNCTION - SYSTEM:%STRUCTURE-NAME SLOT-SYMBOL-ERROR - SYSTEM:%COMPILED-FUNCTION-NAME ONE-INDEX-DFUN-INFO-INDEX - TYPE-FROM-SPECIALIZER MAP-SPECIALIZERS - MAKE-DOCUMENTED-STD-WRITER-METHOD-FUNCTION - NON-PCL-OR-AFTER-INITIALIZE-INSTANCE-METHODS-P - ACCESSOR-DFUN-INFO-ACCESSOR-TYPE ECD-CANONICAL-SLOTS - STRUCTURE-SLOT-BOUNDP PROCLAIM-INCOMPATIBLE-SUPERCLASSES - UN-THE MAKE-WRAPPER |LAP Operand USER-SLOTS| - |LAP Operand CONSTANT| SLOT-READER-UNDEFINED - USE-DISPATCH-DFUN-P METHOD-LL->GENERIC-FUNCTION-LL - LIST-LARGE-CACHE - MAKE-FUNCALLABLE-STANDARD-INSTANCE-READER-METHOD-FUNCTION - CONSTANT-VALUE-P GF-INFO-SIMPLE-ACCESSOR-TYPE - SLOT-BOUNDP-UNDEFINED WRAPPER-FOR-STRUCTURE - MAKE-STRUCTURE-INSTANCE-BOUNDP-METHOD-FUNCTION - GF-DFUN-CACHE COPY-CACHE ECD-SOURCE CLASS-OF - EARLY-CLASS-SLOTS MAKE-NOT-FOR-CACHING-METHOD-FUNCTION - USE-CACHING-DFUN-P INDEX->INDEX-VALUE - BUILT-IN-OR-STRUCTURE-WRAPPER-FUN FGEN-GENERATOR - EARLY-UPDATE-DISCRIMINATOR-CODE COUNT-DFUN ONE-CLASS-P - NON-PCL-INITIALIZE-INSTANCE-METHODS-P - MAKE-DOCUMENTED-STD-BOUNDP-METHOD-FUNCTION SETFBOUNDP - |LAP Operand FSC-WRAPPER|)) + PCL::UPDATE-INITIALIZE-INFO PCL::CPD-SUPERS + WALKER::ENV-WALK-FORM WALKER::ENV-WALK-FUNCTION + PCL::DEFAULT-SECONDARY-DISPATCH-FUNCTION PCL::CPD-AFTER + PCL::EARLY-CLASS-DEFINITION WALKER::GET-WALKER-TEMPLATE + PCL::GET-PV-CELL-FOR-CLASS ITERATE::SEQUENCE-ACCESSOR + PCL::CPD-COUNT PCL::%SYMBOL-FUNCTION PCL::%CCLOSURE-ENV + PCL::EARLY-CLASS-PRECEDENCE-LIST + PCL::INFORM-TYPE-SYSTEM-ABOUT-STD-CLASS + PCL::MAKE-INITFUNCTION PCL::DFUN-INFO-P PCL::ECD-CLASS-NAME + PCL::DISPATCH-P PCL::CANONICAL-SLOT-NAME + PCL::EARLY-CLASS-SLOTS PCL::EARLY-COLLECT-CPL + PCL::EARLY-COLLECT-SLOTS PCL::DEFAULT-METHOD-ONLY-P + PCL::METHODS-CONTAIN-EQL-SPECIALIZER-P + PCL::EARLY-COLLECT-DEFAULT-INITARGS + PCL::ECD-SUPERCLASS-NAMES PCL::ECD-CANONICAL-SLOTS + PCL::UNENCAPSULATED-FDEFINITION PCL::ECD-OTHER-INITARGS + PCL::FAST-METHOD-CALL-ARG-INFO PCL::MAKE-INITIAL-DFUN + PCL::ACCESSOR-DFUN-INFO-P PCL::ECD-SOURCE + PCL::ECD-METACLASS PCL::MAKE-TYPE-PREDICATE + PCL::ONE-INDEX-DFUN-INFO-P PCL::EARLY-CLASS-NAME-OF + PCL::UNPARSE-TYPE-LIST PCL::EARLY-CLASS-DIRECT-SUBCLASSES + PCL::N-N-P PCL::SLOT-READER-SYMBOL PCL::SLOT-WRITER-SYMBOL + PCL::SLOT-BOUNDP-SYMBOL + PCL::MAKE-STRUCTURE-SLOT-BOUNDP-FUNCTION PCL::ONE-CLASS-P + PCL::MAKE-OPTIMIZED-STRUCTURE-SLOT-VALUE-USING-CLASS-METHOD-FUNCTION + PCL::GBOUNDP + PCL::MAKE-OPTIMIZED-STRUCTURE-SETF-SLOT-VALUE-USING-CLASS-METHOD-FUNCTION + PCL::GMAKUNBOUND + PCL::MAKE-OPTIMIZED-STRUCTURE-SLOT-BOUNDP-USING-CLASS-METHOD-FUNCTION + PCL::CLASS-PRECEDENCE-DESCRIPTION-P PCL::TWO-CLASS-P + PCL::EXPAND-LONG-DEFCOMBIN PCL::STRUCTURE-SLOT-BOUNDP + PCL::ONE-INDEX-P PCL::CHECKING-P + PCL::MAKE-DEFAULT-METHOD-GROUP-DESCRIPTION + SYSTEM:%STRUCTURE-NAME PCL::INITIALIZE-INTERNAL-SLOT-GFS + SYSTEM:%COMPILED-FUNCTION-NAME PCL::CACHING-P + PCL::EXPAND-SHORT-DEFCOMBIN + PCL::USE-DEFAULT-METHOD-ONLY-DFUN-P + PCL::METHOD-FUNCTION-FROM-FAST-FUNCTION + PCL::KEYWORD-SPEC-NAME PCL:CLASS-OF + PCL::GENERIC-CLOBBERS-FUNCTION PCL::FUNCTION-RETURNING-NIL + PCL::EARLY-METHOD-LAMBDA-LIST PCL::DO-STANDARD-DEFSETF-1 + PCL::EARLY-GF-P PCL::PARSE-SPECIALIZERS PCL::TYPE-CLASS + PCL::MAKE-CALL-METHODS PCL::EARLY-METHOD-QUALIFIERS + PCL::CLASS-PREDICATE PCL::LEGAL-CLASS-NAME-P + PCL::MAKE-CLASS-EQ-PREDICATE PCL::STRUCTURE-TYPE-P + PCL::MAKE-EQL-PREDICATE + PCL::EARLY-METHOD-STANDARD-ACCESSOR-P + PCL::NEXT-WRAPPER-FIELD PCL::GET-BUILT-IN-CLASS-SYMBOL + PCL::GET-BUILT-IN-WRAPPER-SYMBOL PCL::UNPARSE-SPECIALIZERS + PCL::SETFBOUNDP PCL::GET-SETF-FUNCTION-NAME + PCL::METHOD-CALL-CALL-METHOD-ARGS SYSTEM::NEXT-STACK-FRAME + PCL::INITIALIZE-INFO-P PCL::WRAPPER-OF + PCL::FAST-METHOD-CALL-PV-CELL PCL::CHECK-WRAPPER-VALIDITY + PCL::FAST-METHOD-CALL-NEXT-METHOD-CALL PCL::INITIAL-P + PCL::DEFAULT-TEST-CONVERTER PCL::COMPUTE-STD-CPL-PHASE-2 + PCL::DFUN-INFO-CACHE PCL::DEFAULT-CONSTANT-CONVERTER + WALKER:VARIABLE-GLOBALLY-SPECIAL-P PCL::NO-METHODS-CACHE + PCL::INITIAL-CACHE PCL::LIST-DFUN + PCL::INITIAL-DISPATCH-CACHE PCL::STRUCTURE-OBJECT-P + PCL::LIST-LARGE-CACHE PCL::DEFAULT-CONSTANTP + PCL::INITIAL-DISPATCH-P PCL::DISPATCH-CACHE PCL::COUNT-DFUN + PCL::FGEN-TEST PCL::DEFAULT-METHOD-ONLY-CACHE + PCL::LOOKUP-FGEN PCL::ACCESSOR-DFUN-INFO-CACHE)) (PROCLAIM - '(FTYPE (FUNCTION (T *) *) COMPILE-LAMBDA EXTRACT-DECLARATIONS - OPCODE GET-FUNCTION OPERAND PARSE-METHOD-OR-SPEC - MAKE-FINAL-DFUN-INTERNAL PARSE-SPECIALIZED-LAMBDA-LIST - GET-FUNCTION1 MAP-ALL-CLASSES MAKE-CACHING-DFUN - MAKE-CONSTANT-VALUE-DFUN WALK-FORM ENSURE-GENERIC-FUNCTION)) + '(FTYPE (FUNCTION (T *) *) PCL::GET-FUNCTION PCL::GET-FUNCTION1 + PCL:ENSURE-CLASS PCL::MAKE-METHOD-FUNCTION-INTERNAL + PCL::PARSE-SPECIALIZED-LAMBDA-LIST + PCL::MAKE-METHOD-LAMBDA-INTERNAL + PCL::GET-MAKE-INSTANCE-FUNCTION + PCL::GET-GENERIC-FUNCTION-INFO PCL::PARSE-METHOD-OR-SPEC + PCL::COMPILE-LAMBDA PCL::GET-DFUN-CONSTRUCTOR + PCL::MAKE-CACHING-DFUN PCL::MAKE-CONSTANT-VALUE-DFUN + PCL::MAKE-FINAL-DFUN-INTERNAL PCL::COERCE-TO-CLASS + PCL::MAP-ALL-CLASSES PCL:ENSURE-GENERIC-FUNCTION + PCL::GET-METHOD-FUNCTION PCL::EXTRACT-DECLARATIONS + WALKER:WALK-FORM WALKER:MACROEXPAND-ALL)) +(PROCLAIM '(FTYPE (FUNCTION (T T *) (VALUES T T)) PCL::SYMBOL-APPEND)) +(PROCLAIM '(FTYPE (FUNCTION (T *) STRING) PCL::CAPITALIZE-WORDS)) (PROCLAIM - '(FTYPE (FUNCTION (T (VECTOR T)) T) ALLOCATE-FUNCALLABLE-INSTANCE)) -(PROCLAIM '(FTYPE (FUNCTION (T T *) (VALUES T T)) SYMBOL-APPEND)) + '(FTYPE (FUNCTION (T T) *) PCL::COMPUTE-TEST + PCL::GET-NEW-FUNCTION-GENERATOR-INTERNAL PCL::COMPUTE-CODE + PCL::FIND-SUPERCLASS-CHAIN + PCL::GENERATE-FAST-CLASS-SLOT-ACCESS-P + PCL::MUTATE-SLOTS-AND-CALLS PCL::ENSURE-CLASS-VALUES + PCL::MAKE-DIRECT-SLOTD PCL::EMIT-DEFAULT-ONLY-FUNCTION + PCL::EMIT-DEFAULT-ONLY PCL::SPLIT-DECLARATIONS + PCL::SLOT-NAME-LISTS-FROM-SLOTS PCL::EMIT-CHECKING + PCL::EMIT-CACHING PCL::UPDATE-SLOT-VALUE-GF-INFO + PCL::SET-FUNCTION-NAME PCL::SDFUN-FOR-CACHING + ITERATE::PARSE-DECLARATIONS + PCL::COMPUTE-APPLICABLE-METHODS-USING-TYPES + PCL::INITIALIZE-INSTANCE-SIMPLE-FUNCTION + PCL::FORM-LIST-TO-LISP PCL::CHECK-INITARGS-VALUES + PCL::*SUBTYPEP PCL::CLASS-APPLICABLE-USING-CLASS-P + PCL::SAUT-AND PCL::SAUT-NOT PCL::SAUT-CLASS + PCL::SAUT-PROTOTYPE PCL::SAUT-CLASS-EQ PCL::SAUT-EQL + PCL::SPECIALIZER-APPLICABLE-USING-TYPE-P PCL::*TYPEP + COMPILER::CAN-USE-PRINT-CIRCLE-P1 PCL::DESTRUCTURE + PCL::INVOKE-EMF PCL:SLOT-BOUNDP PCL:SLOT-EXISTS-P + PCL:SLOT-MAKUNBOUND PCL:SLOT-VALUE + PCL::COMPUTE-STD-CPL-PHASE-1 PCL::SLOT-UNBOUND-INTERNAL)) (PROCLAIM - '(FTYPE (FUNCTION (T *) T) FIND-CLASS ITERATE::FUNCTION-LAMBDA-P - ITERATE::MAYBE-WARN PRECOMPUTE-EFFECTIVE-METHODS - LAP-OPERANDS MAKE-SPECIALIZABLE WALKER::RELIST - LAMBDA-LIST-LEGAL-P MAKE-TYPE-PREDICATE-NAME - COERCE-TO-CLASS FIND-STRUCTURE-CLASS MAKE-FINAL-DFUN - GET-METHOD-FUNCTION COMPILE-LAMBDA-DEFERRED - NO-NEXT-METHOD-TRAP WALKER::RELIST* GET-DFUN-CONSTRUCTOR - FIND-CLASS-PREDICATE EARLY-METHOD-SPECIALIZERS UPDATE-DFUN - WALKER::WALKER-ENVIRONMENT-BIND-1 SET-DFUN FIND-CLASS-CELL - CAPITALIZE-WORDS COMPILE-LAMBDA-UNCOMPILED ENSURE-CLASS)) + '(FTYPE (FUNCTION (T *) T) PCL::PV-TABLE-LOOKUP-PV-ARGS + WALKER::RELIST* WALKER::RELIST PCL::FIND-CLASS-PREDICATE + PCL::EXPAND-MAKE-INSTANCE-FORM PCL::SET-DFUN + PCL::MAKE-WRAPPER PCL::MAKE-SPECIALIZABLE + PCL::MAKE-FINAL-DFUN WALKER::WALKER-ENVIRONMENT-BIND-1 + PCL::USE-DISPATCH-DFUN-P PCL::ALLOCATE-STRUCTURE-INSTANCE + PCL::ALLOCATE-STANDARD-INSTANCE ITERATE::FUNCTION-LAMBDA-P + ITERATE::MAYBE-WARN PCL::REAL-USE-DISPATCH-DFUN-P + PCL::MAKE-TYPE-PREDICATE-NAME PCL::USE-CONSTANT-VALUE-DFUN-P + PCL::ALLOCATE-FUNCALLABLE-INSTANCE + PCL::GET-MAKE-INSTANCE-FUNCTIONS PCL:FIND-CLASS + PCL::EARLY-METHOD-SPECIALIZERS + PCL::INITIALIZE-METHOD-FUNCTION PCL::TRACE-METHOD + PCL::UPDATE-DFUN PCL::FIND-CLASS-CELL)) (PROCLAIM - '(FTYPE (FUNCTION (T T) *) SLOT-VALUE ITERATE::PARSE-DECLARATIONS - EMIT-WRAPPER-REF *SUBTYPEP SDFUN-FOR-CACHING SAUT-OR-P - EMIT-CHECKING SAUT-CLASS-EQ-P SAUT-NOT-P COMPUTE-CODE - EARLY-DFUN FIND-SUPERCLASS-CHAIN COMPUTE-TEST SAUT-EQL-P - DESTRUCTURE SAUT-CLASS-P SET-FUNCTION-NAME UPDATE-INITS - CLASS-APPLICABLE-USING-CLASS-P EMIT-CACHING - EMIT-CACHE-VECTOR-REF GET-NEW-FUNCTION-GENERATOR-INTERNAL - SPECIALIZER-APPLICABLE-USING-TYPE-P INITIAL-DFUN - ENSURE-CLASS-VALUES SAUT-AND-P COMPUTE-STD-CPL-PHASE-1 - COMPUTE-APPLICABLE-METHODS-USING-TYPES)) + '(FTYPE (FUNCTION (T T T) (*)) PCL::SORT-APPLICABLE-METHODS + PCL::SORT-METHODS)) (PROCLAIM - '(FTYPE (FUNCTION (T T) T) REMOVE-METHOD SLOT-BOUNDP SLOT-EXISTS-P - SLOT-MAKUNBOUND SYSTEM::DISPLAY-ENV - SYSTEM::DISPLAY-COMPILED-ENV - |LAP Opcode BUILT-IN-INSTANCE-P| - LOAD-DEFINE-CONSTRUCTOR-CODE-TYPE |LAP Opcode IZEROP| - ACCESSOR-MISS-FUNCTION BOOTSTRAP-SLOT-INDEX - %SET-CCLOSURE-ENV PARSE-QUALIFIER-PATTERN - METHOD-FUNCTION-GET |LAP Operand I-| - MAKE-EFFECTIVE-METHOD-FUNCTION1 - |LAP Opcode STRUCTURE-INSTANCE-P| - SET-METHOD-FUNCTION-METHOD WALKER::ENVIRONMENT-FUNCTION - SUPERCLASSES-COMPATIBLE-P WALKER::ENVIRONMENT-MACRO - CLASSES-HAVE-COMMON-SUBCLASS-P *TYPEP - GENERATE-FAST-CLASS-SLOT-ACCESS-P - |LAP Opcode FSC-INSTANCE-P| LOAD-DEFOPCODE UPDATE-CLASS - SLOW-SLOT-VALUE |LAP Opcode MOVE| VARIABLE-CLASS SET-SLOTS - NET-CONSTANT-CONVERTER MAKE-DFUN-LAMBDA-LIST - METHODS-CONVERTER ADD-ARG-INFO |LAP Operand IREF| - |SETF PCL FIND-CLASS| |LAP Operand ISHIFT| PERMUTATION-P - SLOT-WRITER-UNDEFINED COMPUTE-APPLICABLE-METHODS-FUNCTION - WALKER::VARIABLE-SYMBOL-MACRO-P USER-INSTANCE-ACCESS - QUALIFIER-CHECK-RUNTIME |LAP Operand ILOGAND| - MAKE-EFFECTIVE-METHOD-FUNCTION-SIMPLE - MAKE-EFFECTIVE-METHOD-FUNCTION-INTERNAL - MAKE-OPTIMIZED-USER-READER-METHOD-FUNCTION - FIND-SLOT-DEFINITION CANONICALIZE-SLOT-SPECIFICATION - ITERATE::SIMPLE-EXPAND-ITERATE-FORM FOUND-UNKNOWN-CLASS - CANONICALIZE-DEFCLASS-OPTION ITERATE::MV-SETQ - ITERATE::EXTRACT-SPECIAL-BINDINGS N-N-DFUN-INFO - MEC-ALL-CLASSES-INTERNAL AUGMENT-TYPE WRAPPER-STATE-TRAP - SET-WRAPPER |LAP Opcode USER-INSTANCE-P| - SET-USER-INSTANCE-WRAPPER REMOVE-DIRECT-SUBCLASSES - SET-USER-INSTANCE-SLOTS FDEFINE-CAREFULLY - |SETF PCL METHOD-FUNCTION-PLIST| MAKE-PLIST - REMOVE-SLOT-ACCESSORS CLASS-MIGHT-PRECEDE-P - WALKER::NOTE-DECLARATION DOCTOR-DFUN-FOR-THE-DEBUGGER - SET-STANDARD-SVUC-METHOD LOAD-DEFOPERAND REDEFINE-MACRO - DOCUMENTED-FUNCTION-RETURNING-NIL |LAP Operand I+| - COMPUTE-INITARG-POSITIONS - COMPUTE-SECONDARY-DISPATCH-FUNCTION1 - NEW-ARG-INFO-FROM-METHOD SET-GET-METHOD-FROM-IDENTIFIER - TREE-MEMQ-P MEC-ALL-CLASS-LISTS |SETF PCL GDEFINITION| - REAL-ADD-METHOD MAKE-DLAP-LAMBDA-LIST - FUNCALLABLE-STANDARD-INSTANCE-ACCESS CPL-INCONSISTENT-ERROR - REAL-REMOVE-METHOD EARLY-SORT-METHODS COMPUTE-CONSTANTS - REMTAIL RAISE-METATYPE CLASS-ON-CLASS-PRECEDENCE-LIST-P - ADD-DIRECT-SUBCLASSES ADD-SLOT-ACCESSORS - CLASS-CAN-PRECEDE-P REMOVE-ARG-INFO VARIABLE-LEXICAL-P - |LAP Operand CREF| VARIABLE-SPECIAL-P COMPUTE-STD-CPL - DO-SATISFIES-DEFTYPE |LAP Operand ILOGXOR| - WALKER::NOTE-LEXICAL-BINDING - ACCESSOR-METHODS-SAFE-TO-USE-SLOT-WRAPPER-OPTIMIZATIONS-P - |LAP Opcode STD-INSTANCE-P| LIST-EQ - SET-FUNCALLABLE-INSTANCE-FUNCTION VALUE-FOR-CACHING - MEC-ALL-CLASSES SAUT-NOT-CLASS-P SAUT-NOT-CLASS-EQ-P - SET-FUNCTION-PRETTY-ARGLIST REDEFINE-FUNCTION - SET-STRUCTURE-SVUC-METHOD SAUT-NOT-EQL-P NPERMUTATION-P - DEAL-WITH-ARGUMENTS-OPTION UPDATE-SLOT-VALUE-GF-INFO - UPDATE-CPL PRINTING-RANDOM-THING-INTERNAL - CPL-FORWARD-REFERENCED-CLASS-ERROR CHECKING-DFUN-INFO - SLOW-SLOT-BOUNDP STANDARD-INSTANCE-ACCESS - UPDATE-STD-OR-STR-METHODS DESTRUCTURE-INTERNAL - WALKER::WALK-REPEAT-EVAL SYSTEM:%SET-COMPILED-FUNCTION-NAME - MAKE-DISCRIMINATING-FUNCTION-ARGLIST - |SETF PCL FIND-CLASS-PREDICATE| MAKE-UNORDERED-METHODS-EMF - SLOT-VALUES-SAFE-USING-CLASS-P - DOCUMENTED-FUNCTION-RETURNING-T PROCLAIM-DEFGENERIC - ADD-METHOD)) -(PROCLAIM '(FTYPE (FUNCTION NIL FIXNUM) GET-WRAPPER-CACHE-NUMBER)) + '(FTYPE (FUNCTION (T T) T) PCL::CPL-INCONSISTENT-ERROR + WALKER::NOTE-DECLARATION WALKER::NOTE-LEXICAL-BINDING + PCL::MAKE-PV-TABLE-INTERNAL PCL::FIND-SLOT-DEFINITION + WALKER::ENVIRONMENT-FUNCTION PCL::|SETF PCL FIND-CLASS| + PCL::|SETF PCL FIND-CLASS-PREDICATE| + PCL::COMPUTE-EMF-FROM-WRAPPERS PCL::COMPUTE-PV + PCL::COMPUTE-CALLS PCL::UPDATE-ALL-PV-TABLE-CACHES + PCL::MAP-PV-TABLE-REFERENCES-OF + PCL::GF-MAKE-FUNCTION-FROM-EMF PCL::PLIST-VALUE + PCL::ADD-DIRECT-SUBCLASSES PCL::UPDATE-CLASS + PCL::MAKE-CLASS-PREDICATE PCL::ADD-SLOT-ACCESSORS + PCL::SYMBOL-LESSP PCL::REDEFINE-FUNCTION + PCL::METHOD-FUNCTION-RETURNING-NIL + PCL::REMOVE-DIRECT-SUBCLASSES + PCL::METHOD-FUNCTION-RETURNING-T PCL::SYMBOL-OR-CONS-LESSP + PCL::REMOVE-SLOT-ACCESSORS + PCL:FUNCALLABLE-STANDARD-INSTANCE-ACCESS + PCL::PV-TABLE-LOOKUP PCL::UPDATE-CPL + PCL::PV-WRAPPERS-FROM-ALL-ARGS PCL::UPDATE-SLOTS + PCL::UPDATE-INITS PCL::EMIT-1-NIL-DLAP + PCL::EMIT-1-WRAPPER-COMPUTE-PRIMARY-CACHE-LOCATION + PCL::COMPUTE-LAYOUT + PCL::EMIT-N-WRAPPER-COMPUTE-PRIMARY-CACHE-LOCATION + PCL::GET-MAKE-INSTANCE-FUNCTION-KEY + PCL::CHANGE-CLASS-INTERNAL PCL::NEW-ARG-INFO-FROM-METHOD + PCL::ADD-ARG-INFO PCL::REMOVE-ARG-INFO + PCL:SET-FUNCALLABLE-INSTANCE-FUNCTION PCL::LIST-EQ + PCL::COMPUTE-APPLICABLE-METHODS-FUNCTION + PCL::UPDATE-INITIALIZE-INFO-INTERNAL + PCL::PV-WRAPPERS-FROM-ALL-WRAPPERS + PCL::UPDATE-STD-OR-STR-METHODS + PCL::SET-STANDARD-SVUC-METHOD + PCL::SET-STRUCTURE-SVUC-METHOD + PCL::|SETF PCL METHOD-FUNCTION-PLIST| + PCL::MEC-ALL-CLASSES-INTERNAL PCL::MEC-ALL-CLASSES + PCL::MEC-ALL-CLASS-LISTS PCL:STANDARD-INSTANCE-ACCESS + PCL::DESCRIBE-PACKAGE PCL::METHODS-CONVERTER + PCL::RAISE-METATYPE + PCL::MAKE-DISCRIMINATING-FUNCTION-ARGLIST + PCL::|SETF PCL GDEFINITION| PCL::NET-CONSTANT-CONVERTER + PCL::AUGMENT-TYPE PCL::SET-FUNCTION-PRETTY-ARGLIST + PCL::DOCTOR-DFUN-FOR-THE-DEBUGGER PCL::VALUE-FOR-CACHING + PCL::ACCESSOR-MISS-FUNCTION PCL::MAKE-UNORDERED-METHODS-EMF + PCL::FIND-STANDARD-II-METHOD PCL::N-N-DFUN-INFO + PCL::CHECKING-DFUN-INFO + PCL::CPL-FORWARD-REFERENCED-CLASS-ERROR + PCL::MAKE-DFUN-LAMBDA-LIST PCL::MAKE-DLAP-LAMBDA-LIST + WALKER::ENVIRONMENT-MACRO PCL::MAKE-DFUN-ARG-LIST + PCL::MAKE-FAST-METHOD-CALL-LAMBDA-LIST ITERATE::MV-SETQ + ITERATE::EXTRACT-SPECIAL-BINDINGS + WALKER::VARIABLE-SYMBOL-MACRO-P PCL::ADD-FORMS + PCL::SET-WRAPPER PCL::BOOTSTRAP-SLOT-INDEX + PCL::CLASS-CAN-PRECEDE-P PCL::SWAP-WRAPPERS-AND-SLOTS + PCL::ADD-TO-CVECTOR PCL::SAUT-NOT-CLASS + PCL::CANONICALIZE-SLOT-SPECIFICATION PCL::SAUT-NOT-CLASS-EQ + PCL::CANONICALIZE-DEFCLASS-OPTION PCL::SAUT-NOT-PROTOTYPE + WALKER::WALK-REPEAT-EVAL PCL::%SET-CCLOSURE-ENV + PCL::SAUT-NOT-EQL PCL::SUPERCLASSES-COMPATIBLE-P + ITERATE::SIMPLE-EXPAND-ITERATE-FORM + PCL::CLASSES-HAVE-COMMON-SUBCLASS-P PCL::FDEFINE-CAREFULLY + PCL::CLASS-MIGHT-PRECEDE-P PCL::NO-SLOT + PCL::DO-SATISFIES-DEFTYPE PCL::QUALIFIER-CHECK-RUNTIME + PCL::DEAL-WITH-ARGUMENTS-OPTION + PCL::MAKE-INTERNAL-READER-METHOD-FUNCTION + PCL::PARSE-QUALIFIER-PATTERN + PCL::MAKE-STD-READER-METHOD-FUNCTION + PCL::MAKE-STD-WRITER-METHOD-FUNCTION + PCL::MAKE-STD-BOUNDP-METHOD-FUNCTION + SYSTEM:%SET-COMPILED-FUNCTION-NAME PCL:ADD-METHOD + SYSTEM::DISPLAY-ENV PCL::PRINTING-RANDOM-THING-INTERNAL + SYSTEM::DISPLAY-COMPILED-ENV PCL::PROCLAIM-DEFGENERIC + PCL::COMPUTE-STD-CPL PCL::MAKE-PLIST PCL::REMTAIL + PCL::MEMF-CONSTANT-CONVERTER PCL::DESTRUCTURE-INTERNAL + PCL:REMOVE-METHOD PCL::STANDARD-COMPUTE-EFFECTIVE-METHOD + PCL::SET-METHODS PCL::VARIABLE-CLASS PCL::MAKE-CAXR + PCL::MAKE-CDXR PCL::REDIRECT-EARLY-FUNCTION-INTERNAL + WALKER:VARIABLE-LEXICAL-P WALKER:VARIABLE-SPECIAL-P + PCL::REAL-REMOVE-METHOD PCL::COMPUTE-CONSTANTS)) +(PROCLAIM '(FTYPE (FUNCTION NIL FIXNUM) PCL::GET-WRAPPER-CACHE-NUMBER)) (IN-PACKAGE "PCL") -(DOLIST (V '(COMPUTE-INSTANCE-LAYOUT |(WRITER DIRECT-DEFAULT-INITARGS)| - ADD-READER-METHOD - SHORT-COMBINATION-IDENTITY-WITH-ONE-ARGUMENT - SLOT-DEFINITION-INITFUNCTION-SIDE-EFFECT-FREE-P - |DEFINITION-SOURCE-MIXIN class predicate| - REMOVE-READER-METHOD |(WRITER INTERNAL-SLOTDS)| - CLASS-FROM-DEFCLASS-P MAKE-CLOSURE-GENERATOR-FORM - EQL-SPECIALIZER-P |(SETF GENERIC-FUNCTION-NAME)| - OBJECT-PLIST SLOT-DEFINITION-DEFSTRUCT-ACCESSOR-SYMBOL - METHOD-IDENTIFIER - MAKE-DOCUMENTED-BOUNDP-METHOD-FUNCTION - MAKE-DOCUMENTED-READER-METHOD-FUNCTION - MAKE-DOCUMENTED-WRITER-METHOD-FUNCTION SPECIALIZER-TYPE - GF-DFUN-STATE |(SETF GENERIC-FUNCTION-METHOD-CLASS)| - |(SETF GENERIC-FUNCTION-METHOD-COMBINATION)| - CLASS-DEFSTRUCT-CONSTRUCTOR DEPENDENT - |(SETF GENERIC-FUNCTION-METHODS)| TRACE-METHOD - STORE-CLOSURE-GENERATOR-P |(SETF GF-PRETTY-ARGLIST)| - METHOD-OPTIMIZED-FUNCTION SPECIALIZERP - EXACT-CLASS-SPECIALIZER-P - |STANDARD-OBJECT class predicate| - COMPATIBLE-META-CLASS-CHANGE-P - |(BOUNDP READER-FUNCTION)| |(BOUNDP PREDICATE-NAME)| - |(BOUNDP READERS)| UPDATE-GF-DFUN - |(BOUNDP DEFSTRUCT-CONC-NAME)| - |(BOUNDP CLASS-PRECEDENCE-LIST)| - |(BOUNDP ACCESSOR-FLAGS)| - |STANDARD-EFFECTIVE-SLOT-DEFINITION class predicate| - CONSTRUCTOR-SUPPLIED-INITARG-NAMES |(BOUNDP LOCATION)| - |(BOUNDP DOCUMENTATION)| SPECIALIZER-OBJECT - |(BOUNDP CACHED-FUNCTIONS-ALIST)| - |(BOUNDP INCOMPATIBLE-SUPERCLASS-LIST)| - ACCESSOR-METHOD-SLOT-NAME |(BOUNDP DECLARATIONS)| - |(BOUNDP CACHED-IN-GENERIC-FUNCTIONS)| - |(BOUNDP SPECIALIZERS)| - |STANDARD-DIRECT-SLOT-DEFINITION class predicate| - |(BOUNDP IDENTIFIER)| SPECIALIZER-CLASS - |(BOUNDP PRETTY-ARGLIST)| - |(SETF SLOT-DEFINITION-DEFSTRUCT-ACCESSOR-SYMBOL)| - CLASS-EQ-SPECIALIZER-P |(BOUNDP NEEDS-NEXT-METHODS-P)| - SLOTS-FETCHER |(SETF SLOT-ACCESSOR-STD-P)| - |(BOUNDP INITFUNCTION-SIDE-EFFECT-FREE-P)| - |STANDARD-SLOT-DEFINITION class predicate| - REMOVE-WRITER-METHOD |(BOUNDP WRITER-FUNCTION)| - |(BOUNDP INITFUNCTION)| STRUCTURE-CLASS-P - |(BOUNDP WRITERS)| |(BOUNDP INITFORM)| - |(BOUNDP FUNCTION-NAME)| UPDATE-CONSTRUCTORS - |(BOUNDP SLOT-NAME)| BOUNDP-METHOD-CLASS COMPUTE-LAYOUT - |(SETF SLOT-DEFINITION-INITARGS)| |(BOUNDP ALLOCATION)| - CACHED-SLOT-LOCATIONS-AND-FETCHERS-FROM-WRAPPERS - DOCUMENTATION |(BOUNDP FUNCTION)| - |(BOUNDP GENERIC-FUNCTION)| - |SLOT-OBJECT class predicate| |(BOUNDP LAMBDA-LIST)| - METHOD-PRETTY-ARGLIST |(BOUNDP CAN-PRECEDE-LIST)| - |(BOUNDP PROTOTYPE)| CLASS-EQ-SPECIALIZER - INFORM-TYPE-SYSTEM-ABOUT-CLASS - |PCL-CLASS class predicate| |(BOUNDP DFUN-STATE)| - |(BOUNDP FROM-DEFCLASS-P)| |(BOUNDP INTERNAL-SLOTD)| - |(BOUNDP METHOD-CLASS)| |(READER SOURCE)| - |(BOUNDP METHOD-COMBINATION)| - |(BOUNDP OPTIMIZED-FUNCTION)| - |(BOUNDP INTERNAL-WRITER-FUNCTION)| - |(BOUNDP INTERNAL-READER-FUNCTION)| - |(BOUNDP OPTIMIZED-SLOT-INDICES)| - |(BOUNDP DIRECT-METHODS)| |(BOUNDP DIRECT-SLOTS)| - |(BOUNDP BOUNDP-FUNCTION)| - |(BOUNDP DIRECT-SUPERCLASSES)| - |(BOUNDP DIRECT-SUBCLASSES)| ADD-CACHED-FUNCTION - |(BOUNDP METHODS)| |(BOUNDP OPTIONS)| - GET-CACHED-FUNCTION GENERIC-FUNCTION-PRETTY-ARGLIST - MAKE-CONSTRUCTOR-CODE-GENERATORS |(WRITER SOURCE)| - UPDATE-SLOT-ACCESSOR-FUNCTION - |SLOT-DEFINITION class predicate| - |(METHOD NO-NEXT-METHOD (STANDARD-GENERIC-FUNCTION STANDARD-METHOD))| - MAKE-OPTIMIZED-BOUNDP-METHOD-FUNCTION - MAKE-OPTIMIZED-READER-METHOD-FUNCTION - MAKE-OPTIMIZED-WRITER-METHOD-FUNCTION - |METAOBJECT class predicate| CLASS-PREDICATE-NAME - LOAD-CONSTRUCTOR-INTERNAL DESCRIBE-OBJECT-SLOTS - STORE-OPTIMIZED-METHOD-LAMBDA-P COPY-INSTANCE-SLOTS - CLASSP |STD-CLASS class predicate| LEGAL-QUALIFIERS-P - ADD-BOUNDP-METHOD LEGAL-LAMBDA-LIST-P - |SETF PCL GENERIC-FUNCTION-NAME| - |SETF PCL METHOD-FUNCTION-NAME| LEGAL-DECLARATIONS-P - |DEPENDENT-UPDATE-MIXIN class predicate| - |(READER READER-FUNCTION)| |(READER PREDICATE-NAME)| - |(READER READERS)| |(READER DEFSTRUCT-CONC-NAME)| - |(READER CLASS-PRECEDENCE-LIST)| - |(READER ACCESSOR-FLAGS)| |(READER LOCATION)| - |(READER DOCUMENTATION)| |(SETF CLASS-SLOT-VALUE)| - |SETF PCL GF-DFUN-STATE| - |(READER CACHED-FUNCTIONS-ALIST)| - |(READER INCOMPATIBLE-SUPERCLASS-LIST)| - |(READER DECLARATIONS)| - |(READER CACHED-IN-GENERIC-FUNCTIONS)| - |(READER SPECIALIZERS)| COMPUTE-CLASS-SLOTS - |(READER IDENTIFIER)| |(READER PRETTY-ARGLIST)| - |(READER NEEDS-NEXT-METHODS-P)| - |SETF PCL SLOT-DEFINITION-NAME| |SETF PCL CLASS-NAME| - |SETF PCL SLOT-DEFINITION-INTERNAL-SLOTD| - |(WRITER READER-FUNCTION)| - |(METHOD TRACE-METHOD (STANDARD-METHOD))| - |(METHOD TRACE-METHOD (TRACED-METHOD))| - |(METHOD READER-METHOD-CLASS (FUNCALLABLE-STANDARD-CLASS STANDARD-DIRECT-SLOT-DEFINITION))| - |(METHOD READER-METHOD-CLASS (STANDARD-CLASS STANDARD-DIRECT-SLOT-DEFINITION))| - |(METHOD CHANGE-CLASS (T SYMBOL))| - |(WRITER PREDICATE-NAME)| |(WRITER READERS)| - |(READER INITFUNCTION-SIDE-EFFECT-FREE-P)| - |(METHOD UPDATE-INSTANCE-FOR-DIFFERENT-CLASS (STANDARD-OBJECT STANDARD-OBJECT))| - |(METHOD WRAPPER-FETCHER (STRUCTURE-CLASS))| - |(METHOD WRAPPER-FETCHER (FUNCALLABLE-STANDARD-CLASS))| - |(METHOD CLASS-PROTOTYPE (STRUCTURE-CLASS))| - |(METHOD CHANGE-CLASS (STANDARD-OBJECT FUNCALLABLE-STANDARD-CLASS))| - |(METHOD CHANGE-CLASS (STANDARD-OBJECT STANDARD-CLASS))| - |(METHOD CLASS-SLOT-CELLS (STD-CLASS))| - |(METHOD CLASS-CONSTRUCTORS (SLOT-CLASS))| - |(METHOD CLASS-PROTOTYPE (STD-CLASS))| - |(METHOD WRAPPER-FETCHER (STANDARD-CLASS))| - |(READER WRITER-FUNCTION)| |(READER INITFUNCTION)| - |(METHOD DOCUMENTATION (DOCUMENTATION-MIXIN))| - INITIALIZE-INTERNAL-SLOT-FUNCTIONS - |(WRITER DEFSTRUCT-CONC-NAME)| - |SETF PCL SLOT-DEFINITION-TYPE| - |(SETF METHOD-FUNCTION-NAME)| |(READER WRITERS)| - |(WRITER CLASS-PRECEDENCE-LIST)| - |(WRITER ACCESSOR-FLAGS)| |(READER INITFORM)| - METHOD-COMBINATION-P - |(METHOD SPECIALIZER-DIRECT-GENERIC-FUNCTIONS (SPECIALIZER-WITH-OBJECT))| - |(METHOD SPECIALIZER-DIRECT-METHODS (SPECIALIZER-WITH-OBJECT))| - |(WRITER LOCATION)| |(WRITER DOCUMENTATION)| - |STRUCTURE-DIRECT-SLOT-DEFINITION class predicate| - |(METHOD ACCESSOR-METHOD-SLOT-DEFINITION (STANDARD-ACCESSOR-METHOD))| - |(METHOD ACCESSOR-METHOD-SLOT-NAME (TRACED-METHOD))| - |(READER FUNCTION-NAME)| - |(METHOD SPECIALIZER-CLASS (EQL-SPECIALIZER))| - |(METHOD SPECIALIZER-METHOD-TABLE (CLASS-EQ-SPECIALIZER))| - |(METHOD SPECIALIZER-METHOD-TABLE (EQL-SPECIALIZER))| - |STRUCTURE-EFFECTIVE-SLOT-DEFINITION class predicate| - |(METHOD (SETF DOCUMENTATION) (T DOCUMENTATION-MIXIN))| - |SETF PCL GENERIC-FUNCTION-METHODS| - |SETF PCL GENERIC-FUNCTION-METHOD-COMBINATION| - |SETF PCL METHOD-GENERIC-FUNCTION| - |SETF PCL METHOD-OPTIMIZED-FUNCTION| - |(METHOD ADD-CONSTRUCTOR (SLOT-CLASS CONSTRUCTOR))| - |(METHOD ADD-DIRECT-METHOD (SPECIALIZER-WITH-OBJECT METHOD))| - |(METHOD ADD-DIRECT-METHOD (CLASS METHOD))| - |(READER SLOT-NAME)| |(WRITER CACHED-FUNCTIONS-ALIST)| - |(WRITER INCOMPATIBLE-SUPERCLASS-LIST)| - |SETF PCL SLOT-ACCESSOR-STD-P| - |(METHOD UPDATE-CONSTRUCTORS (CLASS))| - |(METHOD UPDATE-CONSTRUCTORS (SLOT-CLASS))| - |(METHOD ADD-DIRECT-SUBCLASS (CLASS CLASS))| - |(READER ALLOCATION)| - |(METHOD (SETF SLOT-DEFINITION-LOCATION) :AFTER (T STANDARD-EFFECTIVE-SLOT-DEFINITION))| - |(METHOD (SETF SLOT-DEFINITION-BOUNDP-FUNCTION) :AFTER (T EFFECTIVE-SLOT-DEFINITION))| - |(METHOD (SETF SLOT-DEFINITION-WRITER-FUNCTION) :AFTER (T EFFECTIVE-SLOT-DEFINITION))| - |(METHOD (SETF SLOT-DEFINITION-READER-FUNCTION) :AFTER (T EFFECTIVE-SLOT-DEFINITION))| - |(METHOD (SETF SLOT-VALUE-USING-CLASS) (T STD-CLASS STANDARD-OBJECT STANDARD-EFFECTIVE-SLOT-DEFINITION))| - |(METHOD (SETF SLOT-VALUE-USING-CLASS) (T STRUCTURE-CLASS STRUCTURE-OBJECT STRUCTURE-EFFECTIVE-SLOT-DEFINITION))| - |SETF PCL CONSTRUCTOR-CODE-TYPE| - |(WRITER DECLARATIONS)| - |(WRITER CACHED-IN-GENERIC-FUNCTIONS)| - |(WRITER SPECIALIZERS)| - |(METHOD SPECIALIZER-CLASS (CLASS))| - |(METHOD SPECIALIZER-DIRECT-GENERIC-FUNCTIONS (CLASS))| - |(METHOD SPECIALIZER-DIRECT-METHODS (CLASS))| - |(METHOD (SETF CLASS-NAME) (T STD-CLASS))| - |(WRITER IDENTIFIER)| |(SETF METHOD-GENERIC-FUNCTION)| - |(SETF METHOD-OPTIMIZED-FUNCTION)| - |(WRITER PRETTY-ARGLIST)| LEGAL-SPECIALIZERS-P - |SETF PCL OBJECT-PLIST| - |(METHOD REINITIALIZE-INSTANCE (SLOT-OBJECT))| - |(METHOD INITIALIZE-INSTANCE (SLOT-OBJECT))| - |(READER FUNCTION)| |(READER GENERIC-FUNCTION)| - |(WRITER NEEDS-NEXT-METHODS-P)| |(READER LAMBDA-LIST)| - INITIALIZE-ALLOCATE-STATIC-SLOT-STORAGE-COPY - |SLOT-CLASS class predicate| - |SETF PCL SLOT-DEFINITION-INITFORM| - |(SETF METHOD-CACHED-FUNCTIONS)| - |(READER CAN-PRECEDE-LIST)| - |SETF PCL GENERIC-FUNCTION-METHOD-CLASS| - |(WRITER INITFUNCTION-SIDE-EFFECT-FREE-P)| - |(READER PROTOTYPE)| |(WRITER WRITER-FUNCTION)| - |(WRITER INITFUNCTION)| - |(METHOD REINITIALIZE-INSTANCE :AFTER (STANDARD-GENERIC-FUNCTION))| - |(METHOD INITIALIZE-INSTANCE :AFTER (STANDARD-GENERIC-FUNCTION))| - |(METHOD WRITER-METHOD-CLASS (FUNCALLABLE-STANDARD-CLASS STANDARD-DIRECT-SLOT-DEFINITION))| - |(METHOD WRITER-METHOD-CLASS (STANDARD-CLASS STANDARD-DIRECT-SLOT-DEFINITION))| - |(METHOD REINITIALIZE-INSTANCE (STANDARD-METHOD))| - |(METHOD INITIALIZE-INTERNAL-SLOT-FUNCTIONS :AFTER (STRUCTURE-EFFECTIVE-SLOT-DEFINITION))| - |(METHOD INITIALIZE-INTERNAL-SLOT-FUNCTIONS :AFTER (STANDARD-EFFECTIVE-SLOT-DEFINITION))| - |(METHOD INITIALIZE-INTERNAL-SLOT-FUNCTIONS (EFFECTIVE-SLOT-DEFINITION))| - |(WRITER WRITERS)| SLOT-ACCESSOR-STD-P - CLASS-INTERNAL-SLOTDS |(WRITER INITFORM)| - |(METHOD REINITIALIZE-INSTANCE :AFTER (STRUCTURE-CLASS))| - |(METHOD INITIALIZE-ALLOCATE-STATIC-SLOT-STORAGE-COPY (STD-CLASS))| - |(METHOD REINITIALIZE-INSTANCE :AFTER (STD-CLASS))| - |(METHOD REINITIALIZE-INSTANCE :BEFORE (SLOT-CLASS))| - |(WRITER FUNCTION-NAME)| |(READER DFUN-STATE)| - |(READER FROM-DEFCLASS-P)| |SETF PCL GF-PRETTY-ARGLIST| - OPTIMIZE-INSTANCE-ACCESS - |SETF PCL SLOT-DEFINITION-LOCATION| - |SETF PCL SLOT-DEFINITION-READER-FUNCTION| - |SETF PCL SLOT-DEFINITION-WRITER-FUNCTION| - |SETF PCL SLOT-DEFINITION-BOUNDP-FUNCTION| - |SETF PCL SLOT-DEFINITION-INTERNAL-READER-FUNCTION| - |SETF PCL SLOT-DEFINITION-INTERNAL-WRITER-FUNCTION| - |SETF PCL SLOT-DEFINITION-ALLOCATION| - |SETF PCL SLOT-DEFINITION-INITFUNCTION| - |(METHOD MAKE-INSTANCES-OBSOLETE (SYMBOL))| - |(METHOD MAKE-INSTANCE (SYMBOL))| |(WRITER SLOT-NAME)| - |(BOUNDP NAME)| - |(METHOD SAME-SPECIALIZER-P (EQL-SPECIALIZER EQL-SPECIALIZER))| - |(METHOD SAME-SPECIALIZER-P (CLASS-EQ-SPECIALIZER CLASS-EQ-SPECIALIZER))| - |(METHOD SAME-SPECIALIZER-P (SPECIALIZER SPECIALIZER))| - |(READER INTERNAL-SLOTD)| - |(METHOD MAKE-DIRECT-SLOTD (STRUCTURE-CLASS))| - |(METHOD MAKE-CLASS-PROTOTYPE (STRUCTURE-CLASS))| - |(METHOD MAKE-INSTANCES-OBSOLETE (STD-CLASS))| - |(METHOD MAKE-DIRECT-SLOTD (STD-CLASS))| - |(METHOD MAKE-CLASS-PROTOTYPE (STD-CLASS))| - |(METHOD MAKE-INSTANCE (SLOT-CLASS))| - |(WRITER ALLOCATION)| CACHED-FUNCTIONS - |(READER METHOD-CLASS)| |(SETF OBJECT-PLIST)| - |(METHOD SLOTS-TO-INSPECT (SLOT-CLASS SLOT-OBJECT))| - |(METHOD ALLOCATE-INSTANCE (FUNCALLABLE-STANDARD-CLASS))| - |(METHOD VALIDATE-SUPERCLASS (FUNCALLABLE-STANDARD-CLASS STANDARD-CLASS))| - |(METHOD VALIDATE-SUPERCLASS (SLOT-CLASS FORWARD-REFERENCED-CLASS))| - |(METHOD VALIDATE-SUPERCLASS (CLASS BUILT-IN-CLASS))| - |(METHOD VALIDATE-SUPERCLASS (CLASS CLASS))| - |(METHOD ALLOCATE-INSTANCE (STRUCTURE-CLASS))| - |(METHOD ALLOCATE-INSTANCE (STANDARD-CLASS))| - |(READER METHOD-COMBINATION)| - |(READER OPTIMIZED-FUNCTION)| - |(READER INTERNAL-WRITER-FUNCTION)| - |(READER INTERNAL-READER-FUNCTION)| - METHOD-COMBINATION-OPTIONS - |(READER OPTIMIZED-SLOT-INDICES)| - |(METHOD COMPUTE-CONSTRUCTOR-CODE (SLOT-CLASS CONSTRUCTOR))| - |(METHOD REMOVE-CONSTRUCTOR (SLOT-CLASS CONSTRUCTOR))| - |(METHOD COMPUTE-DISCRIMINATING-FUNCTION (STANDARD-GENERIC-FUNCTION))| - |(METHOD COMPUTE-DISCRIMINATING-FUNCTION-ARGLIST-INFO (STANDARD-GENERIC-FUNCTION))| - |(METHOD REMOVE-DIRECT-METHOD (SPECIALIZER-WITH-OBJECT METHOD))| - |(METHOD REMOVE-DIRECT-METHOD (CLASS METHOD))| - |(READER DIRECT-METHODS)| |(READER DIRECT-SLOTS)| - |SETF PCL SLOT-DEFINITION-READERS| - |(METHOD COPY-INSTANCE-SLOTS (SLOT-OBJECT SLOT-OBJECT))| - |(METHOD SAME-SPECIALIZER-P (CLASS CLASS))| - |(METHOD COMPUTE-CLASS-PRECEDENCE-LIST (SLOT-CLASS))| - |(METHOD COMPUTE-SLOTS :AROUND (STRUCTURE-CLASS))| - |(METHOD COMPUTE-SLOTS (STRUCTURE-CLASS))| - |(METHOD COMPUTE-SLOTS :AROUND (STD-CLASS))| - |(METHOD COMPUTE-SLOTS (STD-CLASS))| - |(METHOD COMPUTE-DEFAULT-INITARGS (SLOT-CLASS))| - |(METHOD REMOVE-DIRECT-SUBCLASS (CLASS CLASS))| - |(WRITER FUNCTION)| |(WRITER GENERIC-FUNCTION)| - |STRUCTURE-OBJECT class predicate| - COMPILE-STRUCTURE-CLASS-INTERNALS - |(READER BOUNDP-FUNCTION)| |SETF PCL DOCUMENTATION| - |(READER DIRECT-SUPERCLASSES)| - |(READER DIRECT-SUBCLASSES)| - |(METHOD GENERIC-FUNCTION-PRETTY-ARGLIST (STANDARD-GENERIC-FUNCTION))| - |(METHOD FUNCTION-KEYWORDS (STANDARD-METHOD))| - |(SETF GF-VALID-P)| |(WRITER LAMBDA-LIST)| - FUNCALLABLE-STANDARD-CLASS-P |(BOUNDP CLASS)| - |(METHOD FINALIZE-INHERITANCE (STRUCTURE-CLASS))| - |(METHOD FINALIZE-INHERITANCE (STD-CLASS))| - |(METHOD SLOT-DEFINITION-ALLOCATION (STRUCTURE-SLOT-DEFINITION))| - |(METHOD SLOT-VALUE-USING-CLASS (STD-CLASS STANDARD-OBJECT STANDARD-EFFECTIVE-SLOT-DEFINITION))| - |(METHOD SLOT-BOUNDP-USING-CLASS (STD-CLASS STANDARD-OBJECT STANDARD-EFFECTIVE-SLOT-DEFINITION))| - |(METHOD SLOT-MAKUNBOUND-USING-CLASS (STD-CLASS STANDARD-OBJECT STANDARD-EFFECTIVE-SLOT-DEFINITION))| - |(METHOD SLOT-EXISTS-P-USING-CLASS (STD-CLASS STANDARD-OBJECT STANDARD-EFFECTIVE-SLOT-DEFINITION))| - |(METHOD SLOT-VALUE-USING-CLASS (STRUCTURE-CLASS STRUCTURE-OBJECT STRUCTURE-EFFECTIVE-SLOT-DEFINITION))| - |(METHOD SLOT-BOUNDP-USING-CLASS (STRUCTURE-CLASS STRUCTURE-OBJECT STRUCTURE-EFFECTIVE-SLOT-DEFINITION))| - |(METHOD SLOT-MAKUNBOUND-USING-CLASS (STRUCTURE-CLASS STRUCTURE-OBJECT STRUCTURE-EFFECTIVE-SLOT-DEFINITION))| - |(READER METHODS)| |(READER OPTIONS)| - |(WRITER CAN-PRECEDE-LIST)| - |SETF PCL SLOT-DEFINITION-CLASS| - |SETF PCL SLOT-VALUE-USING-CLASS| |(WRITER PROTOTYPE)| - |(BOUNDP TYPE)| |(BOUNDP OBJECT)| - CLASS-CAN-PRECEDE-LIST - |(METHOD SLOTS-FETCHER (STRUCTURE-CLASS))| - |(METHOD SLOTS-FETCHER (FUNCALLABLE-STANDARD-CLASS))| - |(METHOD SLOTS-FETCHER (STANDARD-CLASS))| - SLOT-ACCESSOR-FUNCTION METHOD-OPTIMIZED-METHOD-LAMBDA - METHOD-CONSTANT-VALUE |(BOUNDP PLIST)| - |SETF PCL CLASS-INCOMPATIBLE-SUPERCLASS-LIST| - |SETF PCL SLOT-DEFINITION-WRITERS| - |(WRITER DFUN-STATE)| |(WRITER FROM-DEFCLASS-P)| - |(BOUNDP SLOTS)| - |STRUCTURE-SLOT-DEFINITION class predicate| - LEGAL-METHOD-FUNCTION-P |(WRITER INTERNAL-SLOTD)| - METHOD-CACHED-FUNCTIONS - |(METHOD INSTALL-LAZY-CONSTRUCTOR-INSTALLER (CONSTRUCTOR))| - CLASS-DEFSTRUCT-CONC-NAME |(WRITER METHOD-CLASS)| - |(METHOD ENSURE-CLASS-USING-CLASS (T PCL-CLASS))| - GET-METHOD |(WRITER METHOD-COMBINATION)| - |(WRITER OPTIMIZED-FUNCTION)| - |(WRITER INTERNAL-WRITER-FUNCTION)| - |(WRITER INTERNAL-READER-FUNCTION)| - |(WRITER OPTIMIZED-SLOT-INDICES)| - |(METHOD METHOD-QUALIFIERS (TRACED-METHOD))| - |(METHOD METHOD-SPECIALIZERS (TRACED-METHOD))| - |(METHOD METHOD-LAMBDA-LIST (TRACED-METHOD))| - |(METHOD METHOD-PRETTY-ARGLIST (STANDARD-METHOD))| - |(METHOD METHOD-CONSTANT-VALUE (STANDARD-METHOD))| - |(METHOD METHOD-QUALIFIERS (STANDARD-METHOD))| - |(METHOD METHOD-FUNCTION-FOR-CACHING-P (STANDARD-ACCESSOR-METHOD))| - |(METHOD METHOD-FUNCTION-FOR-CACHING-P (STANDARD-METHOD))| - |(METHOD METHOD-CACHED-FUNCTIONS (STANDARD-METHOD))| - |(WRITER DIRECT-METHODS)| |(WRITER DIRECT-SLOTS)| - |(WRITER BOUNDP-FUNCTION)| - |(WRITER DIRECT-SUPERCLASSES)| - |(WRITER DIRECT-SUBCLASSES)| - SLOT-DEFINITION-INTERNAL-SLOTD - |(METHOD BOUNDP-METHOD-CLASS (FUNCALLABLE-STANDARD-CLASS STANDARD-DIRECT-SLOT-DEFINITION))| - |(METHOD BOUNDP-METHOD-CLASS (STANDARD-CLASS STANDARD-DIRECT-SLOT-DEFINITION))| - |(WRITER METHODS)| |(WRITER OPTIONS)| - SHORT-METHOD-COMBINATION-P GF-ARG-INFO - |(METHOD RAW-INSTANCE-ALLOCATOR (FUNCALLABLE-STANDARD-CLASS))| - |(METHOD RAW-INSTANCE-ALLOCATOR (STANDARD-CLASS))| - SEQUENCEP SPECIALIZER-METHOD-TABLE - |(METHOD MAYBE-UPDATE-CONSTRUCTORS (GENERIC-FUNCTION METHOD))| - METHOD-CLOSURE-GENERATOR REMOVE-CONSTRUCTOR - GF-PRETTY-ARGLIST SAME-SPECIALIZER-P CONSTRUCTOR-NAME - DO-DEFSTRUCT-FROM-DEFCLASS - SLOT-DEFINITION-BOUNDP-FUNCTION - SLOT-DEFINITION-WRITER-FUNCTION - SLOT-DEFINITION-READER-FUNCTION - SLOT-DEFINITION-INTERNAL-WRITER-FUNCTION - SLOT-DEFINITION-INTERNAL-READER-FUNCTION - CONSTRUCTOR-CODE-TYPE - MAKE-CACHED-METHOD-LAMBDA-FROM-STORED-LAMBDA - MAKE-CACHED-METHOD-FUNCTION-FROM-STORED-LAMBDA - METHOD-OPTIMIZED-SLOT-INDICES ADD-CONSTRUCTOR - SLOT-DEFINITION-CLASS GET-CONSTRUCTOR - EQL-SPECIALIZER-OBJECT CLASS-CONSTRUCTORS - STORE-METHOD-FUNCTION-P - STORE-METHOD-OPTIMIZED-FUNCTION-P |(BOUNDP WRAPPER)| - SLOTS-TO-INSPECT |(BOUNDP DEFSTRUCT-ACCESSOR-SYMBOL)| - SPECIALIZER-DIRECT-GENERIC-FUNCTIONS - |(BOUNDP CLASS-EQ-SPECIALIZER)| - |(SETF SLOT-DEFINITION-NAME)| ADD-WRITER-METHOD - |(BOUNDP ARGUMENT-PRECEDENCE-ORDER)| - |(BOUNDP SIDE-EFFECT-INTERNAL-SLOTDS)| - |(SETF SLOT-DEFINITION-INTERNAL-SLOTD)| - |(BOUNDP ARG-INFO)| CONSTRUCTOR-CLASS - |(SETF SLOT-DEFINITION-INITFUNCTION-SIDE-EFFECT-FREE-P)| - |(SETF SLOT-DEFINITION-CLASS)| - |(SETF SLOT-VALUE-USING-CLASS)| - |(BOUNDP DEFAULT-INITARGS)| - |(SETF SLOT-DEFINITION-ALLOCATION)| - |(SETF SLOT-DEFINITION-BOUNDP-FUNCTION)| - |(SETF SLOT-DEFINITION-INITFUNCTION)| - |(SETF SLOT-DEFINITION-INTERNAL-READER-FUNCTION)| - |(SETF SLOT-DEFINITION-INTERNAL-WRITER-FUNCTION)| - |(SETF SLOT-DEFINITION-LOCATION)| - |(SETF SLOT-DEFINITION-READER-FUNCTION)| - |(SETF SLOT-DEFINITION-WRITER-FUNCTION)| - |(BOUNDP DEFSTRUCT-CONSTRUCTOR)| - |(SETF SLOT-DEFINITION-READERS)| - |(SETF SLOT-DEFINITION-WRITERS)| - MAYBE-UPDATE-CONSTRUCTORS |(SETF SLOT-DEFINITION-TYPE)| - CONSTRUCTOR-CODE-GENERATORS - |(SETF SLOT-DEFINITION-INITFORM)| - |EFFECTIVE-SLOT-DEFINITION class predicate| - MAKE-CLASS-PROTOTYPE |(BOUNDP VALID-P)| - |(BOUNDP INITARGS)| LONG-METHOD-COMBINATION-FUNCTION - |BUILT-IN-CLASS class predicate| GENERIC-FUNCTION-P - MAKE-OPTIMIZED-METHOD-LAMBDA |(BOUNDP FINALIZED-P)| - |(BOUNDP OPTIMIZED-METHOD-LAMBDA)| |(READER NAME)| - |(BOUNDP CLOSURE-GENERATOR)| |(READER CLASS)| - |(BOUNDP DIRECT-DEFAULT-INITARGS)| LEGAL-SLOT-NAME-P - |(READER TYPE)| |(READER OBJECT)| - |(METHOD DO-DEFSTRUCT-FROM-DEFCLASS (STRUCTURE-CLASS T T T T T))| - CLASS-WRAPPER |(READER PLIST)| GF-VALID-P - |(METHOD NO-APPLICABLE-METHOD (T))| |(READER SLOTS)| - |(BOUNDP INTERNAL-SLOTDS)| |(WRITER NAME)| - DEFINITION-SOURCE DEFAULT-INITARGS |(WRITER CLASS)| - CLASS-SLOT-VALUE |(WRITER TYPE)| |(WRITER OBJECT)| - |(WRITER PLIST)| |(WRITER SLOTS)| - FORWARD-REFERENCED-CLASS-P - CLASS-SIDE-EFFECT-INTERNAL-SLOTDS - |SPECIALIZER-WITH-OBJECT class predicate| - LEGAL-QUALIFIER-P METHOD-P - |PLIST-MIXIN class predicate| MAKE-DIRECT-SLOTD - CLASS-SLOT-CELLS COMPUTE-CONSTRUCTOR-CODE - |(METHOD LOAD-CONSTRUCTOR-INTERNAL (SLOT-CLASS T T T))| - |(METHOD SHARED-INITIALIZE :AFTER (STANDARD-GENERIC-FUNCTION T))| - |(METHOD SHARED-INITIALIZE :BEFORE (STANDARD-GENERIC-FUNCTION T))| - |(METHOD READER-METHOD-CLASS (SLOT-CLASS T))| - |(METHOD SHARED-INITIALIZE :AFTER (STANDARD-METHOD T))| - |(METHOD SHARED-INITIALIZE :BEFORE (STANDARD-ACCESSOR-METHOD T))| - |(METHOD SHARED-INITIALIZE :BEFORE (STANDARD-METHOD T))| - |(METHOD SHARED-INITIALIZE :AFTER (STRUCTURE-SLOT-DEFINITION T))| - |(METHOD SHARED-INITIALIZE :AFTER (STANDARD-SLOT-DEFINITION T))| - |(METHOD SHARED-INITIALIZE :AFTER (STRUCTURE-CLASS T))| - |(METHOD SHARED-INITIALIZE :BEFORE (BUILT-IN-CLASS T))| - |(METHOD READER-METHOD-CLASS (T T))| - |(METHOD SHARED-INITIALIZE :BEFORE (CLASS T))| - |(METHOD SHARED-INITIALIZE :AFTER (STD-CLASS T))| - |(METHOD SHARED-INITIALIZE :BEFORE (STD-CLASS T))| - |(METHOD SHARED-INITIALIZE :AFTER (EQL-SPECIALIZER T))| - |(METHOD SHARED-INITIALIZE :AFTER (CLASS-EQ-SPECIALIZER T))| - |(METHOD SHARED-INITIALIZE :BEFORE (DOCUMENTATION-MIXIN T))| - |(METHOD SHARED-INITIALIZE (SLOT-OBJECT T))| - |(METHOD CLASS-SLOT-VALUE (STD-CLASS T))| - STANDARD-ACCESSOR-METHOD-P |(SETF CLASS-NAME)| - |(METHOD CACHED-SLOT-LOCATIONS-AND-FETCHERS-FROM-WRAPPERS (STANDARD-METHOD T))| - |(METHOD UPDATE-GF-DFUN (STD-CLASS T))| - |(METHOD ADD-CACHED-FUNCTION (STANDARD-METHOD T T))| - |(METHOD ADD-DEPENDENT (DEPENDENT-UPDATE-MIXIN T))| - |(METHOD ADD-BOUNDP-METHOD (SLOT-CLASS T T))| - |(METHOD ADD-WRITER-METHOD (SLOT-CLASS T T))| - |(METHOD ADD-READER-METHOD (SLOT-CLASS T T))| - |(METHOD UPDATE-SLOT-ACCESSOR-FUNCTION (EFFECTIVE-SLOT-DEFINITION T T))| - |(METHOD UPDATE-INSTANCE-FOR-REDEFINED-CLASS (STANDARD-OBJECT T T T))| - STANDARD-GENERIC-FUNCTION-P STANDARD-METHOD-P - STANDARD-READER-METHOD-P |(METHOD DOCUMENTATION (T))| - |(READER WRAPPER)| - |(METHOD (SETF DOCUMENTATION) (T T))| - |(METHOD (SETF SLOT-ACCESSOR-STD-P) (T EFFECTIVE-SLOT-DEFINITION T))| - |(METHOD (SETF CLASS-SLOT-VALUE) (T STD-CLASS T))| - |SETF PCL GF-VALID-P| - |(READER DEFSTRUCT-ACCESSOR-SYMBOL)| - |(METHOD INFORM-TYPE-SYSTEM-ABOUT-CLASS (STRUCTURE-CLASS T))| - |(METHOD EFFECTIVE-SLOT-DEFINITION-CLASS (STRUCTURE-CLASS T))| - |(METHOD INFORM-TYPE-SYSTEM-ABOUT-CLASS (STD-CLASS T))| - |(METHOD EFFECTIVE-SLOT-DEFINITION-CLASS (STD-CLASS T))| - |(METHOD DEFAULT-INITARGS (SLOT-CLASS T T))| - |(READER CLASS-EQ-SPECIALIZER)| - COMPUTE-DEFAULT-INITARGS - COMPUTE-EFFECTIVE-SLOT-DEFINITION-INITARGS - |(METHOD LEGAL-LAMBDA-LIST-P (STANDARD-GENERIC-FUNCTION T))| - |(METHOD LEGAL-DECLARATIONS-P (STANDARD-GENERIC-FUNCTION T))| - |(METHOD LEGAL-SPECIALIZER-P (STANDARD-METHOD T))| - |(METHOD LEGAL-SPECIALIZERS-P (STANDARD-METHOD T))| - |(METHOD LEGAL-SLOT-NAME-P (STANDARD-METHOD T))| - |(METHOD LEGAL-QUALIFIER-P (STANDARD-METHOD T))| - |(METHOD LEGAL-QUALIFIERS-P (STANDARD-METHOD T))| - |(METHOD LEGAL-METHOD-FUNCTION-P (STANDARD-METHOD T))| - |(METHOD LEGAL-LAMBDA-LIST-P (STANDARD-METHOD T))| - |(METHOD LEGAL-DOCUMENTATION-P (DOCUMENTATION-MIXIN T))| - |(SETF CLASS-INCOMPATIBLE-SUPERCLASS-LIST)| - |SETF PCL CLASS-SLOT-VALUE| - |(READER ARGUMENT-PRECEDENCE-ORDER)| - |(READER SIDE-EFFECT-INTERNAL-SLOTDS)| - |(METHOD PRINT-OBJECT (CONSTRUCTOR T))| - |(METHOD PRINT-OBJECT (METHOD-COMBINATION T))| - |(METHOD PRINT-OBJECT (GENERIC-FUNCTION T))| - |(METHOD WRITER-METHOD-CLASS (SLOT-CLASS T))| - |(METHOD PRINT-OBJECT (STANDARD-ACCESSOR-METHOD T))| - |(METHOD PRINT-OBJECT (STANDARD-METHOD T))| - |(METHOD PRINT-OBJECT (SLOT-DEFINITION T))| - |(METHOD PRINT-OBJECT (CLASS T))| - |(METHOD PRINT-OBJECT (T T))| - |(METHOD WRITER-METHOD-CLASS (T T))| - |(METHOD TRACE-METHOD (CONS))| |(READER ARG-INFO)| - METHOD-COMBINATION-TYPE - |SETF PCL SLOT-DEFINITION-INITFUNCTION-SIDE-EFFECT-FREE-P| - |(READER DEFAULT-INITARGS)| - CLASS-CACHED-IN-GENERIC-FUNCTIONS - |(READER DEFSTRUCT-CONSTRUCTOR)| - |(METHOD MAKE-CACHED-METHOD-LAMBDA-FROM-STORED-LAMBDA (STANDARD-METHOD T))| - |(METHOD MAKE-CONSTRUCTOR-CODE-GENERATORS (SLOT-CLASS T T T T))| - |(METHOD MAKE-CLOSURE-GENERATOR-FORM (STANDARD-GENERIC-FUNCTION STANDARD-METHOD T T))| - |(METHOD MAKE-OPTIMIZED-METHOD-LAMBDA (STANDARD-GENERIC-FUNCTION STANDARD-METHOD T T))| - |(METHOD MAKE-METHOD-LAMBDA (STANDARD-GENERIC-FUNCTION STANDARD-METHOD T T))| - |(METHOD MAKE-CACHED-METHOD-FUNCTION-FROM-STORED-LAMBDA (STANDARD-METHOD T))| - |(METHOD MAKE-OPTIMIZED-BOUNDP-METHOD-FUNCTION (FUNCALLABLE-STANDARD-CLASS T T T))| - |(METHOD MAKE-OPTIMIZED-WRITER-METHOD-FUNCTION (FUNCALLABLE-STANDARD-CLASS T T T))| - |(METHOD MAKE-OPTIMIZED-READER-METHOD-FUNCTION (FUNCALLABLE-STANDARD-CLASS T T T))| - |(METHOD MAKE-OPTIMIZED-BOUNDP-METHOD-FUNCTION (STRUCTURE-CLASS T T T))| - |(METHOD MAKE-OPTIMIZED-WRITER-METHOD-FUNCTION (STRUCTURE-CLASS T T T))| - |(METHOD MAKE-OPTIMIZED-READER-METHOD-FUNCTION (STRUCTURE-CLASS T T T))| - |(METHOD MAKE-OPTIMIZED-BOUNDP-METHOD-FUNCTION (STANDARD-CLASS T T T))| - |(METHOD MAKE-OPTIMIZED-WRITER-METHOD-FUNCTION (STANDARD-CLASS T T T))| - |(METHOD MAKE-OPTIMIZED-READER-METHOD-FUNCTION (STANDARD-CLASS T T T))| - |(METHOD MAKE-OPTIMIZED-BOUNDP-METHOD-FUNCTION (SLOT-CLASS T T T))| - |(METHOD MAKE-OPTIMIZED-WRITER-METHOD-FUNCTION (SLOT-CLASS T T T))| - |(METHOD MAKE-OPTIMIZED-READER-METHOD-FUNCTION (SLOT-CLASS T T T))| - |(METHOD MAKE-DOCUMENTED-BOUNDP-METHOD-FUNCTION (SLOT-CLASS T T T))| - |(METHOD MAKE-DOCUMENTED-WRITER-METHOD-FUNCTION (SLOT-CLASS T T T))| - |(METHOD MAKE-DOCUMENTED-READER-METHOD-FUNCTION (SLOT-CLASS T T T))| - |(WRITER WRAPPER)| STANDARD-CLASS-P - |(SETF CONSTRUCTOR-CODE-TYPE)| LEGAL-SPECIALIZER-P - |(WRITER DEFSTRUCT-ACCESSOR-SYMBOL)| - |(METHOD COMPUTE-EFFECTIVE-METHOD (GENERIC-FUNCTION LONG-METHOD-COMBINATION T))| - |(METHOD COMPUTE-EFFECTIVE-METHOD (GENERIC-FUNCTION SHORT-METHOD-COMBINATION T))| - |(METHOD COMPUTE-EFFECTIVE-METHOD (GENERIC-FUNCTION STANDARD-METHOD-COMBINATION T))| - |(METHOD COMPUTE-APPLICABLE-METHODS-USING-CLASSES (GENERIC-FUNCTION T))| - |(METHOD COMPUTE-APPLICABLE-METHODS (GENERIC-FUNCTION T))| - |(METHOD REMOVE-NAMED-METHOD (T T))| - |(METHOD COMPUTE-EFFECTIVE-SLOT-DEFINITION-INITARGS :AROUND (STRUCTURE-CLASS T))| - |(METHOD COMPUTE-EFFECTIVE-SLOT-DEFINITION (STRUCTURE-CLASS T T))| - |(METHOD COMPILE-STRUCTURE-CLASS-INTERNALS (STRUCTURE-CLASS T T T T))| - |(METHOD REMOVE-DEPENDENT (DEPENDENT-UPDATE-MIXIN T))| - |(METHOD COMPATIBLE-META-CLASS-CHANGE-P (T T))| - |(METHOD REMOVE-BOUNDP-METHOD (SLOT-CLASS T))| - |(METHOD REMOVE-WRITER-METHOD (SLOT-CLASS T))| - |(METHOD REMOVE-READER-METHOD (SLOT-CLASS T))| - |(METHOD COMPUTE-EFFECTIVE-SLOT-DEFINITION-INITARGS (SLOT-CLASS T))| - |(METHOD COMPUTE-EFFECTIVE-SLOT-DEFINITION (FUNCALLABLE-STANDARD-CLASS T T))| - |(METHOD COMPUTE-EFFECTIVE-SLOT-DEFINITION (STANDARD-CLASS T T))| - |(METHOD COMPUTE-LAYOUT (STD-CLASS T T))| - |(METHOD COMPUTE-CLASS-SLOTS (STD-CLASS T))| - |(METHOD COMPUTE-INSTANCE-LAYOUT (STD-CLASS T))| - |(METHOD COMPUTE-STORAGE-INFO (STD-CLASS T))| - COMPUTE-STORAGE-INFO |(READER VALID-P)| - |DIRECT-SLOT-DEFINITION class predicate| - METHOD-FUNCTION-NAME |(READER INITARGS)| - |(WRITER CLASS-EQ-SPECIALIZER)| - |(METHOD FIND-METHOD-COMBINATION (GENERIC-FUNCTION (EQL STANDARD) T))| - STANDARD-BOUNDP-METHOD-P METHOD-FUNCTION-FOR-CACHING - |(METHOD STORE-OPTIMIZED-METHOD-LAMBDA-P (STANDARD-GENERIC-FUNCTION STANDARD-METHOD T))| - |(METHOD STORE-CLOSURE-GENERATOR-P (STANDARD-GENERIC-FUNCTION STANDARD-METHOD T))| - |(METHOD STORE-METHOD-OPTIMIZED-FUNCTION-P (STANDARD-GENERIC-FUNCTION STANDARD-METHOD T))| - |(METHOD STORE-METHOD-FUNCTION-P (STANDARD-GENERIC-FUNCTION STANDARD-METHOD T))| - |(METHOD SLOT-UNBOUND :AROUND (CLASS T T))| - |(METHOD SLOT-ACCESSOR-STD-P (EFFECTIVE-SLOT-DEFINITION T))| - |(METHOD SLOT-ACCESSOR-FUNCTION (EFFECTIVE-SLOT-DEFINITION T))| - |(METHOD SLOT-MISSING (T T T T))| - |(METHOD SLOT-UNBOUND (T T T))| |(READER FINALIZED-P)| - |(SETF DOCUMENTATION)| - |SETF PCL METHOD-CACHED-FUNCTIONS| - RAW-INSTANCE-ALLOCATOR - |(WRITER ARGUMENT-PRECEDENCE-ORDER)| - INSTALL-LAZY-CONSTRUCTOR-INSTALLER - |(WRITER SIDE-EFFECT-INTERNAL-SLOTDS)| - |(METHOD MAP-DEPENDENTS (DEPENDENT-UPDATE-MIXIN T))| - METHOD-FUNCTION-FOR-CACHING-P - |SETF PCL SLOT-DEFINITION-DEFSTRUCT-ACCESSOR-SYMBOL| - |(WRITER ARG-INFO)| |(READER OPTIMIZED-METHOD-LAMBDA)| - COMPUTE-DISCRIMINATING-FUNCTION-ARGLIST-INFO - STANDARD-WRITER-METHOD-P - CLASS-INCOMPATIBLE-SUPERCLASS-LIST - |(WRITER DEFAULT-INITARGS)| - |(WRITER DEFSTRUCT-CONSTRUCTOR)| - |(METHOD DIRECT-SLOT-DEFINITION-CLASS (STRUCTURE-CLASS T))| - |(METHOD DIRECT-SLOT-DEFINITION-CLASS (STD-CLASS T))| - WRAPPER-FETCHER |(METHOD DESCRIBE-OBJECT (CLASS T))| - |(METHOD DESCRIBE-OBJECT (STANDARD-GENERIC-FUNCTION T))| - |(METHOD DESCRIBE-OBJECT-SLOTS (SLOT-OBJECT T))| - |(METHOD DESCRIBE-OBJECT (SLOT-OBJECT T))| - |(METHOD DESCRIBE-OBJECT (T T))| - |(METHOD DESCRIBE-OBJECT (CONSTRUCTOR T))| - |SETF PCL SLOT-DEFINITION-INITARGS| - |(READER CLOSURE-GENERATOR)| REMOVE-BOUNDP-METHOD - |(METHOD GET-CONSTRUCTOR (SLOT-CLASS T))| - |(METHOD OPTIMIZE-INSTANCE-ACCESS (STANDARD-GENERIC-FUNCTION STANDARD-METHOD STRUCTURE-CLASS T T T T T))| - |(METHOD OPTIMIZE-INSTANCE-ACCESS (STANDARD-GENERIC-FUNCTION STANDARD-METHOD T T T T T T))| - |(METHOD METHOD-FUNCTION-FOR-CACHING (STANDARD-ACCESSOR-METHOD T))| - |(METHOD GET-CACHED-FUNCTION (STANDARD-METHOD T))| - |(METHOD METHOD-FUNCTION-FOR-CACHING (STANDARD-METHOD T))| - |(WRITER VALID-P)| |(WRITER INITARGS)| - |(METHOD BOUNDP-METHOD-CLASS (SLOT-CLASS T))| - |(METHOD BOUNDP-METHOD-CLASS (T T))| - |(WRITER FINALIZED-P)| - |(READER DIRECT-DEFAULT-INITARGS)| |(BOUNDP SOURCE)| - |DOCUMENTATION-MIXIN class predicate| - |(WRITER OPTIMIZED-METHOD-LAMBDA)| - |(SETF GF-DFUN-STATE)| |(READER INTERNAL-SLOTDS)| - SHORT-COMBINATION-OPERATOR METHOD-NEEDS-NEXT-METHODS-P - |(WRITER CLOSURE-GENERATOR)| REMOVE-NAMED-METHOD - |(METHOD ENSURE-CLASS-USING-CLASS (T NULL))| - LEGAL-DOCUMENTATION-P CLASS-DIRECT-SUPERCLASSES - CLASS-DIRECT-SUBCLASSES CLASS-DIRECT-DEFAULT-INITARGS - SLOT-DEFINITION-READERS SLOT-VALUE-USING-CLASS - DESCRIBE-OBJECT COMPUTE-APPLICABLE-METHODS CLASS-NAME - CLASS-PROTOTYPE READER-METHOD-CLASS REMOVE-METHOD - SLOT-DEFINITION-INITFORM - UPDATE-INSTANCE-FOR-REDEFINED-CLASS - UPDATE-INSTANCE-FOR-DIFFERENT-CLASS CHANGE-CLASS - METHOD-FUNCTION DIRECT-SLOT-DEFINITION-CLASS - MAKE-METHOD-LAMBDA EFFECTIVE-SLOT-DEFINITION-CLASS - CLASS-SLOTS COMPUTE-SLOTS SLOT-DEFINITION-NAME - FINALIZE-INHERITANCE - GENERIC-FUNCTION-ARGUMENT-PRECEDENCE-ORDER - GENERIC-FUNCTION-LAMBDA-LIST NO-NEXT-METHOD - CLASS-DIRECT-SLOTS CLASS-DEFAULT-INITARGS - COMPUTE-DISCRIMINATING-FUNCTION CLASS-FINALIZED-P - GENERIC-FUNCTION-NAME REMOVE-DEPENDENT - COMPUTE-CLASS-PRECEDENCE-LIST ADD-DEPENDENT - SLOT-BOUNDP-USING-CLASS ACCESSOR-METHOD-SLOT-DEFINITION - SHARED-INITIALIZE ADD-DIRECT-METHOD - SLOT-DEFINITION-LOCATION SLOT-DEFINITION-INITFUNCTION - SLOT-DEFINITION-ALLOCATION ADD-METHOD - GENERIC-FUNCTION-METHOD-CLASS METHOD-SPECIALIZERS - SLOT-DEFINITION-INITARGS WRITER-METHOD-CLASS - ADD-DIRECT-SUBCLASS SPECIALIZER-DIRECT-METHODS - GENERIC-FUNCTION-METHOD-COMBINATION ALLOCATE-INSTANCE - COMPUTE-EFFECTIVE-METHOD SLOT-DEFINITION-TYPE - SLOT-UNBOUND INITIALIZE-INSTANCE FUNCTION-KEYWORDS - SLOT-EXISTS-P-USING-CLASS REINITIALIZE-INSTANCE - VALIDATE-SUPERCLASS GENERIC-FUNCTION-METHODS - REMOVE-DIRECT-METHOD METHOD-LAMBDA-LIST MAKE-INSTANCE - GENERIC-FUNCTION-DECLARATIONS - COMPUTE-EFFECTIVE-SLOT-DEFINITION PRINT-OBJECT - METHOD-QUALIFIERS METHOD-GENERIC-FUNCTION - REMOVE-DIRECT-SUBCLASS MAKE-INSTANCES-OBSOLETE - SLOT-MAKUNBOUND-USING-CLASS - ENSURE-GENERIC-FUNCTION-USING-CLASS SLOT-MISSING - MAP-DEPENDENTS FIND-METHOD-COMBINATION - ENSURE-CLASS-USING-CLASS NO-APPLICABLE-METHOD - SLOT-DEFINITION-WRITERS - COMPUTE-APPLICABLE-METHODS-USING-CLASSES - CLASS-PRECEDENCE-LIST)) - (SETF (GET V 'COMPILER::PROCLAIMED-CLOSURE) T)) +(DOLIST (PCL::V '(PCL::ADD-READER-METHOD + PCL::SHORT-COMBINATION-IDENTITY-WITH-ONE-ARGUMENT + PCL::|DEFINITION-SOURCE-MIXIN class predicate| + PCL::REMOVE-READER-METHOD PCL::EQL-SPECIALIZER-P + PCL::OBJECT-PLIST + PCL::SLOT-DEFINITION-DEFSTRUCT-ACCESSOR-SYMBOL + PCL::SPECIALIZER-TYPE PCL::GF-DFUN-STATE + PCL::CLASS-DEFSTRUCT-CONSTRUCTOR + PCL::METHOD-FAST-FUNCTION PCL::SPECIALIZERP + PCL::EXACT-CLASS-SPECIALIZER-P + PCL::|STANDARD-OBJECT class predicate| + PCL::COMPATIBLE-META-CLASS-CHANGE-P + PCL::|STANDARD-METHOD-COMBINATION class predicate| + PCL::UPDATE-GF-DFUN + PCL::|STANDARD-EFFECTIVE-SLOT-DEFINITION class predicate| + PCL::SPECIALIZER-OBJECT + PCL::ACCESSOR-METHOD-SLOT-NAME + PCL::|STANDARD-DIRECT-SLOT-DEFINITION class predicate| + PCL::SPECIALIZER-CLASS PCL::CLASS-EQ-SPECIALIZER-P + PCL::SLOTS-FETCHER PCL::REMOVE-WRITER-METHOD + PCL::|STANDARD-SLOT-DEFINITION class predicate| + PCL::STRUCTURE-CLASS-P PCL::UPDATE-CONSTRUCTORS + PCL::DOCUMENTATION + PCL::|SLOT-OBJECT class predicate| + PCL::METHOD-PRETTY-ARGLIST + PCL::|RATIONAL class predicate| + PCL::CLASS-EQ-SPECIALIZER + PCL::INFORM-TYPE-SYSTEM-ABOUT-CLASS + PCL::|PCL-CLASS class predicate| + PCL::ACCESSOR-METHOD-CLASS + PCL::GENERIC-FUNCTION-PRETTY-ARGLIST + PCL::MAKE-BOUNDP-METHOD-FUNCTION + PCL::|SLOT-DEFINITION class predicate| + PCL::|METAOBJECT class predicate| + PCL::CLASS-PREDICATE-NAME + PCL::|SEQUENCE class predicate| PCL::CLASSP + PCL::|CHARACTER class predicate| + PCL::|COMPLEX class predicate| + PCL::|STD-CLASS class predicate| + PCL::LEGAL-QUALIFIERS-P PCL::ADD-BOUNDP-METHOD + PCL::LEGAL-LAMBDA-LIST-P + PCL::|SETF PCL GENERIC-FUNCTION-NAME| + PCL::|DEPENDENT-UPDATE-MIXIN class predicate| + PCL::DESCRIBE-OBJECT + PCL::MAKE-WRITER-METHOD-FUNCTION + PCL::|SETF PCL GF-DFUN-STATE| + PCL::|LONG-METHOD-COMBINATION class predicate| + PCL::|VECTOR class predicate| + PCL::|SETF PCL SLOT-DEFINITION-NAME| + PCL::|SETF PCL CLASS-NAME| + PCL::INITIALIZE-INTERNAL-SLOT-FUNCTIONS + PCL::|SETF PCL SLOT-DEFINITION-TYPE| + PCL::METHOD-COMBINATION-P + PCL::|STRUCTURE-DIRECT-SLOT-DEFINITION class predicate| + PCL::|STRUCTURE-EFFECTIVE-SLOT-DEFINITION class predicate| + PCL::|SETF PCL GENERIC-FUNCTION-METHODS| + PCL::|SETF PCL GENERIC-FUNCTION-METHOD-COMBINATION| + PCL::|SETF PCL METHOD-GENERIC-FUNCTION| + PCL::|SETF PCL SLOT-ACCESSOR-STD-P| + PCL::LEGAL-SPECIALIZERS-P + PCL::|SETF PCL OBJECT-PLIST| + PCL::|SETF PCL SLOT-DEFINITION-INITFORM| + PCL::|SETF PCL CLASS-DEFSTRUCT-FORM| + PCL::|SETF PCL GENERIC-FUNCTION-METHOD-CLASS| + PCL::SLOT-ACCESSOR-STD-P + PCL::|SETF PCL GF-PRETTY-ARGLIST| + PCL::|SETF PCL SLOT-ACCESSOR-FUNCTION| + PCL::|SETF PCL SLOT-DEFINITION-LOCATION| + PCL::|SETF PCL SLOT-DEFINITION-READER-FUNCTION| + PCL::|SETF PCL SLOT-DEFINITION-WRITER-FUNCTION| + PCL::|SETF PCL SLOT-DEFINITION-BOUNDP-FUNCTION| + PCL::|SETF PCL SLOT-DEFINITION-INTERNAL-READER-FUNCTION| + PCL::|SETF PCL SLOT-DEFINITION-INTERNAL-WRITER-FUNCTION| + PCL::|SETF PCL SLOT-DEFINITION-ALLOCATION| + PCL::|SETF PCL SLOT-DEFINITION-INITFUNCTION| + PCL::METHOD-COMBINATION-OPTIONS + PCL::|SETF PCL SLOT-DEFINITION-READERS| + PCL::|STRUCTURE-OBJECT class predicate| + PCL::|SETF PCL DOCUMENTATION| + PCL::FUNCALLABLE-STANDARD-CLASS-P + PCL::|SETF PCL SLOT-DEFINITION-CLASS| + PCL::|SETF PCL SLOT-VALUE-USING-CLASS| + PCL::CLASS-CAN-PRECEDE-LIST + PCL::|SETF PCL CLASS-DIRECT-SLOTS| + PCL::|SETF PCL CLASS-SLOTS| + PCL::SLOT-ACCESSOR-FUNCTION + PCL::|SETF PCL CLASS-INCOMPATIBLE-SUPERCLASS-LIST| + PCL::|SETF PCL SLOT-DEFINITION-WRITERS| + PCL::|STRUCTURE-SLOT-DEFINITION class predicate| + PCL::SLOT-CLASS-P PCL::MAKE-READER-METHOD-FUNCTION + PCL::|STRING class predicate| + PCL::LEGAL-METHOD-FUNCTION-P + PCL::|NUMBER class predicate| PCL::GET-METHOD + PCL::SHORT-METHOD-COMBINATION-P PCL::GF-ARG-INFO + PCL::|SYMBOL class predicate| + PCL::SPECIALIZER-METHOD-TABLE + PCL::MAKE-METHOD-INITARGS-FORM + PCL::CLASS-DEFSTRUCT-FORM PCL::GF-PRETTY-ARGLIST + PCL::SAME-SPECIALIZER-P + PCL::SLOT-DEFINITION-BOUNDP-FUNCTION + PCL::SLOT-DEFINITION-WRITER-FUNCTION + PCL::SLOT-DEFINITION-READER-FUNCTION + PCL::SLOT-DEFINITION-INTERNAL-WRITER-FUNCTION + PCL::SLOT-DEFINITION-INTERNAL-READER-FUNCTION + PCL::SLOT-DEFINITION-CLASS + PCL::EQL-SPECIALIZER-OBJECT + PCL::|RATIO class predicate| + PCL::CLASS-CONSTRUCTORS PCL::SLOTS-TO-INSPECT + PCL::SPECIALIZER-DIRECT-GENERIC-FUNCTIONS + PCL::ADD-WRITER-METHOD + PCL::MAYBE-UPDATE-CONSTRUCTORS + PCL::|EFFECTIVE-SLOT-DEFINITION class predicate| + PCL::|LIST class predicate| + PCL::LONG-METHOD-COMBINATION-FUNCTION + PCL::|BUILT-IN-CLASS class predicate| + PCL::GENERIC-FUNCTION-P PCL::|T class predicate| + PCL::|FLOAT class predicate| + PCL::|CONS class predicate| PCL::LEGAL-SLOT-NAME-P + PCL::CLASS-WRAPPER PCL::|ARRAY class predicate| + PCL::DEFINITION-SOURCE PCL::DEFAULT-INITARGS + PCL::|NULL class predicate| PCL::CLASS-SLOT-VALUE + PCL::FORWARD-REFERENCED-CLASS-P + PCL::GF-FAST-METHOD-FUNCTION-P + PCL::|SPECIALIZER-WITH-OBJECT class predicate| + PCL::LEGAL-QUALIFIER-P PCL::METHOD-P + PCL::|PLIST-MIXIN class predicate| + PCL::CLASS-SLOT-CELLS + PCL::STANDARD-ACCESSOR-METHOD-P + PCL::STANDARD-GENERIC-FUNCTION-P + PCL::STANDARD-READER-METHOD-P + PCL::STANDARD-METHOD-P + PCL::|TRACED-METHOD class predicate| + PCL::COMPUTE-EFFECTIVE-SLOT-DEFINITION-INITARGS + PCL::COMPUTE-DEFAULT-INITARGS + PCL::|SETF PCL CLASS-SLOT-VALUE| + PCL::METHOD-COMBINATION-TYPE PCL::STANDARD-CLASS-P + PCL::LEGAL-SPECIALIZER-P + PCL::COMPUTE-SLOT-ACCESSOR-INFO + PCL::|DIRECT-SLOT-DEFINITION class predicate| + PCL::STANDARD-BOUNDP-METHOD-P + PCL::RAW-INSTANCE-ALLOCATOR + PCL::|SETF PCL SLOT-DEFINITION-DEFSTRUCT-ACCESSOR-SYMBOL| + PCL::COMPUTE-DISCRIMINATING-FUNCTION-ARGLIST-INFO + PCL::STANDARD-WRITER-METHOD-P + PCL::CLASS-INCOMPATIBLE-SUPERCLASS-LIST + PCL::WRAPPER-FETCHER + PCL::|INTEGER class predicate| + PCL::METHOD-COMBINATION-DOCUMENTATION + PCL::|SETF PCL SLOT-DEFINITION-INITARGS| + PCL::REMOVE-BOUNDP-METHOD + PCL::|SETF PCL CLASS-DEFSTRUCT-CONSTRUCTOR| + PCL::|DOCUMENTATION-MIXIN class predicate| + PCL::SHORT-COMBINATION-OPERATOR + PCL::|BIT-VECTOR class predicate| + PCL::REMOVE-NAMED-METHOD + PCL::LEGAL-DOCUMENTATION-P + PCL:CLASS-DIRECT-SUPERCLASSES + PCL:CLASS-DIRECT-SUBCLASSES + PCL:CLASS-DIRECT-DEFAULT-INITARGS + PCL:SLOT-DEFINITION-READERS + PCL:SLOT-VALUE-USING-CLASS + PCL:COMPUTE-APPLICABLE-METHODS PCL:CLASS-NAME + PCL:CLASS-PROTOTYPE PCL:READER-METHOD-CLASS + PCL:REMOVE-METHOD PCL:SLOT-DEFINITION-INITFORM + PCL:UPDATE-INSTANCE-FOR-REDEFINED-CLASS + PCL:UPDATE-INSTANCE-FOR-DIFFERENT-CLASS + PCL:CHANGE-CLASS PCL:METHOD-FUNCTION + PCL:DIRECT-SLOT-DEFINITION-CLASS + PCL:MAKE-METHOD-LAMBDA + PCL:EFFECTIVE-SLOT-DEFINITION-CLASS + PCL:CLASS-SLOTS PCL:COMPUTE-SLOTS + PCL:SLOT-DEFINITION-NAME PCL:FINALIZE-INHERITANCE + PCL:GENERIC-FUNCTION-LAMBDA-LIST + PCL:CLASS-DIRECT-SLOTS PCL:CLASS-DEFAULT-INITARGS + PCL:COMPUTE-DISCRIMINATING-FUNCTION + PCL:CLASS-FINALIZED-P PCL:GENERIC-FUNCTION-NAME + PCL:REMOVE-DEPENDENT + PCL:COMPUTE-CLASS-PRECEDENCE-LIST + PCL:ADD-DEPENDENT PCL:SLOT-BOUNDP-USING-CLASS + PCL:ACCESSOR-METHOD-SLOT-DEFINITION + PCL:SHARED-INITIALIZE PCL:ADD-DIRECT-METHOD + PCL:SLOT-DEFINITION-LOCATION + PCL:SLOT-DEFINITION-INITFUNCTION + PCL:SLOT-DEFINITION-ALLOCATION PCL:ADD-METHOD + PCL:GENERIC-FUNCTION-METHOD-CLASS + PCL:METHOD-SPECIALIZERS + PCL:SLOT-DEFINITION-INITARGS + PCL:WRITER-METHOD-CLASS PCL:ADD-DIRECT-SUBCLASS + PCL:SPECIALIZER-DIRECT-METHODS + PCL:GENERIC-FUNCTION-METHOD-COMBINATION + PCL:ALLOCATE-INSTANCE PCL:COMPUTE-EFFECTIVE-METHOD + PCL:SLOT-DEFINITION-TYPE PCL:SLOT-UNBOUND + PCL:INITIALIZE-INSTANCE PCL:FUNCTION-KEYWORDS + PCL:REINITIALIZE-INSTANCE PCL:VALIDATE-SUPERCLASS + PCL:GENERIC-FUNCTION-METHODS + PCL:REMOVE-DIRECT-METHOD PCL:METHOD-LAMBDA-LIST + PCL:MAKE-INSTANCE + PCL:COMPUTE-EFFECTIVE-SLOT-DEFINITION + PCL:PRINT-OBJECT PCL:METHOD-QUALIFIERS + PCL:METHOD-GENERIC-FUNCTION + PCL:REMOVE-DIRECT-SUBCLASS + PCL:MAKE-INSTANCES-OBSOLETE + PCL:SLOT-MAKUNBOUND-USING-CLASS + PCL:ENSURE-GENERIC-FUNCTION-USING-CLASS + PCL:SLOT-MISSING PCL:MAP-DEPENDENTS + PCL:FIND-METHOD-COMBINATION + PCL:ENSURE-CLASS-USING-CLASS + PCL:NO-APPLICABLE-METHOD + PCL:SLOT-DEFINITION-WRITERS + PCL:COMPUTE-APPLICABLE-METHODS-USING-CLASSES + PCL:CLASS-PRECEDENCE-LIST)) + (SETF (GET PCL::V 'COMPILER::PROCLAIMED-CLOSURE) T)) diff --git a/pcl/sysdef.lisp b/pcl/sysdef.lisp index 6ddfed6d2..3056e6e3c 100644 --- a/pcl/sysdef.lisp +++ b/pcl/sysdef.lisp @@ -41,44 +41,7 @@ (unless (boundp 'pcl::*redefined-functions*) (setq pcl::*redefined-functions* nil)) -(defun pcl::reset-pcl-package () ; Try to do this safely - (let* ((vars '(pcl::*pcl-directory* - pcl::*default-pathname-extensions* - pcl::*pathname-extensions* - pcl::*redefined-functions*)) - (names (mapcar #'symbol-name vars)) - (values (mapcar #'symbol-value vars))) - (let ((pkg (find-package "PCL"))) - (do-symbols (sym pkg) - (when (eq pkg (symbol-package sym)) - (if (constantp sym) - (unintern sym pkg) - (progn - (makunbound sym) - (unless (eq sym 'pcl::reset-pcl-package) - (fmakunbound sym)) - #+cmu (fmakunbound `(setf ,sym)) - (setf (symbol-plist sym) nil)))))) - (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 pcl::*redefined-functions*) - (setf (symbol-function sym) (get sym ':definition-before-pcl))) - nil)) - (defun reset-pcl-package () - #-cmu - (unless (compiled-function-p #'pcl::reset-pcl-package) - (compile 'pcl::reset-pcl-package)) (pcl::reset-pcl-package) (let ((defsys (subfile '("pcl") :name "defsys"))) (setq pcl::*pcl-directory* defsys) @@ -111,7 +74,9 @@ (lfi (get-loaded-file-info path))) (and lfi path-fwd (= path-fwd (lfi-fwd lfi))))) (pcl-binary-files))) - (reset-pcl-package) + (let ((b-s 'pcl::*boot-state*)) + (when (and (boundp b-s) (symbol-value b-s)) + (reset-pcl-package))) (pcl::load-pcl))) (defsystem pcl @@ -133,9 +98,10 @@ (progn (maybe-load-defsys t) (if (and (fboundp 'pcl::operation-transformations) - (every #'(lambda (trans) - (eq (car trans) :load)) - (pcl::operation-transformations 'pcl::pcl :compile))) + (or (null (probe-file (subfile '("pcl") :name "defsys" :type "lisp"))) + (every #'(lambda (trans) + (eq (car trans) :load)) + (pcl::operation-transformations 'pcl::pcl :compile)))) (maybe-load-pcl) (let ((b-s 'pcl::*boot-state*)) (when (and (boundp b-s) (symbol-value b-s)) @@ -145,7 +111,8 @@ si::*system-directory*)) (#+cmu with-compilation-unit #-cmu progn #+cmu (:optimize - '(optimize (user::debug-info #+small .5 #-small 2) + '(optimize (user::debug-info #+(and small (not testing)) .5 + #-(and small (not testing)) 2) (speed #+testing 1 #-testing 2) (safety #+testing 3 #-testing 0) #+ignore (user::inhibit-warnings 2)) @@ -157,7 +124,8 @@ #-testing *fast-declaration*) (pcl::compile-pcl)) (reset-pcl-package) - (maybe-load-pcl t)))) + (maybe-load-pcl t))) + #+cmu (lisp::purify)) :load (progn (maybe-load-pcl) diff --git a/pcl/time.lisp b/pcl/time.lisp index 9abf2a7fa..06aefc4ca 100644 --- a/pcl/time.lisp +++ b/pcl/time.lisp @@ -9,19 +9,13 @@ (defvar gf #'shared-initialize) (defvar c (find-class 'standard-class)) -(eval-when (compile) - (defvar *saved-defclass-times* *defclass-times*) - (setf *defclass-times* '(eval load compile))) - (defclass str () ((slot :initform nil :reader str-slot)) (:metaclass structure-class)) -(eval-when (compile) - (setf *defclass-times* *saved-defclass-times*)) - (defvar str (make-instance 'str)) + (push (cons "Time unoptimized slot-value. This is case (1) from notes.text. (standard)" '(time-slot-value m 'plist 10000)) *tests*) @@ -88,7 +82,7 @@ '(time-default-initargs (find-class 'plist-mixin) 1000)) *tests*) (defun time-default-initargs (class n) - (time (dotimes (i n) (default-initargs class nil (class-default-initargs class))))) + (time (dotimes (i n) (default-initargs class nil)))) (push (cons "Time make-instance." @@ -97,25 +91,18 @@ (defun time-make-instance (class n) (time (dotimes (i n) (make-instance class)))) - -(defmethod meth-standard-1-slot-value ((object standard-method)) - (slot-value object 'function)) - -(defmethod meth-structure-1-slot-value ((object str)) - (slot-value object 'slot)) - -(push (cons "Time optimized slot-value inside of a defmethod (standard)" - '(time-meth-standard-1-slot-value m 10000)) +(push (cons "Time constant-keys make-instance." + '(time-constant-keys-make-instance 1000)) *tests*) -(defun time-meth-standard-1-slot-value (object n) - (time (dotimes (i n) (meth-standard-1-slot-value object)))) -(push (cons "Time optimized slot-value inside of a defmethod (structure)" - '(time-meth-structure-1-slot-value str 10000)) - *tests*) -(defun time-meth-structure-1-slot-value (object n) - (time (dotimes (i n) (meth-structure-1-slot-value object)))) +(expanding-make-instance-top-level +(defun constant-keys-make-instance (n) + (dotimes (i n) (make-instance 'plist-mixin)))) +(precompile-random-code-segments) + +(defun time-constant-keys-make-instance (n) + (time (constant-keys-make-instance n))) (defun expand-all-macros (form) (walk-form form nil #'(lambda (form context env) @@ -127,17 +114,17 @@ (values (macroexpand form env)) form)))) -(push (cons "Macroexpand method-structure-slot-value" - '(pprint (multiple-value-bind (function optimized-function) - (expand-defmethod-internal - (prototype-of-generic-function 'meth-structure-slot-value) - (method-prototype-for-gf 'meth-structure-slot-value) - 'method-structure-slot-value - nil '((object str)) - '(#'(lambda () (slot-value object 'slot))) - nil) - optimized-function))) +(push (cons "Macroexpand meth-structure-slot-value" + '(pprint (multiple-value-bind (pgf pm) + (prototypes-for-make-method-lambda + 'meth-structure-slot-value) + (expand-defmethod + 'meth-structure-slot-value pgf pm + nil '((object str)) + '(#'(lambda () (slot-value object 'slot))) + nil)))) *tests*) + #-kcl (push (cons "Show code for slot-value inside a defmethod for a structure-class. Case (3)." '(disassemble (meth-structure-slot-value str))) @@ -149,15 +136,10 @@ #|| ; interesting, but long. (produces 100 lines of output) (push (cons "Macroexpand meth-standard-slot-value" '(pprint (expand-all-macros - (multiple-value-bind (function optimized-function) - (expand-defmethod-internal - (prototype-of-generic-function 'meth-standard-slot-value) - (method-prototype-for-gf 'meth-standard-slot-value) - 'meth-standard-slot-value - nil '((object standard-method)) - '(#'(lambda () (slot-value object 'function))) - nil) - optimized-function)))) + (expand-defmethod-internal 'meth-standard-slot-value + nil '((object standard-method)) + '(#'(lambda () (slot-value object 'function))) + nil)))) *tests*) (push (cons "Show code for slot-value inside a defmethod for a standard-class. Case (4)." '(disassemble (meth-standard-slot-value m))) diff --git a/pcl/vector.lisp b/pcl/vector.lisp index d3ae7c761..b1a4161c5 100644 --- a/pcl/vector.lisp +++ b/pcl/vector.lisp @@ -29,191 +29,575 @@ (in-package 'pcl) -(defmacro instance-slot-index-from-slots-layout (slots-layout slot-name) - `(locally (declare #.*optimize-speed*) - (let ((slots-left ,slots-layout)) - (if slots-left - (block nil - (let ((index 0)) - (declare (type index index)) - (tagbody - begin-loop - (if (eq (car slots-left) ,slot-name) - (go return-index)) - (setf index (the index (1+ index))) - (if (null (setf slots-left (cdr slots-left))) - (return NIL)) - (go begin-loop) - return-index) - index)))))) - (defmacro instance-slot-index (wrapper slot-name) - `(instance-slot-index-from-slots-layout - (wrapper-instance-slots-layout ,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))))) ;;; ;;; ;;; +(defun pv-cache-limit-fn (nlines) + (default-limit-fn nlines)) + +(defstruct (pv-table + (:predicate pv-tablep) + (:constructor make-pv-table-internal + (slot-name-lists call-list))) + (cache nil :type (or cache null)) + (pv-size 0 :type fixnum) + (slot-name-lists nil :type list) + (call-list nil :type list)) + +(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) + +(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)) + +(defun make-pv-table-type-declaration (var) + `(type pv-table ,var)) + +(defvar *slot-name-lists-inner* (make-hash-table :test #'equal)) +(defvar *slot-name-lists-outer* (make-hash-table :test #'equal)) + +;entries in this are lists of (table . pv-offset-list) +(defvar *pv-key-to-pv-table-table* (make-hash-table :test 'equal)) + +(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*) + (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))))) + (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))) + (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) - (let ((slotd (find-slot-definition class slot-name))) - (and slotd - (or (not (eq *boot-state* 'complete)) + (or (not (eq *boot-state* 'complete)) + (let ((slotd (find-slot-definition class slot-name))) + (and slotd (slot-accessor-std-p slotd type))))) -(defun optimize-generic-function-call (form required-parameters env) - (declare (ignore env required-parameters)) - form - #|| - (let* ((gf-name (car form)) - (gf (gdefinition gf-name)) - (arg-info (gf-arg-info gf)) - (metatypes (arg-info-metatypes arg-info)) - (nreq (length metatypes)) - (applyp (arg-info-applyp arg-info))) - (declare (type index nreq)) - (declare (ignore applyp)) - (if (or (zerop nreq) - (not (<= nreq (length (cdr form)))) - (not (every #'(lambda (arg mt) - (declare (ignore mt)) - (when (consp arg) - (setq arg (un-the arg))) - (and (symbolp arg) - (memq arg required-parameters)) - (let ((class-name (caddr (variable-declaration - 'class arg env)))) - (and class-name (not (eq 't class-name))))) - (cdr form) metatypes))) - form - form))||#) ;`(maybe-fast-gf-call ,(car form) ,(cdr form)) - - -;; For calls to a gf: -; gf-call-info: (gf call-info-vector . gf-function-vector) -; call-info-vector: #(call-info1 ... call-infon) -; gf-function-vector: #(function1 ... functionn) -; --> once an entry is made in call-info-vector, it is never moved or removed -; call-info: (gf . arg-types) -; arg-type: a type. `(arg ,n) is not allowed here. - -;; For calls from a method: -; method-gf-call-info: (method-specializers method-call-info-vector . ???) -; arg-type: a type or `(arg ,n) -; when arg-type is (arg n) the real type is either: -; the arg's specializer or -; (wrapper-eq ,wrapper) for a call appearing within a caching dfun gf - -; every optimized gf in a method has an entry in the method's method-call-info-vector -; a macro: (get-call-cell mciv-index .all-wrappers.) -> -; index into the gf-function-vector - -;(defmacro maybe-fast-gf-call (gf-name args) -; nil) +(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) + (unless (listp wrappers) (setq wrappers (list wrappers))) + (let* ((not-simple-p-cell (list nil)) + (elements + (gathering1 (collecting) + (iterate ((slot-names (list-elements slot-name-lists))) + (when slot-names + (let* ((wrapper (pop wrappers)) + (class (wrapper-class* wrapper)) + (class-slots (wrapper-class-slots wrapper))) + (dolist (slot-name (cdr slot-names)) + (gather1 + (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))))))) + +(defun compute-calls (call-list wrappers) + (map 'vector + #'(lambda (call) + (compute-emf-from-wrappers call wrappers)) + call-list)) + +(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)))))))) + +(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) + (free-cache cache)) + pv-cell)))) + +(defun make-pv-type-declaration (var) + `(type simple-vector ,var)) + +(defvar *empty-pv* #()) + +(defmacro pvref (pv index) + `(svref ,pv ,index)) + +(defmacro copy-pv (pv) + `(copy-seq ,pv)) + +(defun make-calls-type-declaration (var) + `(type simple-vector ,var)) + +(defmacro callsref (calls index) + `(svref ,calls ,index)) + +(defvar *pv-table-cache-update-info* nil) + +;called by: +;(method shared-initialize :after (structure-class t)) +;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)))) + +(defun update-all-pv-table-caches (class slot-names) + (let* ((cwrapper (class-wrapper class)) + (class-slots (wrapper-class-slots cwrapper)) + (class-slot-p-cell (list nil)) + (new-values (mapcar #'(lambda (slot-name) + (cons slot-name + (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))) + (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) + (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) + (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))) +(defun maybe-expand-accessor-form (form required-parameters slots env) + (let* ((fname (car form)) + (len (length form)) + (gf (if (symbolp fname) + (unencapsulated-fdefinition fname) + (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)))))))))))))) + +(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 t)) + #|| + (maybe-expand-accessor-form form required-parameters slots env) + (let* ((fname (car form)) + (len (length form)) + (gf (if (symbolp fname) + (and (fboundp fname) + (unencapsulated-fdefinition fname)) + (and (gboundp 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)) + + + (defun can-optimize-access (form required-parameters env) (let ((type (ecase (car form) (slot-value 'reader) (set-slot-value 'writer) (slot-boundp 'boundp))) - (var (un-the (cadr form))) + (var (cadr form)) (slot-name (eval (caddr form)))) ; known to be constant - (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 (if (and class - (class-on-class-precedence-list-p - *the-class-structure-object* class)) - (optimize-slot-value-by-class-p class slot-name type) - (and class-name (not (eq class-name 't)))) + (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 (generic-function method slots sparameter form) +(defun optimize-slot-value (slots sparameter form) (if sparameter (destructuring-bind (ignore ignore slot-name-form) form - (let ((slot-name (eval slot-name-form)) - (class (if (consp sparameter) (cdr sparameter) *the-class-t*)) - (parameter (if (consp sparameter) (car sparameter) sparameter))) - (if (eq *boot-state* 'complete) - (optimize-instance-access generic-function method class parameter - slots :read slot-name nil) - (optimize-std-instance-access class parameter - slots :read slot-name nil)))) - `(fast-slot-value ,@(cdr form)))) - -(defun optimize-set-slot-value (generic-function method slots sparameter 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 (ignore ignore slot-name-form new-value) form - (let ((slot-name (eval slot-name-form)) - (class (if (consp sparameter) (cdr sparameter) *the-class-t*)) - (parameter (if (consp sparameter) (car sparameter) sparameter))) - (if (eq *boot-state* 'complete) - (optimize-instance-access generic-function method class parameter - slots :write slot-name new-value) - (optimize-std-instance-access class parameter - slots :write slot-name new-value)))) - `(fast-set-slot-value ,@(cdr form)))) - -(defun optimize-slot-boundp (generic-function method slots sparameter 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 (destructuring-bind (ignore ignore slot-name-form new-value) form - (let ((slot-name (eval slot-name-form)) - (class (if (consp sparameter) (cdr sparameter) *the-class-t*)) - (parameter (if (consp sparameter) (car sparameter) sparameter))) - (if (eq *boot-state* 'complete) - (optimize-instance-access generic-function method class parameter - slots :boundp slot-name new-value) - (optimize-std-instance-access class parameter - slots :boundp slot-name new-value)))) - `(fast-slot-boundp ,@(cdr form)))) + (let ((slot-name (eval slot-name-form))) + (optimize-instance-access slots :boundp sparameter slot-name new-value))) + `(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 (ignore ignore new-value) 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-std-instance-access (class parameter slots read/write - slot-name new-value) - (let* ((parameter-entry (assq parameter slots)) - (class-name (if (symbolp class) class (class-name class))) - (slot-entry (assq slot-name (cdr parameter-entry))) - (index-name - (or (second slot-entry) - (intern - (string-append "." (symbol-name parameter) "-" - (symbol-name slot-name) "-INDEX."))))) +(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 (or slot-entry - (skip-fast-slot-access-p - class-name slot-name - (ecase read/write - (:read 'reader) (:write 'writer) (:boundp 'boundp)))) - (setq slot-entry (list slot-name index-name)) + (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 - (if slot-entry - `(instance-read ,parameter ',slot-name ,index-name ,class-name) - `(fast-slot-value ,parameter ',slot-name))) + `(instance-reader ,pv-offset-form ,parameter ,position ,gf-name ',class)) (:write - (if slot-entry - `(instance-write ,parameter ',slot-name ,index-name ,class-name - ,new-value) - `(fast-set-slot-value ,parameter ',slot-name ,new-value))) - (:boundp - (if slot-entry - `(instance-boundp ,parameter ',slot-name ,index-name ,class-name) - `(fast-slot-boundp ,parameter ',slot-name)))))) + `(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))))))))) + + +(define-walker-template pv-offset) ; These forms get munged by mutate slots. +(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. @@ -224,231 +608,436 @@ (standard-class-p class) (not (eq class *the-class-t*)) ; shouldn't happen, though. (let ((slotd (find-slot-definition class slot-name))) - (and slotd (consp (slot-definition-location slotd))))))) + (and slotd (classp (slot-definition-allocation slotd))))))) -(defun skip-fast-slot-access-p (class-name slot-name-form type) - (let ((class (find-class class-name nil)) - (slot-name - (cond ((symbolp slot-name-form) slot-name-form) - ((constantp slot-name-form) (eval slot-name-form))))) +(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. - (progn - (unless (class-finalized-p class) (finalize-inheritance class)) - (let ((slotd (find-slot-definition class slot-name))) - (and slotd (skip-optimize-slot-value-by-class-p class slot-name type))))))) + (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 (the boolean (slot-accessor-std-p slotd type)))))) + (not (slot-accessor-std-p slotd type))))) -(defmacro instance-read (parameter slot-name index class) +(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) - `(fast-slot-value ,parameter ,slot-name) - `(optimized-parameter-read ,parameter ,slot-name ,index))) + `(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)) -(defmacro instance-write (parameter slot-name index class new-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) - `(fast-set-slot-value ,parameter ,slot-name ,new-value) - `(optimized-parameter-write ,parameter ,slot-name ,index ,new-value))) + `(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-boundp (parameter slot-name index class) - (if (skip-fast-slot-access-p class slot-name 'boundp) - `(fast-slot-boundp ,parameter ,slot-name) - `(optimized-parameter-boundp ,parameter ,slot-name ,index))) - - -;;; closure-generators are used only by method-function-for-caching -;;; (in methods.lisp) and make-not-for-caching-method-function. - -(defun make-not-for-caching-method-function (closure-generator) - (let ((function (method-function-funcall closure-generator nil))) - #+(and kcl turbo-closure) (si:turbo-closure function) - function)) - -(declaim (ftype (function (T) boolean) all-standard-accesses-p)) -(defun all-standard-accesses-p (slot-locs-and-fetchers-and-method) - (let ((slot-locations (first slot-locs-and-fetchers-and-method)) - (slot-fetchers (second slot-locs-and-fetchers-and-method))) - (and slot-locations - slot-fetchers - (every #'integerp slot-locations) - (every #'(lambda (x) (eq x 'std-instance-slots)) slot-fetchers)))) - -(defun make-std-closure-generator-form - (generic-function method optimized-method-lambda initargs) - (declare (type list initargs)) - (let ((slot-indices - (getf initargs :optimized-slot-indices)) - (runtime-compile-p - (and (eq *boot-state* 'complete) - (call-store-optimized-method-lambda-p - generic-function method initargs)))) - (declare (type boolean runtime-compile-p)) - `#'(lambda (slot-locs-and-fetchers-and-method) - (let (,@(mapcar - #'(lambda (slot-index) - `(,(third slot-index) - (nth ,(posq slot-index slot-indices) - (the list - (car slot-locs-and-fetchers-and-method))))) - slot-indices)) - (if (all-standard-accesses-p slot-locs-and-fetchers-and-method) - (macrolet - ((optimized-parameter-read (x slot-name index) - `(locally (declare #.*optimize-speed*) - (let ((.value. (%svref (std-instance-slots ,x) ,index))) - (if (eq .value. *slot-unbound*) - (funcall #'slot-value ,x ,slot-name) - .value.)))) - (optimized-parameter-write (x slot-name index new) - (declare (ignore slot-name)) - `(locally (declare #.*optimize-speed*) - (setf (%svref (std-instance-slots ,x) ,index) ,new))) - (optimized-parameter-boundp (x slot-name index) - (declare (ignore slot-name)) - `(locally (declare #.*optimize-speed*) - (neq (%svref (std-instance-slots ,x) ,index) - *slot-unbound*)))) - (function ,optimized-method-lambda)) - ,(if runtime-compile-p - `(make-cached-method-function-from-stored-lambda - (third slot-locs-and-fetchers-and-method) - slot-locs-and-fetchers-and-method) - `(macrolet - ((optimized-parameter-read (x slot-name index) - `(locally (declare #.*optimize-speed*) - (let ((.value. - (typecase ,index - (fixnum (%svref (get-slots ,x) ,index)) - (cons (cdr ,index)) - (T *slot-unbound*)))) - (if (eq .value. *slot-unbound*) - (funcall #'slot-value ,x ,slot-name) - .value.)))) - (optimized-parameter-write (x slot-name index new) - (once-only (new) - `(locally (declare #.*optimize-speed*) - (typecase ,index - (fixnum (setf (%svref (get-slots ,x) ,index) ,new)) - (cons (setf (cdr ,index) ,new)) - (T (funcall #'set-slot-value ,x ,slot-name - ,new)))))) - (optimized-parameter-boundp (x slot-name index) - `(locally (declare #.*optimize-speed*) - (typecase ,index - (fixnum (neq (%svref (get-slots ,x) ,index) - *slot-unbound*)) - (cons (neq (cdr ,index) *slot-unbound*)) - (T (funcall #'slot-boundp ,x ,slot-name)))))) - (function ,optimized-method-lambda)))))))) +(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 + (,(if (consp gf-name) + (get-setf-function-name gf-name) + gf-name) + (instance-accessor-parameter ,parameter) + ,new-value) + :instance)) - -(defmethod wrapper-fetcher ((class standard-class)) - 'std-instance-wrapper) +(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))))))) -(defmethod slots-fetcher ((class standard-class)) - 'std-instance-slots) +(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)))) -(defmethod raw-instance-allocator ((class standard-class)) - '%%allocate-instance--class) +;;; +;;; This magic function has quite a job to do indeed. +;;; +;;; 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. +;;; +;;; 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. +;;; +;;; 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) + (let* ((slot-name-lists + (mapcar #'(lambda (parameter-entry) + (cons nil (mapcar #'car (cdr parameter-entry)))) + 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))) + (values slot-name-lists call-list)))) +(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 + (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))) + (values sorted-slots sorted-calls))) -(defun instance-type (instance) - "Returns the underlying instance type of INSTANCE." - (cond ((std-instance-p instance) 'std-instance) - ((fsc-instance-p instance) 'fsc-instance) - #+pcl-user-instances - ((user-instance-p instance) 'user-instance) - ((structurep instance) 'structure-instance) - (T (error "~S is not a standard kind of instance." instance)))) +(defun symbol-pkg-name (sym) + (let ((pkg (symbol-package sym))) + (if pkg (package-name pkg) ""))) -(defun class-instance-type (class) - "Returns the underlying instance type CLASS instances." - (if (eq class *the-class-standard-generic-function*) - 'fsc-instance - (if (class-finalized-p class) - (instance-type (class-prototype class)) - (instance-type (allocate-instance class))))) +(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)))) -;;; -;;; These are the basic functions to allow programmers to define their -;;; own type of instances other than STD-INSTANCE, FSC-INSTANCE, -;;; STRUCTURE-INSTANCE, or BUILT-IN-INSTANCE. It can be used for user-defined -;;; meta-classes whose instances' underlying implementation is different -;;; than the default PCL implementation of STD-INSTANCE for STANDARD-CLASS. -;;; For example, the programmer can define their own user instances to be -;;; represented as a simple-vector whose first element stores the information -;;; needed to control the instances (e.g. a user wrapper storing the normal -;;; PCL wrapper, the list of slot names for the class, and so on), and whose -;;; remaining elements are the slots of the instance itself. This kind of -;;; defined user instance would take less space than the normal pcl -;;; STD-INSTANCE (which is represented as a structure, one of whose elements -;;; is another vector holding the slots), at the cost of some redefinition -;;; flexibility. See user-instances.lisp for an example of how this can be done. -;;; Defining USER-INSTANCES requires knowledge of how PCL's -;;; wrappers and slots work internally, but the basic functions that need -;;; to be implemented are USER-INSTANCE-P, USER-INSTANCE-WRAPPER, -;;; SET-USER-INSTANCE-WRAPPER, USER-INSTANCE-SLOTS, and -;;; SET-USER-INSTANCE-SLOTS. These are analogous to STD-INSTANCE-P, -;;; STD-INSTANCE-WRAPPER, etc., and must return the same thing that they -;;; would. -;;; Contact Trent Lange (lange@cs.ucla.edu) for any questions. -;;; The feature :PCL-USER-INSTANCES must be pushed onto the lisp *FEATURES* -;;; list in low.lisp to turn this feature on. -;;; +(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)))))))) -#+pcl-user-instances -(progn -(proclaim '(notinline user-instance-p - user-instance-wrapper - user-instance-slots - set-user-instance-wrapper - set-user-instance-slots)) +(defun sort-slots (slots) + (mapcar #'(lambda (parameter-entry) + (cons (car parameter-entry) + (sort (cdr parameter-entry) ;slot entries + #'symbol-or-cons-lessp + :key #'car))) + slots)) -(defun user-instance-p (x) - (declare (ignore x)) - NIL) +(defun sort-calls (calls) + (sort calls #'symbol-or-cons-lessp :key #'car)) + + +;;; +;;; 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. -(defun user-instance-wrapper (x) - (declare (ignore x)) - (error "No user-instance-wrapper function defined for user instances.")) +(defmacro pv-binding ((required-parameters slot-name-lists pv-table-symbol) + &body body) + (with-gathering ((slot-vars (collecting)) + (pv-parameters (collecting))) + (iterate ((slots (list-elements slot-name-lists)) + (required-parameter (list-elements required-parameters)) + (i (interval :from 0))) + (when slots + (gather required-parameter pv-parameters) + (gather (slot-vector-symbol i) slot-vars))) + `(pv-binding1 (.pv. .calls. ,pv-table-symbol ,pv-parameters ,slot-vars) + ,@body))) -(defun set-user-instance-wrapper (x nv) - (declare (ignore x nv)) - (error "No set-user-instance-wrapper function defined for user instances.")) +(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))) -(defun user-instance-slots (x) - (declare (ignore x)) - (error "No user-instance-slots function defined for user instances.")) +;This gets used only when the default make-method-lambda is overriden. +(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)) + ,@(when (symbolp pv-table-symbol) + `((declare (special ,pv-table-symbol)))) + ,pv ,calls + ,@forms)) -(defun set-user-instance-slots (x nv) - (declare (ignore x nv)) - (error "No set-user-instance-slots function defined for user instances.")) +(defun split-declarations (body args) + (let* ((must-rebind-args-p nil) + (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) + (case (car form) + ((optimize method-name method-lambda-list) + (push `(declare ,form) outer-decls)) + ((ignore type class) + (let ((dname (list (pop form))) (inners nil) (outers nil)) + (when (member (car dname) '(type class)) + (setq dname (append dname (list (pop form))))) + (dolist (var form) + (if (member var args) + (push var outers) + (push var inners))) + (when outers + (push `(declare (,@dname ,@outers)) outer-decls)) + (when inners + (push `(declare (,@dname ,@inners)) inner-decls)))) + (t (setq must-rebind-args-p t))))) + (setq body (cdr body))) + (values outer-decls inner-decls must-rebind-args-p body))) -(defsetf user-instance-wrapper set-user-instance-wrapper) -(defsetf user-instance-slots set-user-instance-slots) +(defun make-method-initargs-form-internal (method-lambda initargs env) + (declare (ignore env)) + (let (method-lambda-args lmf lmf-params) + (if (not (and (= 3 (length method-lambda)) + (= 2 (length (setq method-lambda-args (cadr method-lambda)))) + (consp (setq lmf (third method-lambda))) + (eq 'simple-lexical-method-functions (car lmf)) + (eq (car method-lambda-args) (cadr (setq lmf-params (cadr lmf)))) + (eq (cadr method-lambda-args) (caddr lmf-params)))) + `(list* :function #',method-lambda + ',initargs) + (let* ((lambda-list (car lmf-params)) + (nreq 0)(restp nil)(args nil)) + (dolist (arg lambda-list) + (when (member arg '(&optional &rest &key)) + (setq restp t)(return nil)) + (when (eq arg '&aux) (return nil)) + (incf nreq)(push arg args)) + (setq args (nreverse args)) + (setf (getf (getf initargs ':plist) ':arg-info) (cons nreq restp)) + (make-method-initargs-form-internal1 + initargs (cddr lmf) args lmf-params restp))))) -;;; The following three macros are used by PCL as hooks to call the three -;;; user-instance functions. They can be redefined for particular -;;; instantiations of the user-instance instances to return the same -;;; values the functions would, but to work faster by avoiding the -;;; function call. +(defun make-method-initargs-form-internal1 + (initargs body req-args lmf-params restp) + (multiple-value-bind (outer-decls inner-decls must-rebind-args-p body) + (split-declarations body req-args) + (let* ((rest-arg (when restp '.rest-arg.)) + (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 + .pv-cell. .next-method-call. + (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 + ,@forms))) + (fast-lexical-method-functions + (,(car lmf-params) .next-method-call. ,req-args ,rest-arg + ,@(cdddr lmf-params)) + ,@inner-decls + ,@body))) + ',initargs)))) -(defmacro get-user-instance-p (x) - `(user-instance-p ,x)) +;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) + (let* ((method-function nil) (pv-table nil) + (arg-info (method-function-get fmf ':arg-info)) + (nreq (car arg-info)) + (restp (cdr arg-info))) + (setq method-function + #'(lambda (method-args next-methods) + (unless pv-table + (setq pv-table (method-function-pv-table fmf))) + (let* ((pv-cell (when pv-table + (get-method-function-pv-cell + method-function method-args pv-table))) + (nm (car next-methods)) + (nms (cdr next-methods)) + (nmc (when nm + (make-method-call :function (if (std-instance-p nm) + (method-function nm) + nm) + :call-method-args (list nms))))) + (if restp + (let* ((rest (nthcdr nreq method-args)) + (args (ldiff method-args rest))) + (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)))) + (set-function-name method-function name)) + (setf (method-function-get method-function :fast-function) fmf) + method-function)) -(defmacro get-user-instance-wrapper (x) - `(user-instance-wrapper ,x)) +(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)))))) -(defmacro get-user-instance-slots (x) - `(user-instance-slots ,x)) +(defun pv-table-lookup-pv-args (pv-table &rest pv-parameters) + (pv-table-lookup pv-table (pv-wrappers-from-pv-args pv-parameters))) -(defmacro fast-check-user-wrapper-validity (object) - `(fast-check-wrapper-validity ,object get-user-instance-wrapper)) +(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 (cond ((std-instance-p arg) + (std-instance-wrapper arg)) + ((fsc-instance-p arg) + (fsc-instance-wrapper arg)) + (t + #+new-kcl-wrapper + (built-in-wrapper-of arg) + #-new-kcl-wrapper + (built-in-or-structure-wrapper arg)))) + (unless (eq 't (wrapper-state 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)) -) ;+pcl-user-instances +(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))) +(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))) diff --git a/pcl/walk.lisp b/pcl/walk.lisp index 6d26a482a..be759ab63 100644 --- a/pcl/walk.lisp +++ b/pcl/walk.lisp @@ -62,12 +62,14 @@ ;;; (export '(define-walker-template walk-form + walk-form-expand-macros-p nested-walk-form variable-lexical-p variable-special-p variable-globally-special-p *variable-declarations* variable-declaration + macroexpand-all )) @@ -204,21 +206,24 @@ ,@body)) (defun with-augmented-environment-internal (env functions macros) - (dolist (f functions) - (push (list* f 'function #'unbound-lexical-function) env)) - (dolist (m macros) - (push (list* (car m) 'excl::macro (cadr m)) env)) - env) + (let (#+allegro-v4.1 (env-tail (cdr env)) #+allegro-v4.1 (env (car env))) + (dolist (f functions) + (push (list* f 'function #'unbound-lexical-function) env)) + (dolist (m macros) + (push (list* (car m) 'excl::macro (cadr m)) env)) + #-allegro-v4.1 env #+allegro-v4.1 (cons env env-tail))) (defun environment-function (env fn) - (let ((entry (assoc fn env :test #'equal))) + (let* (#+allegro-v4.1 (env (car env)) + (entry (assoc fn env :test #'equal))) (and entry (or (eq (cadr entry) 'function) (eq (cadr entry) 'compiler::function-value)) (cddr entry)))) (defun environment-macro (env macro) - (let ((entry (assoc macro env :test #'equal))) + (let* (#+allegro-v4.1 (env (car env)) + (entry (assoc macro env :test #'equal))) (and entry (eq (cadr entry) 'excl::macro) (cddr entry)))) @@ -858,15 +863,17 @@ ;; we have no idea what to use for the environment. So we just blow it ;; off, 'cause anything real we do would be wrong. We still have to ;; make an entry so we can tell functions from macros. - (c::make-lexenv :default (or env (c::make-null-environment)) - :functions - (append (mapcar #'(lambda (f) - (cons (car f) (c::make-functional))) - functions) - (mapcar #'(lambda (m) - (list* (car m) 'c::macro - (coerce (cadr m) 'function))) - macros)))) + (let ((env (or env (c::make-null-environment)))) + (c::make-lexenv + :default env + :functions + (append (mapcar #'(lambda (f) + (cons (car f) (c::make-functional :lexenv env))) + functions) + (mapcar #'(lambda (m) + (list* (car m) 'c::macro + (coerce (cadr m) 'function))) + macros))))) (defun environment-function (env fn) (when env @@ -986,11 +993,11 @@ entry))) -(defvar *VARIABLE-DECLARATIONS* (list 'special)) +(defvar *VARIABLE-DECLARATIONS* '(special)) (defun VARIABLE-DECLARATION (declaration var env) (if (not (member declaration *variable-declarations*)) - (error "~S is not a reckognized 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) @@ -1143,6 +1150,7 @@ (define-walker-template LAMBDA walk-lambda) (define-walker-template LET walk-let) (define-walker-template LET* walk-let*) +(define-walker-template LOCALLY walk-locally) (define-walker-template MACROLET walk-macrolet) (define-walker-template MULTIPLE-VALUE-CALL (NIL EVAL REPEAT (EVAL))) (define-walker-template MULTIPLE-VALUE-PROG1 (NIL RETURN REPEAT (EVAL))) @@ -1156,6 +1164,7 @@ (define-walker-template SYMBOL-MACROLET walk-symbol-macrolet) (define-walker-template TAGBODY walk-tagbody) (define-walker-template THE (NIL QUOTE EVAL)) +#+cmu(define-walker-template EXT:TRULY-THE (NIL QUOTE EVAL)) (define-walker-template THROW (NIL EVAL EVAL)) (define-walker-template UNWIND-PROTECT (NIL RETURN REPEAT (EVAL))) @@ -1203,6 +1212,12 @@ +(defvar walk-form-expand-macros-p nil) + +(defun macroexpand-all (form &optional environment) + (let ((walk-form-expand-macros-p t)) + (walk-form form environment))) + (defun WALK-FORM (form &optional environment (walk-function @@ -1295,8 +1310,6 @@ ;;; 3. Otherwise, assume it is a function call. " ;;; -(defvar walk-form-expand-macros-p nil) - (defun walk-form-internal (form context env) ;; First apply the walk-function to perform whatever translation ;; the user wants to this form. If the second value returned @@ -1363,7 +1376,7 @@ ((LAMBDA CALL) (cond ((or (symbolp form) (and (listp form) - (= (length (the list form)) 2) + (= (length form) 2) (eq (car form) 'setf))) form) #+Lispm @@ -1378,10 +1391,9 @@ ;; call to length. (if (null (cddr template)) () - (nthcdr (- (length (the list form)) + (nthcdr (- (length form) (length - (the list - (cddr template)))) + (cddr template))) form)) context env)) @@ -1526,7 +1538,7 @@ &aux arg) (cond ((null arglist) ()) ((symbolp (setq arg (car arglist))) - (or (member arg lambda-list-keywords :test #'eq) + (or (member arg lambda-list-keywords) (note-lexical-binding arg env)) (recons arglist arg @@ -1535,26 +1547,24 @@ env (and destructuringp (not (member arg - lambda-list-keywords - :test #'eq)))))) + lambda-list-keywords)))))) ((consp arg) - (prog1 - (recons arglist - (if destructuringp - (walk-arglist arg context env destructuringp) - (relist* arg - (car arg) - (walk-form-internal (cadr arg) :eval env) - (cddr arg))) - (walk-arglist (cdr arglist) context env nil)) - (if (symbolp (car arg)) - (note-lexical-binding (car arg) env) - (note-lexical-binding (cadar arg) env)) - (or (null (cddr arg)) - (not (symbolp (caddr arg))) - (note-lexical-binding (caddr arg) env)))) - (t - (error "Can't understand something in the arglist ~S" arglist)))) + (prog1 (recons arglist + (if destructuringp + (walk-arglist arg context env destructuringp) + (relist* arg + (car arg) + (walk-form-internal (cadr arg) :eval env) + (cddr arg))) + (walk-arglist (cdr arglist) context env nil)) + (if (symbolp (car arg)) + (note-lexical-binding (car arg) env) + (note-lexical-binding (cadar arg) env)) + (or (null (cddr arg)) + (not (symbolp (caddr arg))) + (note-lexical-binding (caddr arg) env)))) + (t + (error "Can't understand something in the arglist ~S" arglist)))) (defun walk-let (form context env) (walk-let/let* form context env nil)) @@ -1590,6 +1600,15 @@ (relist* form let/let* walked-bindings walked-body)))) +(defun walk-locally (form context env) + (declare (ignore context)) + (let* ((locally (car form)) + (body (cdr form)) + (walked-body + (walk-declarations body #'walk-repeat-eval env))) + (relist* + form locally walked-body))) + (defun walk-prog/prog* (form context old-env sequentialp) (walker-environment-bind (new-env old-env) (let* ((possible-block-name (second form)) @@ -1656,18 +1675,11 @@ (if (some #'(lambda (var) (variable-symbol-macro-p var env)) vars) - (let* ((expanded - (let ((sets NIL) - (temps NIL) - (temp NIL)) - (dolist (var vars) - (setf temp (gensym)) - (push `(setq ,var ,temp) sets) - (push temp temps)) - `(multiple-value-bind - ,(nreverse temps) - ,(caddr form) - ,@(nreverse sets)))) + (let* ((temps (mapcar #'(lambda (var) (declare (ignore var)) (gensym)) vars)) + (sets (mapcar #'(lambda (var temp) `(setq ,var ,temp)) vars temps)) + (expanded `(multiple-value-bind ,temps + ,(caddr form) + ,@sets)) (walked (walk-form-internal expanded context env))) (if (eq walked expanded) form @@ -1767,13 +1779,11 @@ (defun walk-setq (form context env) (if (cdddr form) - (let* ((expanded - (let ((collect NIL) - (ptr (cdr form))) - (loop (push `(setq ,(car ptr) ,(cadr ptr)) collect) - (setf ptr (cddr ptr)) - (unless ptr - (return (nreverse collect)))))) + (let* ((expanded (let ((rforms nil) + (tail (cdr form))) + (loop (when (null tail) (return (nreverse rforms))) + (let ((var (pop tail)) (val (pop tail))) + (push `(setq ,var ,val) rforms))))) (walked (walk-repeat-eval expanded env))) (if (eq expanded walked) form @@ -1904,7 +1914,7 @@ Even if this is what~%~ you intended, you should fix your source code." form - (length (the list (cdr form)))) + (length (cdr form))) (cons 'progn (cdddr form))) (cadddr form)))) (relist form -- GitLab