mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2026-01-15 22:01:36 -08:00
Code Issues Projects Releases Packages Wiki Activity

METAOBJECT is now created in boot.lsp as a first step towards the introduction of other classes

Browse source
This commit is contained in:
Juan Jose Garcia Ripoll 2012-04-22 20:08:38 +02:00
parent 408c53c52a
commit b9dd1309ee
3 changed files with 53 additions and 21 deletions
Download patch file Download diff file Expand all files Collapse all files

64
src/clos/boot.lsp
View file

@ -46,6 +46,7 @@
(funcallable-standard-class
(make-empty-standard-class 'FUNCALLABLE-STANDARD-CLASS
standard-class))
(metaobject (make-empty-standard-class 'METAOBJECT standard-class))
(the-class (make-empty-standard-class 'CLASS standard-class))
(the-t (make-empty-standard-class 'T the-class))
;; It does not matter that we pass NIL instead of a class object,
@ -90,31 +91,70 @@
(class-direct-slots standard-class))
;; 3) Fix the class hierarchy
;; FROM AMOP:
;;
;; Metaobject Class Direct Superclasses
;; standard-object (t)
;; funcallable-standard-object (standard-object function)
;; * metaobject (standard-object)
;; * generic-function (metaobject funcallable-standard-object)
;; standard-generic-function (generic-function)
;; * method (metaobject)
;; standard-method (method)
;; * standard-accessor-method (standard-method)
;; standard-reader-method (standard-accessor-method)
;; standard-writer-method (standard-accessor-method)
;; * method-combination (metaobject)
;; * slot-definition (metaobject)
;; * direct-slot-definition (slot-definition)
;; * effective-slot-definition (slot-definition)
;; * standard-slot-definition (slot-definition)
;; standard-direct-slot-definition (standard-slot-definition direct-slot-definition)
;; standard-effective-slot-definition (standard-slot-definition effective-slot-definition)
;; * specializer (metaobject)
;; eql-specializer (specializer)
;; * class (specializer)
;; built-in-class (class)
;; forward-referenced-class (class)
;; standard-class (class)
;; funcallable-standard-class (class)
;;
(setf (class-direct-superclasses the-t) nil
(class-direct-subclasses the-t) (list standard-object)
(class-direct-superclasses standard-object) (list the-t)
(class-direct-subclasses standard-object) (list the-class)
(class-direct-superclasses the-class) (list standard-object)
(class-direct-subclasses the-class) (list standard-class)
(class-direct-subclasses standard-object) (list metaobject)
(class-direct-superclasses metaobject) (list standard-object)
(class-direct-subclasses metaobject) (list the-class)
(class-direct-superclasses the-class) (list metaobject)
(class-direct-subclasses the-class) (list std-class)
(class-direct-superclasses std-class) (list the-class)
(class-direct-superclasses standard-class) (list std-class)
(class-direct-superclasses funcallable-standard-class) (list std-class))
(si::instance-sig-set the-t)
(si::instance-sig-set standard-object)
(si::instance-sig-set metaobject)
(si::instance-sig-set the-class)
(si::instance-sig-set std-class)
(si::instance-sig-set standard-class)
(si::instance-sig-set standard-object)
(si::instance-sig-set funcallable-standard-class)
(si::instance-sig-set the-t)
;; 4) Fix the class precedence list
(let ((cpl (list std-class the-class standard-object the-t)))
(setf (class-precedence-list std-class) cpl
(class-precedence-list standard-class) (list* standard-class cpl)
(class-precedence-list funcallable-standard-class) (list* funcallable-standard-class cpl)
(class-precedence-list the-class) (cdr cpl)
(class-precedence-list standard-object) (cddr cpl)
(class-precedence-list the-t) (cdddr cpl)))
(let ((cpl (list std-class the-class metaobject standard-object the-t)))
(setf (class-precedence-list the-t)
(setf cpl (list the-t))
(class-precedence-list standard-object)
(setf cpl (list* standard-object cpl))
(class-precedence-list metaobject)
(setf cpl (list* metaobject cpl))
(class-precedence-list the-class)
(setf cpl (list* the-class cpl))
(class-precedence-list std-class)
(setf cpl (list* std-class cpl))
(class-precedence-list standard-class)
(list* standard-class cpl)
(class-precedence-list funcallable-standard-class)
(list* funcallable-standard-class cpl)))
;; 5) Generate accessors (In macros.lsp)
)

1
src/clos/kernel.lsp
View file

@ -188,6 +188,7 @@
(let ((topmost (find-class 'CLASS nil)))
;; All instances can be classes until the class CLASS has
;; been installed. Otherwise, we check the parents.
;(print (list (class-id (class-of obj))topmost (and topmost (class-precedence-list topmost))))
(or (null topmost)
(si::subclassp (si::instance-class obj) topmost)))
t))

9
src/clos/stdmethod.lsp
View file

@ -11,15 +11,6 @@
(in-package "CLOS")
;;; ----------------------------------------------------------------------
;;; Metaobject (an abstract class, not used)
;;; ----------------------------------------------------------------------
;;;
;;; We cannot evaluate this when compiling, because redefining the metaobject
;;; class causes a lot of trouble -- slot definitions have to be finalized
;;; again and as a result a lot of functions break down.
(let () (defclass metaobject (standard-object) ()))
;;; ----------------------------------------------------------------------
;;; Funcallable object
;;; ----------------------------------------------------------------------