their interaction with the cross-compiler dumper, should PCL ever be
moved to the main build.
-** SB-KERNEL
-
-Now that CL:CLASS has turned into SB-KERNEL:CLASSOID, SB-PCL can
-use-package SB-KERNEL. This should have the pleasant effect of
-ridding us of a fair amount of package prefix noise.
-
** SB-MOP
Now that a CL:CLASS is a real CLOS class, it might be worth giving
SB-PCL the SB-MOP nickname, since it now is in the region of
conforming to AMOP.
+** LEGAL-CLASS-NAME-P
+
+NIL is probably not a legal class name
"CLASSOID-LAYOUT" "CLASSOID-NAME"
"DD-RAW-LENGTH" "NOTE-NAME-DEFINED"
"%CODE-CODE-SIZE" "DD-SLOTS"
+ "DD-INCLUDE"
"%IMAGPART" "DSD-ACCESSOR-NAME"
"%CODE-DEBUG-INFO" "DSD-%NAME"
"LAYOUT-CLASSOID" "LAYOUT-INVALID"
"BECOME-DEFINED-FUN-NAME"
"%NUMERATOR" "CLASSOID-TYPEP"
"DSD-READ-ONLY"
+ "DSD-DEFAULT"
"LAYOUT-INHERITS" "DD-LENGTH" "%CODE-ENTRY-POINTS"
"%DENOMINATOR"
"%FUNCALLABLE-INSTANCE-INFO" "RANDOM-CHUNK"
"MAKE-FUNCALLABLE-STRUCTURE-CLASSOID" "LAYOUT-CLOS-HASH-MAX"
"CLASSOID-CELL-NAME" "BUILT-IN-CLASSOID-DIRECT-SUPERCLASSES"
+ "BUILT-IN-CLASSOID-TRANSLATION"
"RANDOM-LAYOUT-CLOS-HASH"
"CLASSOID-PCL-CLASS" "FUNCALLABLE-STRUCTURE"
"FUNCALLABLE-INSTANCE-FUN"
extensions, but even they are not guaranteed to be present in
later versions of SBCL, and the other stuff in here is
definitely not guaranteed to be present in later versions of SBCL."
- ;; FIXME: SB-PCL should probably USE-PACKAGE SB-KERNEL, since SB-PCL
- ;; is built on SB-KERNEL, and in the absence of USE-PACKAGE, it ends
- ;; up using a thundering herd of explicit prefixes to get to
- ;; SB-KERNEL symbols. However, it'll probably be too messy to do
- ;; this until the duplicate SB-PCL:CLASS/CL:CLASS hierarchy kludge
- ;; is unscrewed, since until it is there are too many things which
- ;; conflict between the two packages.
- :use ("CL" "SB!INT" "SB!EXT" "SB!WALKER")
+ :use ("CL" "SB!INT" "SB!EXT" "SB!WALKER" "SB!KERNEL")
:import-from (("SB!KERNEL" "FUNCALLABLE-INSTANCE-P" "%FUN-DOC"
"PACKAGE-DOC-STRING"
"PACKAGE-HASHTABLE-SIZE" "PACKAGE-HASHTABLE-FREE"
"PACKAGE-INTERNAL-SYMBOLS" "PACKAGE-EXTERNAL-SYMBOLS"))
+ ;; FIXME: should we now reexport CLASS and friends, too?
+ ;; Probably. See if AMOP has a list of exported symbols.
:reexport ("ADD-METHOD" "ALLOCATE-INSTANCE"
"COMPUTE-APPLICABLE-METHODS"
"ENSURE-GENERIC-FUNCTION"
#',fun-name))))
(defun compile-or-load-defgeneric (fun-name)
- (sb-kernel:proclaim-as-fun-name fun-name)
- (sb-kernel:note-name-defined fun-name :function)
+ (proclaim-as-fun-name fun-name)
+ (note-name-defined fun-name :function)
(unless (eq (info :function :where-from fun-name) :declared)
(setf (info :function :where-from fun-name) :defined)
(setf (info :function :type fun-name)
- (sb-kernel:specifier-type 'function))))
+ (specifier-type 'function))))
(defun load-defgeneric (fun-name lambda-list &rest initargs)
(when (fboundp fun-name)
- (sb-kernel::style-warn "redefining ~S in DEFGENERIC" fun-name)
+ (style-warn "redefining ~S in DEFGENERIC" fun-name)
(let ((fun (fdefinition fun-name)))
(when (generic-function-p fun)
(loop for method in (generic-function-initial-methods fun)
(parse-specializers specializers)
nil))))
(when method
- (sb-kernel::style-warn "redefining ~S~{ ~S~} ~S in DEFMETHOD"
- gf-spec qualifiers specializers))))
+ (style-warn "redefining ~S~{ ~S~} ~S in DEFMETHOD"
+ gf-spec qualifiers specializers))))
(let ((method (apply #'add-named-method
gf-spec qualifiers specializers lambda-list
:definition-source `((defmethod ,gf-spec
(analyze-lambda-list lambda-list)
(declare (ignore keyword-parameters))
(let* ((old (info :function :type name)) ;FIXME:FDOCUMENTATION instead?
- (old-ftype (if (sb-kernel:fun-type-p old) old nil))
- (old-restp (and old-ftype (sb-kernel:fun-type-rest old-ftype)))
+ (old-ftype (if (fun-type-p old) old nil))
+ (old-restp (and old-ftype (fun-type-rest old-ftype)))
(old-keys (and old-ftype
- (mapcar #'sb-kernel:key-info-name
- (sb-kernel:fun-type-keywords
+ (mapcar #'key-info-name
+ (fun-type-keywords
old-ftype))))
- (old-keysp (and old-ftype (sb-kernel:fun-type-keyp old-ftype)))
+ (old-keysp (and old-ftype (fun-type-keyp old-ftype)))
(old-allowp (and old-ftype
- (sb-kernel:fun-type-allowp old-ftype)))
+ (fun-type-allowp old-ftype)))
(keywords (union old-keys (mapcar #'keyword-spec-name keywords))))
`(function ,(append (make-list nrequired :initial-element t)
(when (plusp noptional)
fin
(or function
(if (eq spec 'print-object)
- #'(sb-kernel:instance-lambda (instance stream)
+ #'(instance-lambda (instance stream)
(print-unreadable-object (instance stream :identity t)
(format stream "std-instance")))
- #'(sb-kernel:instance-lambda (&rest args)
+ #'(instance-lambda (&rest args)
(declare (ignore args))
(error "The function of the funcallable-instance ~S~
has not been set." fin)))))
(get-instance-hash-code))))
(set-funcallable-instance-fun
fin
- #'(sb-kernel:instance-lambda (&rest args)
+ #'(instance-lambda (&rest args)
(declare (ignore args))
(error "The function of the funcallable-instance ~S has not been set."
fin)))
(dolist (e *built-in-classes*)
(destructuring-bind (name supers subs cpl prototype) e
(let* ((class (find-class name))
- (lclass (sb-kernel:find-classoid name))
- (wrapper (sb-kernel:classoid-layout lclass)))
+ (lclass (find-classoid name))
+ (wrapper (classoid-layout lclass)))
(set (get-built-in-class-symbol name) class)
(set (get-built-in-wrapper-symbol name) wrapper)
- (setf (sb-kernel:classoid-pcl-class lclass) class)
+ (setf (classoid-pcl-class lclass) class)
(!bootstrap-initialize-class 'built-in-class class
name class-eq-wrapper nil
(make-class-predicate class (class-predicate-name class))))))
\f
(defmacro wrapper-of-macro (x)
- `(sb-kernel:layout-of ,x))
+ `(layout-of ,x))
(defun class-of (x)
(wrapper-class* (wrapper-of-macro x)))
:metaclass 'structure-class
:name symbol
:direct-superclasses
- (mapcar #'sb-kernel:classoid-name
- (sb-kernel:classoid-direct-superclasses
- (sb-kernel:find-classoid symbol)))
+ (mapcar #'classoid-name
+ (classoid-direct-superclasses
+ (find-classoid symbol)))
:direct-slots
(mapcar #'slot-initargs-from-structure-slotd
(structure-type-slot-description-list
;;; Set the inherits from CPL, and register the layout. This actually
;;; installs the class in the Lisp type system.
(defun update-lisp-class-layout (class layout)
- (let ((lclass (sb-kernel:layout-classoid layout)))
- (unless (eq (sb-kernel:classoid-layout lclass) layout)
- (setf (sb-kernel:layout-inherits layout)
- (sb-kernel:order-layout-inherits
+ (let ((lclass (layout-classoid layout)))
+ (unless (eq (classoid-layout lclass) layout)
+ (setf (layout-inherits layout)
+ (order-layout-inherits
(map 'simple-vector #'class-wrapper
(reverse (rest (class-precedence-list class))))))
- (sb-kernel:register-layout layout :invalidate t)
+ (register-layout layout :invalidate t)
;; Subclasses of formerly forward-referenced-class may be
;; unknown to CL:FIND-CLASS and also anonymous. This
;; functionality moved here from (SETF FIND-CLASS).
(let ((name (class-name class)))
- (setf (sb-kernel:find-classoid name) lclass
- (sb-kernel:classoid-name lclass) name)))))
+ (setf (find-classoid name) lclass
+ (classoid-name lclass) name)))))
(defun set-class-type-translation (class name)
- (let ((classoid (sb-kernel:find-classoid name nil)))
+ (let ((classoid (find-classoid name nil)))
(etypecase classoid
(null)
- (sb-kernel:built-in-classoid
- (let ((translation (sb-kernel::built-in-classoid-translation classoid)))
+ (built-in-classoid
+ (let ((translation (built-in-classoid-translation classoid)))
(cond
(translation
- (aver (sb-kernel:ctype-p translation))
+ (aver (ctype-p translation))
(setf (info :type :translator class)
(lambda (spec) (declare (ignore spec)) translation)))
(t
(setf (info :type :translator class)
(lambda (spec) (declare (ignore spec)) classoid))))))
- (sb-kernel:classoid
+ (classoid
(setf (info :type :translator class)
(lambda (spec) (declare (ignore spec)) classoid))))))
(dohash (name x *find-class*)
(let* ((class (find-class-from-cell name x))
(layout (class-wrapper class))
- (lclass (sb-kernel:layout-classoid layout))
- (lclass-pcl-class (sb-kernel:classoid-pcl-class lclass))
- (olclass (sb-kernel:find-classoid name nil)))
+ (lclass (layout-classoid layout))
+ (lclass-pcl-class (classoid-pcl-class lclass))
+ (olclass (find-classoid name nil)))
(if lclass-pcl-class
(aver (eq class lclass-pcl-class))
- (setf (sb-kernel:classoid-pcl-class lclass) class))
+ (setf (classoid-pcl-class lclass) class))
(update-lisp-class-layout class layout)
(cond (olclass
(aver (eq lclass olclass)))
(t
- (setf (sb-kernel:find-classoid name) lclass)))
+ (setf (find-classoid name) lclass)))
(set-class-type-translation class name)))
1 (the fixnum (1+ old-count))))))))
(deftype field-type ()
- '(mod #.sb-kernel:layout-clos-hash-length))
+ '(mod #.layout-clos-hash-length))
(eval-when (:compile-toplevel :load-toplevel :execute)
(defun power-of-two-ceiling (x)
;;; are the forms of this constant which it is more convenient for the
;;; runtime code to use.
(defconstant wrapper-cache-number-length
- (integer-length sb-kernel:layout-clos-hash-max))
-(defconstant wrapper-cache-number-mask sb-kernel:layout-clos-hash-max)
+ (integer-length layout-clos-hash-max))
+(defconstant wrapper-cache-number-mask layout-clos-hash-max)
(defconstant wrapper-cache-number-adds-ok
- (truncate most-positive-fixnum sb-kernel:layout-clos-hash-max))
+ (truncate most-positive-fixnum layout-clos-hash-max))
\f
;;;; wrappers themselves
;;; have a fixed number of cache hash values, and that number must
;;; correspond to the number of cache lines we use.
(defconstant wrapper-cache-number-vector-length
- sb-kernel:layout-clos-hash-length)
+ layout-clos-hash-length)
(unless (boundp '*the-class-t*)
(setq *the-class-t* nil))
(defmacro wrapper-class (wrapper)
- `(sb-kernel:classoid-pcl-class (sb-kernel:layout-classoid ,wrapper)))
+ `(classoid-pcl-class (layout-classoid ,wrapper)))
(defmacro wrapper-no-of-instance-slots (wrapper)
- `(sb-kernel:layout-length ,wrapper))
+ `(layout-length ,wrapper))
(defmacro wrapper-instance-slots-layout (wrapper)
`(%wrapper-instance-slots-layout ,wrapper))
;;; whose slots are not initialized yet, and which may be built-in
;;; classes. We pass in the class name in addition to the class.
(defun boot-make-wrapper (length name &optional class)
- (let ((found (sb-kernel:find-classoid name nil)))
+ (let ((found (find-classoid name nil)))
(cond
(found
- (unless (sb-kernel:classoid-pcl-class found)
- (setf (sb-kernel:classoid-pcl-class found) class))
- (aver (eq (sb-kernel:classoid-pcl-class found) class))
- (let ((layout (sb-kernel:classoid-layout found)))
+ (unless (classoid-pcl-class found)
+ (setf (classoid-pcl-class found) class))
+ (aver (eq (classoid-pcl-class found) class))
+ (let ((layout (classoid-layout found)))
(aver layout)
layout))
(t
(make-wrapper-internal
:length length
- :classoid (sb-kernel:make-standard-classoid
+ :classoid (make-standard-classoid
:name name :pcl-class class))))))
;;; The following variable may be set to a STANDARD-CLASS that has
:classoid
(let ((owrap (class-wrapper class)))
(cond (owrap
- (sb-kernel:layout-classoid owrap))
+ (layout-classoid owrap))
((*subtypep (class-of class)
*the-class-standard-class*)
(cond ((and *pcl-class-boot*
(eq (slot-value class 'name) *pcl-class-boot*))
- (let ((found (sb-kernel:find-classoid
+ (let ((found (find-classoid
(slot-value class 'name))))
- (unless (sb-kernel:classoid-pcl-class found)
- (setf (sb-kernel:classoid-pcl-class found) class))
- (aver (eq (sb-kernel:classoid-pcl-class found) class))
+ (unless (classoid-pcl-class found)
+ (setf (classoid-pcl-class found) class))
+ (aver (eq (classoid-pcl-class found) class))
found))
(t
- (sb-kernel:make-standard-classoid :pcl-class class))))
+ (make-standard-classoid :pcl-class class))))
(t
- (sb-kernel:make-random-pcl-classoid :pcl-class class))))))
+ (make-random-pcl-classoid :pcl-class class))))))
(t
- (let* ((found (sb-kernel:find-classoid (slot-value class 'name)))
- (layout (sb-kernel:classoid-layout found)))
- (unless (sb-kernel:classoid-pcl-class found)
- (setf (sb-kernel:classoid-pcl-class found) class))
- (aver (eq (sb-kernel:classoid-pcl-class found) class))
+ (let* ((found (find-classoid (slot-value class 'name)))
+ (layout (classoid-layout found)))
+ (unless (classoid-pcl-class found)
+ (setf (classoid-pcl-class found) class))
+ (aver (eq (classoid-pcl-class found) class))
(aver layout)
layout))))
(defmacro cache-number-vector-ref (cnv n)
`(wrapper-cache-number-vector-ref ,cnv ,n))
(defmacro wrapper-cache-number-vector-ref (wrapper n)
- `(sb-kernel:layout-clos-hash ,wrapper ,n))
+ `(layout-clos-hash ,wrapper ,n))
(declaim (inline wrapper-class*))
(defun wrapper-class* (wrapper)
(or (wrapper-class wrapper)
(find-structure-class
- (sb-kernel:classoid-name (sb-kernel:layout-classoid wrapper)))))
+ (classoid-name (layout-classoid wrapper)))))
;;; The wrapper cache machinery provides general mechanism for
;;; trapping on the next access to any instance of a given class. This
(declaim (inline invalid-wrapper-p))
(defun invalid-wrapper-p (wrapper)
- (not (null (sb-kernel:layout-invalid wrapper))))
+ (not (null (layout-invalid wrapper))))
(defvar *previous-nwrappers* (make-hash-table))
(push previous new-previous))
(let ((ocnv (wrapper-cache-number-vector owrapper)))
- (dotimes (i sb-kernel:layout-clos-hash-length)
+ (dotimes (i layout-clos-hash-length)
(setf (cache-number-vector-ref ocnv i) 0)))
- (push (setf (sb-kernel:layout-invalid owrapper) (list state nwrapper))
+ (push (setf (layout-invalid owrapper) (list state nwrapper))
new-previous)
(setf (gethash owrapper *previous-nwrappers*) ()
(defun check-wrapper-validity (instance)
(let* ((owrapper (wrapper-of instance))
- (state (sb-kernel:layout-invalid owrapper)))
+ (state (layout-invalid owrapper)))
(if (null state)
owrapper
(ecase (car state)
(declaim (inline check-obsolete-instance))
(defun check-obsolete-instance (instance)
- (when (invalid-wrapper-p (sb-kernel:layout-of instance))
+ (when (invalid-wrapper-p (layout-of instance))
(check-wrapper-validity instance)))
\f
(defvar *free-caches* nil)
((csubtypep otype std-obj) t)
((not (types-equal-or-intersect otype std-obj)) nil)
(t
- `(typep (sb-kernel:layout-of object) 'sb-pcl::wrapper)))))
+ `(typep (layout-of object) 'sb-pcl::wrapper)))))
(define-source-context defmethod (name &rest stuff)
(let ((arg-pos (position-if #'listp stuff)))
;;; When the optimized function is computed, the function of the
;;; funcallable instance is set to it.
;;;
-(sb-kernel:!defstruct-with-alternate-metaclass ctor
+(!defstruct-with-alternate-metaclass ctor
:slot-names (function-name class-name class initargs)
:boa-constructor %make-ctor
:superclass-name pcl-funcallable-instance
- :metaclass-name sb-kernel:random-pcl-classoid
- :metaclass-constructor sb-kernel:make-random-pcl-classoid
- :dd-type sb-kernel:funcallable-structure
+ :metaclass-name random-pcl-classoid
+ :metaclass-constructor make-random-pcl-classoid
+ :dd-type funcallable-structure
:runtime-type-checks-p nil)
;;; List of all defined ctors.
(defun install-initial-constructor (ctor &key force-p)
(when (or force-p (ctor-class ctor))
(setf (ctor-class ctor) nil)
- (setf (sb-kernel:funcallable-instance-fun ctor)
- #'(sb-kernel:instance-lambda (&rest args)
+ (setf (funcallable-instance-fun ctor)
+ #'(instance-lambda (&rest args)
(install-optimized-constructor ctor)
(apply ctor args)))
- (setf (sb-kernel:%funcallable-instance-info ctor 1)
+ (setf (%funcallable-instance-info ctor 1)
(ctor-function-name ctor))))
;;;
(function-name (make-ctor-function-name class-name initargs)))
;;
;; Prevent compiler warnings for calling the ctor.
- (sb-kernel:proclaim-as-fun-name function-name)
- (sb-kernel:note-name-defined function-name :function)
+ (proclaim-as-fun-name function-name)
+ (note-name-defined function-name :function)
(when (eq (info :function :where-from function-name) :assumed)
(setf (info :function :where-from function-name) :defined)
(when (info :function :assumed-type function-name)
(finalize-inheritance class))
(setf (ctor-class ctor) class)
(pushnew ctor (plist-value class 'ctors))
- (setf (sb-kernel:funcallable-instance-fun ctor)
+ (setf (funcallable-instance-fun ctor)
;; KLUDGE: Gerd here has the equivalent of (COMPILE NIL
;; (CONSTRUCTOR-FUNCTION-FORM)), but SBCL's COMPILE doesn't
;; deal with INSTANCE-LAMBDA expressions, only with LAMBDA
(defun fallback-generator (ctor ii-methods si-methods)
(declare (ignore ii-methods si-methods))
- `(sb-kernel:instance-lambda ,(make-ctor-parameter-list ctor)
+ `(instance-lambda ,(make-ctor-parameter-list ctor)
(make-instance ,(ctor-class ctor) ,@(ctor-initargs ctor))))
(defun optimizing-generator (ctor ii-methods si-methods)
(multiple-value-bind (body before-method-p)
(fake-initialization-emf ctor ii-methods si-methods)
- `(sb-kernel:instance-lambda ,(make-ctor-parameter-list ctor)
+ `(instance-lambda ,(make-ctor-parameter-list ctor)
(declare #.*optimize-speed*)
,(wrap-in-allocate-forms ctor body before-method-p))))
`(let ((.instance. (%make-standard-instance nil
(get-instance-hash-code)))
(.slots. (make-array
- ,(sb-kernel:layout-length wrapper)
+ ,(layout-length wrapper)
,@(when before-method-p
'(:initial-element +slot-unbound+)))))
(setf (std-instance-wrapper .instance.) ,wrapper)
(initargs (ctor-initargs ctor))
(initkeys (plist-keys initargs))
(slot-vector
- (make-array (sb-kernel:layout-length (class-wrapper class))
+ (make-array (layout-length (class-wrapper class))
:initial-element nil))
(class-inits ())
(default-initargs (class-default-initargs class))
(class-eq (class-eq-specializer (coerce-to-class (car args))))
(eql (intern-eql-specializer (car args))))))
;; FIXME: do we still need this?
- ((and (null args) (typep type 'sb-kernel:classoid))
- (or (sb-kernel:classoid-pcl-class type)
- (find-structure-class (sb-kernel:classoid-name type))))
+ ((and (null args) (typep type 'classoid))
+ (or (classoid-pcl-class type)
+ (find-structure-class (classoid-name type))))
((specializerp type) type)))
;;; interface
((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-classoid (class-wrapper (cadr type))))
+ (layout-classoid (class-wrapper (cadr type))))
(eql type)
(t (if (null (cdr type))
(car type)
(/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 'sb-kernel:built-in-classoid)
- (sb-kernel:built-in-classoid-direct-superclasses class)
- (let ((inherits (sb-kernel:layout-inherits
- (sb-kernel:classoid-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:classoid-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 (sb-kernel:find-classoid name)))
+ (class (find-classoid name)))
(/noshow name class)
`(,name
- ,(mapcar #'sb-kernel:classoid-name (direct-supers class))
- ,(mapcar #'sb-kernel:classoid-name (direct-subs class))
+ ,(mapcar #'classoid-name (direct-supers class))
+ ,(mapcar #'classoid-name (direct-subs class))
,(map 'list
(lambda (x)
- (sb-kernel:classoid-name
- (sb-kernel:layout-classoid x)))
+ (classoid-name
+ (layout-classoid x)))
(reverse
- (sb-kernel:layout-inherits
- (sb-kernel:classoid-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))
(defun make-initial-dfun (gf)
(let ((initial-dfun
- #'(sb-kernel:instance-lambda (&rest args)
+ #'(instance-lambda (&rest args)
(initial-dfun gf args))))
(multiple-value-bind (dfun cache info)
(if (and (eq *boot-state* 'complete)
(let* ((methods (early-gf-methods gf))
(slot-name (early-method-standard-accessor-slot-name (car methods))))
(ecase type
- (reader #'(sb-kernel:instance-lambda (instance)
+ (reader #'(instance-lambda (instance)
(let* ((class (class-of instance))
(class-name (!bootstrap-get-slot 'class class 'name)))
(!bootstrap-get-slot class-name instance slot-name))))
- (boundp #'(sb-kernel:instance-lambda (instance)
+ (boundp #'(instance-lambda (instance)
(let* ((class (class-of instance))
(class-name (!bootstrap-get-slot 'class class 'name)))
(not (eq +slot-unbound+
(!bootstrap-get-slot class-name
instance slot-name))))))
- (writer #'(sb-kernel:instance-lambda (new-value instance)
+ (writer #'(instance-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)))))))
specls all-same-p)
(cond ((null methods)
(values
- #'(sb-kernel:instance-lambda (&rest args)
+ #'(instance-lambda (&rest args)
(apply #'no-applicable-method gf args))
nil
(no-methods-dfun-info)))
(if function-p
(lambda (method-alist wrappers)
(declare (ignore method-alist wrappers))
- #'(sb-kernel:instance-lambda (&rest args)
+ #'(instance-lambda (&rest args)
(apply #'no-applicable-method gf args)))
(lambda (method-alist wrappers)
(declare (ignore method-alist wrappers))
(lambda `(lambda ,closure-variables
,@(when (member 'miss-fn closure-variables)
`((declare (type function miss-fn))))
- #'(sb-kernel:instance-lambda ,args
+ #'(instance-lambda ,args
(let ()
(declare #.*optimize-speed*)
,form)))))
(if cached-emf-p
(lambda (cache miss-fn)
(declare (type function miss-fn))
- #'(sb-kernel:instance-lambda (&rest args)
+ #'(instance-lambda (&rest args)
(declare #.*optimize-speed*)
(with-dfun-wrappers (args metatypes)
(dfun-wrappers invalid-wrapper-p)
(invoke-emf emf args))))))))
(lambda (cache emf miss-fn)
(declare (type function miss-fn))
- #'(sb-kernel:instance-lambda (&rest args)
+ #'(instance-lambda (&rest args)
(declare #.*optimize-speed*)
(with-dfun-wrappers (args metatypes)
(dfun-wrappers invalid-wrapper-p)
;;; it needs a more mnemonic name. -- WHN 19991204
(defun structure-type-p (type)
(and (symbolp type)
- (let ((classoid (sb-kernel:find-classoid type nil)))
+ (let ((classoid (find-classoid type nil)))
(and classoid
- (typep (sb-kernel:layout-info
- (sb-kernel:classoid-layout classoid))
- 'sb-kernel:defstruct-description)))))
+ (typep (layout-info
+ (classoid-layout classoid))
+ 'defstruct-description)))))
\f
(/show "finished with early-low.lisp")
(defmethod make-load-form ((object wrapper) &optional env)
(declare (ignore env))
- (let ((pname (sb-kernel:classoid-proper-name
- (sb-kernel:layout-classoid object))))
+ (let ((pname (classoid-proper-name
+ (layout-classoid object))))
(unless pname
(error "can't dump wrapper for anonymous class:~% ~S"
- (sb-kernel:layout-classoid object)))
- `(sb-kernel:classoid-layout (sb-kernel:find-classoid ',pname))))
+ (layout-classoid object)))
+ `(classoid-layout (find-classoid ',pname))))
;; even if it hasn't been defined yet, the user doesn't get
;; obscure warnings about undefined internal implementation
;; functions like HAIRY-MAKE-instance-name.
- (sb-kernel:become-defined-fun-name sym)
+ (become-defined-fun-name sym)
`(,sym ',class (list ,@initargs)))))))
(defmacro expanding-make-instance-toplevel (&rest forms &environment env)
;;; this shouldn't matter, since the only two slots that WRAPPER adds
;;; are meaningless in those cases.
(defstruct (wrapper
- (:include sb-kernel:layout
+ (:include layout
;; KLUDGE: In CMU CL, the initialization default
;; for LAYOUT-INVALID was NIL. In SBCL, that has
;; changed to :UNINITIALIZED, but PCL code might
\f
;;;; PCL's view of funcallable instances
-(sb-kernel:!defstruct-with-alternate-metaclass pcl-funcallable-instance
+(!defstruct-with-alternate-metaclass pcl-funcallable-instance
;; KLUDGE: Note that neither of these slots is ever accessed by its
;; accessor name as of sbcl-0.pre7.63. Presumably everything works
;; by puns based on absolute locations. Fun fun fun.. -- WHN 2001-10-30
:slot-names (clos-slots name hash-code)
:boa-constructor %make-pcl-funcallable-instance
- :superclass-name sb-kernel:funcallable-instance
- :metaclass-name sb-kernel:random-pcl-classoid
- :metaclass-constructor sb-kernel:make-random-pcl-classoid
- :dd-type sb-kernel:funcallable-structure
+ :superclass-name funcallable-instance
+ :metaclass-name random-pcl-classoid
+ :metaclass-constructor make-random-pcl-classoid
+ :dd-type funcallable-structure
;; Only internal implementation code will access these, and these
;; accesses (slot readers in particular) could easily be a
;; bottleneck, so it seems reasonable to suppress runtime type
(defun set-funcallable-instance-fun (fin new-value)
(declare (type function new-value))
(aver (funcallable-instance-p fin))
- (setf (sb-kernel:funcallable-instance-fun fin) new-value))
+ (setf (funcallable-instance-fun fin) new-value))
(defmacro fsc-instance-p (fin)
`(funcallable-instance-p ,fin))
(defmacro fsc-instance-wrapper (fin)
- `(sb-kernel:%funcallable-instance-layout ,fin))
+ `(%funcallable-instance-layout ,fin))
;;; FIXME: This seems to bear no relation at all to the CLOS-SLOTS
;;; slot in the FUNCALLABLE-INSTANCE structure, above, which
;;; (bizarrely) seems to be set to the NAME of the
;;; FUNCALLABLE-INSTANCE. At least, the index 1 seems to return the
;;; NAME, and the index 2 NIL. Weird. -- CSR, 2002-11-07
(defmacro fsc-instance-slots (fin)
- `(sb-kernel:%funcallable-instance-info ,fin 0))
+ `(%funcallable-instance-info ,fin 0))
(defmacro fsc-instance-hash (fin)
- `(sb-kernel:%funcallable-instance-info ,fin 3))
+ `(%funcallable-instance-info ,fin 3))
\f
(declaim (inline clos-slots-ref (setf clos-slots-ref)))
(declaim (ftype (function (simple-vector index) t) clos-slots-ref))
;;; few uses of (OR STD-INSTANCE-P FSC-INSTANCE-P) are changed to
;;; PCL-INSTANCE-P.
(defmacro std-instance-p (x)
- `(sb-kernel:%instancep ,x))
+ `(%instancep ,x))
;; a temporary definition used for debugging the bootstrap
#+sb-show
(if (if (eq *boot-state* 'complete)
(typep fcn 'generic-function)
(eq (class-of fcn) *the-class-standard-generic-function*))
- (setf (sb-kernel:%funcallable-instance-info fcn 1) new-name)
+ (setf (%funcallable-instance-info fcn 1) new-name)
(bug "unanticipated function type"))
fcn)
(t
;; it loses some info of potential hacking value. So,
;; lets not do this...
#+nil
- (let ((header (sb-kernel:%closure-fun fcn)))
- (setf (sb-kernel:%simple-fun-name header) new-name))
+ (let ((header (%closure-fun fcn)))
+ (setf (%simple-fun-name header) new-name))
;; XXX Maybe add better scheme here someday.
fcn)))
\f
;;; This definition is for interpreted code.
(defun pcl-instance-p (x)
- (typep (sb-kernel:layout-of x) 'wrapper))
+ (typep (layout-of x) 'wrapper))
;;; CMU CL comment:
;;; We define this as STANDARD-INSTANCE, since we're going to
(:predicate nil)
(:constructor %%allocate-instance--class ())
(:copier nil)
- (:alternate-metaclass sb-kernel:instance
+ (:alternate-metaclass instance
cl:standard-class
- sb-kernel:make-standard-class))
+ make-standard-class))
(slots nil))
|#
-(sb-kernel:!defstruct-with-alternate-metaclass standard-instance
+(!defstruct-with-alternate-metaclass standard-instance
:slot-names (slots hash-code)
:boa-constructor %make-standard-instance
- :superclass-name sb-kernel:instance
- :metaclass-name sb-kernel:standard-classoid
- :metaclass-constructor sb-kernel:make-standard-classoid
+ :superclass-name instance
+ :metaclass-name standard-classoid
+ :metaclass-constructor make-standard-classoid
:dd-type structure
:runtime-type-checks-p nil)
;;; Both of these operations "work" on structures, which allows the above
;;; weakening of STD-INSTANCE-P.
-(defmacro std-instance-slots (x) `(sb-kernel:%instance-ref ,x 1))
-(defmacro std-instance-wrapper (x) `(sb-kernel:%instance-layout ,x))
+(defmacro std-instance-slots (x) `(%instance-ref ,x 1))
+(defmacro std-instance-wrapper (x) `(%instance-layout ,x))
;;; KLUDGE: This one doesn't "work" on structures. However, we
;;; ensure, in SXHASH and friends, never to call it on structures.
-(defmacro std-instance-hash (x) `(sb-kernel:%instance-ref ,x 2))
+(defmacro std-instance-hash (x) `(%instance-ref ,x 2))
;;; FIXME: These functions are called every place we do a
;;; CALL-NEXT-METHOD, and probably other places too. It's likely worth
(when (pcl-instance-p instance)
(get-slots instance)))
-(defmacro built-in-or-structure-wrapper (x) `(sb-kernel:layout-of ,x))
+(defmacro built-in-or-structure-wrapper (x) `(layout-of ,x))
(defmacro get-wrapper (inst)
(once-only ((wrapper `(wrapper-of ,inst)))
;;; The definition of STRUCTURE-TYPE-P was moved to early-low.lisp.
(defun get-structure-dd (type)
- (sb-kernel:layout-info (sb-kernel:classoid-layout
- (sb-kernel:find-classoid type))))
+ (layout-info (classoid-layout (find-classoid type))))
(defun structure-type-included-type-name (type)
- (let ((include (sb-kernel::dd-include (get-structure-dd type))))
+ (let ((include (dd-include (get-structure-dd type))))
(if (consp include)
(car include)
include)))
(defun structure-type-slot-description-list (type)
(nthcdr (length (let ((include (structure-type-included-type-name type)))
(and include
- (sb-kernel:dd-slots (get-structure-dd include)))))
- (sb-kernel:dd-slots (get-structure-dd type))))
+ (dd-slots (get-structure-dd include)))))
+ (dd-slots (get-structure-dd type))))
(defun structure-slotd-name (slotd)
- (sb-kernel:dsd-name slotd))
+ (dsd-name slotd))
(defun structure-slotd-accessor-symbol (slotd)
- (sb-kernel:dsd-accessor-name slotd))
+ (dsd-accessor-name slotd))
(defun structure-slotd-reader-function (slotd)
- (fdefinition (sb-kernel:dsd-accessor-name slotd)))
+ (fdefinition (dsd-accessor-name slotd)))
(defun structure-slotd-writer-function (slotd)
- (unless (sb-kernel:dsd-read-only slotd)
- (fdefinition `(setf ,(sb-kernel:dsd-accessor-name slotd)))))
+ (unless (dsd-read-only slotd)
+ (fdefinition `(setf ,(dsd-accessor-name slotd)))))
(defun structure-slotd-type (slotd)
- (sb-kernel:dsd-type slotd))
+ (dsd-type slotd))
(defun structure-slotd-init-form (slotd)
- (sb-kernel::dsd-default slotd))
+ (dsd-default slotd))
(or (find-class-cell-class ,class-cell)
,(if errorp
`(find-class-from-cell ',symbol ,class-cell t)
- `(and (sb-kernel:classoid-cell-classoid
- ',(sb-kernel:find-classoid-cell symbol))
+ `(and (classoid-cell-classoid
+ ',(find-classoid-cell symbol))
(find-class-from-cell ',symbol ,class-cell nil))))))
form))
&rest other-initargs)
(unless (and (fboundp generic-function-name)
(typep (fdefinition generic-function-name) 'generic-function))
- (sb-kernel::style-warn "implicitly creating new generic function ~S"
- generic-function-name))
+ (style-warn "implicitly creating new generic function ~S"
+ generic-function-name))
;; XXX What about changing the class of the generic function if
;; there is one? Whose job is that, anyway? Do we need something
;; kind of like CLASS-FOR-REDEFINITION?
(cond ((eq class *the-class-t*)
t)
((eq class *the-class-slot-object*)
- `(not (typep (sb-kernel:classoid-of ,arg)
- 'sb-kernel:built-in-classoid)))
+ `(not (typep (classoid-of ,arg)
+ 'built-in-classoid)))
((eq class *the-class-std-object*)
`(or (std-instance-p ,arg) (fsc-instance-p ,arg)))
((eq class *the-class-standard-object*)
(make-fast-method-call-lambda-list metatypes applyp))))
(multiple-value-bind (cfunction constants)
(get-fun1 `(,(if function-p
- 'sb-kernel:instance-lambda
+ 'instance-lambda
'lambda)
,arglist
,@(unless function-p
(setf (slot-value class 'class-precedence-list)
(compute-class-precedence-list class))
(setf (slot-value class 'slots) (compute-slots class))
- (let ((lclass (sb-kernel:find-classoid (class-name class))))
- (setf (sb-kernel:classoid-pcl-class lclass) class)
- (setf (slot-value class 'wrapper) (sb-kernel:classoid-layout lclass)))
+ (let ((lclass (find-classoid (class-name class))))
+ (setf (classoid-pcl-class lclass) class)
+ (setf (slot-value class 'wrapper) (classoid-layout lclass)))
(update-pv-table-cache-info class)
(setq predicate-name (if predicate-name-p
(setf (slot-value class 'predicate-name)
;;; obsolete the wrapper.
;;;
;;; FIXME: either here or in INVALID-WRAPPER-P looks like a good place
-;;; for (AVER (NOT (EQ (SB-KERNEL:LAYOUT-INVALID OWRAPPER)
+;;; for (AVER (NOT (EQ (LAYOUT-INVALID OWRAPPER)
;;; :UNINITIALIZED)))
;;;
;;; Thanks to Gerd Moellmann for the explanation. -- CSR, 2002-10-29
;; a violation of locality or what might be considered
;; good style. There has to be a better way! -- CSR,
;; 2002-10-29
- (eq (sb-kernel:layout-invalid owrapper) t))
+ (eq (layout-invalid owrapper) t))
(let ((nwrapper (make-wrapper (wrapper-no-of-instance-slots owrapper)
class)))
(setf (wrapper-instance-slots-layout nwrapper)
;;; versions, especially for internal versions off the main CVS
;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.7.13.pcl-class.1"
+"0.7.13.pcl-class.2"
projects / sbcl.git / commitdiff