:object (coerce-to-class (car args))))
(class-eq (class-eq-specializer (coerce-to-class (car args))))
(eql (intern-eql-specializer (car args))))))
- ((and (null args) (typep type 'cl:class))
- (or (sb-kernel:class-pcl-class type)
- (find-structure-class (cl:class-name type))))
+ ;; FIXME: do we still need this?
+ ((and (null args) (typep type 'classoid))
+ (or (classoid-pcl-class type)
+ (find-structure-class (classoid-name type))))
((specializerp type) type)))
;;; interface
(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
((not and or) `(,(car type) ,@(mapcar #'convert-to-system-type
(cdr type))))
((class class-eq) ; class-eq is impossible to do right
- (sb-kernel:layout-class (class-wrapper (cadr type))))
+ (layout-classoid (class-wrapper (cadr type))))
(eql type)
(t (if (null (cdr type))
(car type)
(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))
(/show "about to set up SB-PCL::*BUILT-IN-CLASSES*")
(defvar *built-in-classes*
(labels ((direct-supers (class)
- (/noshow "entering DIRECT-SUPERS" (sb-kernel::class-name class))
- (if (typep class 'cl:built-in-class)
- (sb-kernel:built-in-class-direct-superclasses class)
- (let ((inherits (sb-kernel:layout-inherits
- (sb-kernel:class-layout class))))
+ (/noshow "entering DIRECT-SUPERS" (classoid-name class))
+ (if (typep class 'built-in-classoid)
+ (built-in-classoid-direct-superclasses class)
+ (let ((inherits (layout-inherits
+ (classoid-layout class))))
(/noshow inherits)
(list (svref inherits (1- (length inherits)))))))
(direct-subs (class)
- (/noshow "entering DIRECT-SUBS" (sb-kernel::class-name class))
+ (/noshow "entering DIRECT-SUBS" (classoid-name class))
(collect ((res))
- (let ((subs (sb-kernel:class-subclasses class)))
+ (let ((subs (classoid-subclasses class)))
(/noshow subs)
(when subs
(dohash (sub v subs)
(mapcar (lambda (kernel-bic-entry)
(/noshow "setting up" kernel-bic-entry)
(let* ((name (car kernel-bic-entry))
- (class (cl:find-class name)))
+ (class (find-classoid name)))
(/noshow name class)
`(,name
- ,(mapcar #'cl:class-name (direct-supers class))
- ,(mapcar #'cl:class-name (direct-subs class))
+ ,(mapcar #'classoid-name (direct-supers class))
+ ,(mapcar #'classoid-name (direct-subs class))
,(map 'list
(lambda (x)
- (cl:class-name (sb-kernel:layout-class x)))
+ (classoid-name
+ (layout-classoid x)))
(reverse
- (sb-kernel:layout-inherits
- (sb-kernel:class-layout class))))
+ (layout-inherits
+ (classoid-layout class))))
,(prototype name))))
(remove-if (lambda (kernel-bic-entry)
(member (first kernel-bic-entry)
;; I'm not sure why these are removed from
;; the list, but that's what the original
;; CMU CL code did. -- WHN 20000715
- '(t sb-kernel:instance
- sb-kernel:funcallable-instance
+ '(t instance
+ funcallable-instance
function stream)))
sb-kernel::*built-in-classes*))))
(/noshow "done setting up SB-PCL::*BUILT-IN-CLASSES*")
(defclass t () ()
(:metaclass built-in-class))
-(defclass sb-kernel:instance (t) ()
+(defclass instance (t) ()
(:metaclass built-in-class))
(defclass function (t) ()
(:metaclass built-in-class))
-(defclass sb-kernel:funcallable-instance (function) ()
+(defclass funcallable-instance (function) ()
(:metaclass built-in-class))
-(defclass stream (sb-kernel:instance) ()
+(defclass stream (instance) ()
(:metaclass built-in-class))
(defclass slot-object (t) ()
(:metaclass slot-class))
-(defclass structure-object (slot-object sb-kernel:instance) ()
+(defclass structure-object (slot-object instance) ()
(:metaclass structure-class))
(defstruct (dead-beef-structure-object
(defclass std-object (slot-object) ()
(:metaclass std-class))
-(defclass standard-object (std-object sb-kernel:instance) ())
+(defclass standard-object (std-object instance) ())
-(defclass funcallable-standard-object (std-object
- sb-kernel:funcallable-instance)
+(defclass funcallable-standard-object (std-object funcallable-instance)
()
(:metaclass funcallable-standard-class))
(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)))
projects / sbcl.git / blobdiff