(defun class-eq-type (class)
(specializer-type (class-eq-specializer class)))
-(defun inform-type-system-about-std-class (name)
- (let ((predicate-name (make-type-predicate-name name)))
- (setf (gdefinition predicate-name)
- (make-type-predicate name))))
-
-(defun make-type-predicate (name)
- (let ((cell (find-class-cell name)))
- (lambda (x)
- (funcall (the function (find-class-cell-predicate cell)) x))))
-
-(defun make-type-predicate-name (name &optional kind)
- (if (symbol-package name)
- (intern (format nil
- "~@[~A ~]TYPE-PREDICATE ~A ~A"
- kind
- (package-name (symbol-package name))
- (symbol-name name))
- *pcl-package*)
- (make-symbol (format nil
- "~@[~A ~]TYPE-PREDICATE ~A"
- kind
- (symbol-name name)))))
-
;;; internal to this file..
;;;
;;; These functions are a pale imitation of their namesake. They accept
(defvar *name->class->slotd-table* (make-hash-table))
-;;; This is used by combined methods to communicate the next methods
-;;; to the methods they call. This variable is captured by a lexical
-;;; variable of the methods to give it the proper lexical scope.
-(defvar *next-methods* nil)
-
-(defvar *not-an-eql-specializer* '(not-an-eql-specializer))
-
-(defvar *umi-gfs*)
-(defvar *umi-complete-classes*)
-(defvar *umi-reorder*)
-
-(defvar *invalidate-discriminating-function-force-p* ())
-(defvar *invalid-dfuns-on-stack* ())
-
(defvar *standard-method-combination*)
-
-(defvar *slotd-unsupplied* (list '*slotd-unsupplied*)) ;***
\f
-(defmacro define-gf-predicate (predicate-name &rest classes)
- `(progn
- (defmethod ,predicate-name ((x t)) nil)
- ,@(mapcar (lambda (c) `(defmethod ,predicate-name ((x ,c)) t))
- classes)))
-
(defun make-class-predicate-name (name)
- (intern (format nil "~A::~A class predicate"
- (package-name (symbol-package name))
- name)
- *pcl-package*))
-
+ (list 'class-predicate name))
+
(defun plist-value (object name)
(getf (object-plist object) name))
(defclass definition-source-mixin (std-object)
((source
- :initform *load-truename*
+ :initform *load-pathname*
:reader definition-source
:initarg :definition-source))
(:metaclass std-class))
(:metaclass std-class))
;;; The class CLASS is a specified basic class. It is the common
-;;; superclass of any kind of class. That is any class that can be a
+;;; superclass 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
(direct-superclasses
:initform ()
:reader class-direct-superclasses)
+ ;; Note: The (CLASS-)DIRECT-SUBCLASSES for STRUCTURE-CLASSes and
+ ;; CONDITION-CLASSes are lazily computed whenever the subclass info
+ ;; becomes available, i.e. when the PCL class is created.
(direct-subclasses
:initform ()
:reader class-direct-subclasses)
((allocation
:initform :instance
:initarg :allocation
- :accessor slot-definition-allocation)))
+ :accessor slot-definition-allocation)
+ (allocation-class
+ :initform nil
+ :initarg :allocation-class
+ :accessor slot-definition-allocation-class)))
(defclass structure-slot-definition (slot-definition)
((defstruct-accessor-symbol
(method-combination
:initarg :method-combination
:accessor generic-function-method-combination)
+ (declarations
+ :initarg :declarations
+ :initform ()
+ :accessor generic-function-declarations)
(arg-info
:initform (make-arg-info)
:reader gf-arg-info)
:reader method-combination-options
:initarg :options)))
+(defclass long-method-combination (standard-method-combination)
+ ((function
+ :initarg :function
+ :reader long-method-combination-function)
+ (args-lambda-list
+ :initarg :args-lambda-list
+ :reader long-method-combination-args-lambda-list)))
+
(defparameter *early-class-predicates*
'((specializer specializerp)
(exact-class-specializer exact-class-specializer-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)))
+ (method-combination method-combination-p)
+ (long-method-combination long-method-combination-p)))