From b9dd1309ee90f9cb4c839baf88bf653c6e896c8a Mon Sep 17 00:00:00 2001 From: Juan Jose Garcia Ripoll Date: Sun, 22 Apr 2012 20:08:38 +0200 Subject: [PATCH] METAOBJECT is now created in boot.lsp as a first step towards the introduction of other classes --- src/clos/boot.lsp | 64 ++++++++++++++++++++++++++++++++++-------- src/clos/kernel.lsp | 1 + src/clos/stdmethod.lsp | 9 ------ 3 files changed, 53 insertions(+), 21 deletions(-) diff --git a/src/clos/boot.lsp b/src/clos/boot.lsp index 15f1969c2..824690986 100644 --- a/src/clos/boot.lsp +++ b/src/clos/boot.lsp @@ -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) ) diff --git a/src/clos/kernel.lsp b/src/clos/kernel.lsp index 8cbb76cef..18cf50abd 100644 --- a/src/clos/kernel.lsp +++ b/src/clos/kernel.lsp @@ -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)) diff --git a/src/clos/stdmethod.lsp b/src/clos/stdmethod.lsp index f7ea47ed9..c94202900 100644 --- a/src/clos/stdmethod.lsp +++ b/src/clos/stdmethod.lsp @@ -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 ;;; ----------------------------------------------------------------------