(i 0 (1+ i)))
((>= i no-of-slots)) ;endp rem-slots))
(declare (list rem-slots)
- (type sb-int:index i))
+ (type index i))
(setf (aref slots i) (first rem-slots)))
slots))
(t
(find-class ',class) ,class)))
classes)))
-(defun bootstrap-meta-braid ()
+(defun !bootstrap-meta-braid ()
(let* ((name 'class)
(predicate-name (make-type-predicate-name name)))
(setf (gdefinition predicate-name)
(t
(boot-make-wrapper (length slots) name))))
(proto nil))
- (when (eq name 't) (setq *the-wrapper-of-t* wrapper))
+ (when (eq name t) (setq *the-wrapper-of-t* wrapper))
(set (intern (format nil "*THE-CLASS-~A*" (symbol-name name))
*pcl-package*)
class)
(allocate-standard-instance wrapper)))
(setq direct-slots
- (bootstrap-make-slot-definitions
+ (!bootstrap-make-slot-definitions
name class direct-slots
standard-direct-slot-definition-wrapper nil))
(setq slots
- (bootstrap-make-slot-definitions
+ (!bootstrap-make-slot-definitions
name class slots
standard-effective-slot-definition-wrapper t))
(case meta
((std-class standard-class funcallable-standard-class)
- (bootstrap-initialize-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
+ (!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
+ (!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
+ (!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-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)))
+ (!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.")
;;; Initialize a class metaobject.
;;;
-;;; FIXME: This and most stuff in this file is probably only needed at init
-;;; time.
-(defun bootstrap-initialize-class
+;;; FIXME: This and most stuff in this file is probably only needed at
+;;; init time.
+(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 metaclass-name class slot-name value)))
+ (!bootstrap-set-slot metaclass-name class slot-name value)))
(set-slot 'name name)
(set-slot 'source source)
- (set-slot 'type (if (eq class (find-class 't))
+ (set-slot 'type (if (eq class (find-class t))
t
+ ;; FIXME: Could this just be CLASS instead
+ ;; of `(CLASS ,CLASS)? If not, why not?
+ ;; (See also similar expression in
+ ;; SHARED-INITIALIZE :BEFORE (CLASS).)
`(class ,class)))
(set-slot 'class-eq-specializer
(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)
+ (!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)))
(make-class-predicate-name name)))
(set-slot 'defstruct-form
`(defstruct (structure-object (:constructor
- ,constructor-sym))))
+ ,constructor-sym)
+ (:copier nil))))
(set-slot 'defstruct-constructor constructor-sym)
(set-slot 'from-defclass-p t)
(set-slot 'plist nil)
(set-slot 'prototype (or proto (allocate-standard-instance wrapper))))
class))
-(defun bootstrap-make-slot-definitions (name class slots wrapper effective-p)
+(defun !bootstrap-make-slot-definitions (name class slots wrapper effective-p)
(let ((index -1))
- (mapcar #'(lambda (slot)
- (incf index)
- (bootstrap-make-slot-definition
- name class slot wrapper effective-p index))
+ (mapcar (lambda (slot)
+ (incf index)
+ (!bootstrap-make-slot-definition
+ name class slot wrapper effective-p index))
slots)))
-(defun bootstrap-make-slot-definition
+(defun !bootstrap-make-slot-definition
(name class slot wrapper effective-p index)
(let* ((slotd-class-name (if effective-p
'standard-effective-slot-definition
(slot-name (getf slot :name)))
(flet ((get-val (name) (getf slot name))
(set-val (name val)
- (bootstrap-set-slot slotd-class-name slotd name val)))
- (set-val 'name slot-name)
+ (!bootstrap-set-slot slotd-class-name slotd name val)))
+ (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 'type (or (get-val :type) t))
(set-val 'documentation (or (get-val :documentation) ""))
(set-val 'class class)
(when effective-p
(setq *the-eslotd-funcallable-standard-class-slots* slotd))
slotd)))
-(defun bootstrap-accessor-definitions (early-p)
+(defun !bootstrap-accessor-definitions (early-p)
(let ((*early-p* early-p))
(dolist (definition *early-class-definitions*)
(let ((name (ecd-class-name definition))
(let ((slot-name (getf slotd :name))
(readers (getf slotd :readers))
(writers (getf slotd :writers)))
- (bootstrap-accessor-definitions1
+ (!bootstrap-accessor-definitions1
name
slot-name
readers
writers
nil)
- (bootstrap-accessor-definitions1
+ (!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)
+(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
(writer (values 'standard-writer-method
#'make-std-writer-method-function
(list 'new-value class-name)
- (list 't class-name)
+ (list t class-name)
"automatically generated writer method"))
(boundp (values 'standard-boundp-method
#'make-std-boundp-method-function
doc
slot-name))))))
-(defun bootstrap-accessor-definitions1 (class-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))
+ (!bootstrap-accessor-definition class-name
+ reader
+ slot-name
+ 'reader))
(do-writer-definition (writer)
- (bootstrap-accessor-definition class-name
- writer
- slot-name
- 'writer))
+ (!bootstrap-accessor-definition class-name
+ writer
+ slot-name
+ 'writer))
(do-boundp-definition (boundp)
- (bootstrap-accessor-definition class-name
- boundp
- slot-name
- '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)
+(defun !bootstrap-class-predicates (early-p)
(let ((*early-p* early-p))
(dolist (definition *early-class-definitions*)
(let* ((name (ecd-class-name definition))
(setf (find-class-predicate name)
(make-class-predicate class (class-predicate-name class)))))))
-(defun bootstrap-built-in-classes ()
+(defun !bootstrap-built-in-classes ()
;; First make sure that all the supers listed in
;; *BUILT-IN-CLASS-LATTICE* are themselves defined by
;; other sorts of brainos.
(dolist (e *built-in-classes*)
(dolist (super (cadr e))
- (unless (or (eq super 't)
+ (unless (or (eq super t)
(assq super *built-in-classes*))
(error "in *BUILT-IN-CLASSES*: ~S has ~S as a super,~%~
but ~S is not itself a class in *BUILT-IN-CLASSES*."
(set (get-built-in-wrapper-symbol name) wrapper)
(setf (sb-kernel:class-pcl-class lclass) class)
- (bootstrap-initialize-class 'built-in-class class
- name class-eq-wrapper nil
- supers subs
- (cons name cpl)
- wrapper prototype)))))
+ (!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))
(cl:find-class symbol))))
;; a hack to add the STREAM class as a
;; mixin to the LISP-STREAM class.
- ((eq symbol 'sb-sys:lisp-stream)
+ ((eq symbol 'sb-kernel:lisp-stream)
'(structure-object stream))
((structure-type-included-type-name symbol)
(list (structure-type-included-type-name
symbol)))))
(error "~S is not a legal structure class name." symbol)))
\f
-(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)
(early-gf-methods gf))))
(unless mlist
(unless (eq class *the-class-t*)
- (let* ((default-method-function #'method-function-returning-nil)
+ (let* ((default-method-function #'constantly-nil)
(default-method-initargs (list :function
default-method-function))
(default-method (make-a-method 'standard-method
(setf (method-function-get default-method-function :constant-value)
nil)
(add-method gf default-method)))
- (let* ((class-method-function #'method-function-returning-t)
+ (let* ((class-method-function #'constantly-t)
(class-method-initargs (list :function
class-method-function))
(class-method (make-a-method 'standard-method
(eval-when (:load-toplevel :execute)
(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)
-
- (sb-int:dohash (name x *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)
+
+ (dohash (name x *find-class*)
(let* ((class (find-class-from-cell name x))
(layout (class-wrapper class))
(lclass (sb-kernel:layout-class layout))
projects / sbcl.git / blobdiff