X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fdefs.lisp;h=dc12f8469dd5446933cee40be968c140fabc6ee3;hb=bd0ba0f214518e8d72ff2d44de5a1e3e4b02af2c;hp=2ec1da607215a761c6de3046255ca975464c37d5;hpb=63cef087068afc157283c0a05ae1f16b962303aa;p=sbcl.git diff --git a/src/pcl/defs.lisp b/src/pcl/defs.lisp index 2ec1da6..dc12f84 100644 --- a/src/pcl/defs.lisp +++ b/src/pcl/defs.lisp @@ -102,6 +102,7 @@ *the-class-generic-function* *the-class-built-in-class* *the-class-slot-class* + *the-class-condition-class* *the-class-structure-class* *the-class-std-class* *the-class-standard-class* @@ -148,9 +149,10 @@ :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) + (ensure-non-standard-class (classoid-name type)))) ((specializerp type) type))) ;;; interface @@ -216,7 +218,7 @@ ((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) @@ -283,36 +285,11 @@ (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*)) ;*** -(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)) @@ -382,17 +359,17 @@ (/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) @@ -427,25 +404,26 @@ (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*") @@ -455,22 +433,25 @@ (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 condition (slot-object instance) () + (:metaclass condition-class)) + +(defclass structure-object (slot-object instance) () (:metaclass structure-class)) (defstruct (dead-beef-structure-object @@ -480,10 +461,9 @@ (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)) @@ -494,7 +474,7 @@ (defclass definition-source-mixin (std-object) ((source - :initform *load-truename* + :initform *load-pathname* :reader definition-source :initarg :definition-source)) (:metaclass std-class)) @@ -540,7 +520,20 @@ :initform (cons nil nil)) (predicate-name :initform nil - :reader class-predicate-name))) + :reader class-predicate-name) + (finalized-p + :initform nil + :reader class-finalized-p))) + +(def!method make-load-form ((class class) &optional env) + ;; FIXME: should we not instead pass ENV to FIND-CLASS? Probably + ;; doesn't matter while all our environments are the same... + (declare (ignore env)) + (let ((name (class-name class))) + (unless (and name (eq (find-class name nil) class)) + (error "~@" + class)) + `(find-class ',name))) ;;; The class PCL-CLASS is an implementation-specific common ;;; superclass of all specified subclasses of the class CLASS. @@ -587,6 +580,8 @@ (defclass built-in-class (pcl-class) ()) +(defclass condition-class (slot-class) ()) + (defclass structure-class (slot-class) ((defstruct-form :initform () @@ -667,7 +662,21 @@ ((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 condition-slot-definition (slot-definition) + ((allocation + :initform :instance + :initarg :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 @@ -706,6 +715,14 @@ :initform nil :accessor slot-definition-location))) +(defclass condition-direct-slot-definition (condition-slot-definition + direct-slot-definition) + ()) + +(defclass condition-effective-slot-definition (condition-slot-definition + effective-slot-definition) + ()) + (defclass structure-direct-slot-definition (structure-slot-definition direct-slot-definition) ()) @@ -794,6 +811,10 @@ (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) @@ -818,6 +839,14 @@ :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) @@ -828,6 +857,7 @@ (std-class std-class-p) (standard-class standard-class-p) (funcallable-standard-class funcallable-standard-class-p) + (condition-class condition-class-p) (structure-class structure-class-p) (forward-referenced-class forward-referenced-class-p) (method method-p) @@ -838,5 +868,6 @@ (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)))