From 803a1fb8238fce63befa0cb1cc03bcffb9256f42 Mon Sep 17 00:00:00 2001 From: Juanjo Garcia-Ripoll Date: Thu, 26 Apr 2012 12:20:16 +0200 Subject: [PATCH] Simplify and automate the creation of the basic classes in boot.lsp --- src/clos/boot.lsp | 191 +++++++++++++++++++----------------------- src/clos/defclass.lsp | 33 ++++---- src/clos/load.lsp.in | 2 +- 3 files changed, 104 insertions(+), 122 deletions(-) diff --git a/src/clos/boot.lsp b/src/clos/boot.lsp index aa5869c9b..44cda6b15 100644 --- a/src/clos/boot.lsp +++ b/src/clos/boot.lsp @@ -11,6 +11,65 @@ (in-package "CLOS") +;;; ---------------------------------------------------------------------- + +;;; 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) +;;; +(eval-when (compile eval) + (defconstant +class-hierarchy+ + '((t) + (standard-object + :direct-superclasses (t)) + (metaobject + :direct-superclasses (standard-object)) + (method-combination + :direct-superclasses (metaobject) + :direct-slots #.(remove-accessors +method-combination-slots+)) + (specializer + :direct-superclasses (metaobject) + :direct-slots #.(remove-accessors +specializer-slots+)) + (eql-specializer + :direct-superclasses (specializer) + :direct-slots #.(remove-accessors +eql-specializer-slots+)) + (class + :direct-superclasses (specializer) + :direct-slots #.(remove-accessors +class-slots+)) + (std-class + :direct-superclasses (class) + :direct-slots #.(remove-accessors +standard-class-slots+)) + (standard-class + :direct-superclasses (std-class) + :direct-slots #.(remove-accessors +standard-class-slots+)) + (funcallable-standard-class + :direct-superclasses (std-class) + :direct-slots #.(remove-accessors +standard-class-slots+))))) + ;;; ---------------------------------------------------------------------- ;;; Building the classes T, CLASS, STANDARD-OBJECT and STANDARD-CLASS. ;;; @@ -18,7 +77,9 @@ ;;; DIRECT-SLOTS, etc are empty and therefore SLOT-VALUE does not work. (defun make-empty-standard-class (name metaclass) - (let ((class (si:allocate-raw-instance nil metaclass #.(length +standard-class-slots+)))) + (let ((class (or (find-class name nil) + (si:allocate-raw-instance nil metaclass + #.(length +standard-class-slots+))))) (unless metaclass (si:instance-class-set class class)) (setf (class-id class) name @@ -33,7 +94,7 @@ (eql-specializer-flag class) nil (specializer-direct-methods class) nil (specializer-direct-generic-functions class) nil - (find-class name) class) + (gethash name si::*class-name-hash-table*) class) (unless (eq name 'T) (setf (slot-table class) (make-hash-table :size 2))) class)) @@ -59,112 +120,30 @@ ;; Notice that, due to circularity in the definition, STANDARD-CLASS has ;; itself as metaclass. MAKE-EMPTY-CLASS takes care of that. ;; -(let* ((standard-class (make-empty-standard-class 'STANDARD-CLASS nil)) - (std-class (make-empty-standard-class 'STD-CLASS standard-class)) - (standard-object (make-empty-standard-class 'STANDARD-OBJECT standard-class)) - (funcallable-standard-class - (make-empty-standard-class 'FUNCALLABLE-STANDARD-CLASS - standard-class)) - (metaobject (make-empty-standard-class 'METAOBJECT standard-class)) - (method-combination (make-empty-standard-class 'METHOD-COMBINATION standard-class)) - (specializer (make-empty-standard-class 'SPECIALIZER standard-class)) - (eql-specializer (make-empty-standard-class 'EQL-SPECIALIZER standard-class)) - (the-class (make-empty-standard-class 'CLASS standard-class)) - (the-t (make-empty-standard-class 'T the-class))) - - ;; 2) STANDARD-CLASS and CLASS and others are classes with slots. Create a - ;; hash table for them, so that SLOT-VALUE works. Notice that we - ;; make a intentional mistake: CLASS and STANDARD-CLASS share the same - ;; hashtable!! - (add-slots the-class '#.(remove-accessors +class-slots+)) - (add-slots std-class #1='#.(remove-accessors +standard-class-slots+)) - (add-slots standard-class #1#) - (add-slots funcallable-standard-class #1#) - (add-slots method-combination '#.(remove-accessors +method-combination-slots+)) - (add-slots specializer '#.(remove-accessors +specializer-slots+)) - (add-slots eql-specializer '#.(remove-accessors +eql-specializer-slots+)) - - ;; 3) Fix the class hierarchy - ;; FROM AMOP: +(let ((all-classes '#.+class-hierarchy+)) ;; - ;; 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) + ;; 1) Create the classes, fix their inheritance chain and add their slots ;; - (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 metaobject) - (class-direct-superclasses metaobject) (list standard-object) - (class-direct-subclasses metaobject) (list specializer method-combination) - (class-direct-superclasses method-combination) (list metaobject) - (class-direct-superclasses specializer) (list metaobject) - (class-direct-subclasses specializer) (list the-class eql-specializer) - (class-direct-superclasses eql-specializer) (list specializer) - (class-direct-superclasses the-class) (list specializer) - (class-direct-subclasses the-class) (list std-class) - (class-direct-superclasses std-class) (list the-class) - (class-direct-subclasses std-class) (list standard-class funcallable-standard-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 method-combination) - (si::instance-sig-set specializer) - (si::instance-sig-set eql-specializer) - (si::instance-sig-set the-class) - (si::instance-sig-set std-class) - (si::instance-sig-set standard-class) - (si::instance-sig-set funcallable-standard-class) - - ;; 4) Fix the class precedence list - (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 method-combination) - (list* method-combination cpl) - (class-precedence-list specializer) - (setf cpl (list* specializer cpl)) - (class-precedence-list eql-specializer) - (list* eql-specializer 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) + (loop with standard-class = (make-empty-standard-class 'standard-class nil) + for c in all-classes + for name = (first c) + for class = (make-empty-standard-class name standard-class) + for superclasses-names = (getf (rest c) :direct-superclasses) + for superclasses = (mapcar #'find-class superclasses-names) + for slots = (getf (rest c) :direct-slots) + do (setf (class-direct-superclasses class) + (loop for parent in superclasses + do (push class (class-direct-subclasses parent)) + collect parent) + (class-precedence-list class) + (compute-clos-class-precedence-list class superclasses)) + when slots + do (add-slots class slots)) + ;; + ;; 3) Finalize + ;; + (loop for c in all-classes + do (si::instance-sig-set (find-class (first c)))) ) (defconstant +the-t-class+ (find-class 't nil)) diff --git a/src/clos/defclass.lsp b/src/clos/defclass.lsp index c13fee768..e7ce5a2b7 100644 --- a/src/clos/defclass.lsp +++ b/src/clos/defclass.lsp @@ -236,20 +236,23 @@ (let ((one-list (first l))) (when (eq class (first one-list)) (setf (first l) (rest one-list))))))) - (if (endp (rest superclasses)) - (let ((class (first superclasses))) - (list* new-class (class-precedence-list class))) - (multiple-value-bind (class-list precedence-lists) - (walk-supers superclasses) - (do ((cpl (list new-class))) - ((null class-list) - (if precedence-lists (cycle-error new-class) (nreverse cpl))) - (let* ((candidates (free-elements class-list precedence-lists)) - (next (next-element candidates cpl))) - (unless next - (cycle-error new-class)) - (setf precedence-lists (delete-class next precedence-lists) - class-list (delete next class-list) - cpl (cons next cpl)))))))) + (cond ((null superclasses) + (list new-class)) + ((endp (rest superclasses)) + (let ((class (first superclasses))) + (list* new-class (class-precedence-list class)))) + (t + (multiple-value-bind (class-list precedence-lists) + (walk-supers superclasses) + (do ((cpl (list new-class))) + ((null class-list) + (if precedence-lists (cycle-error new-class) (nreverse cpl))) + (let* ((candidates (free-elements class-list precedence-lists)) + (next (next-element candidates cpl))) + (unless next + (cycle-error new-class)) + (setf precedence-lists (delete-class next precedence-lists) + class-list (delete next class-list) + cpl (cons next cpl))))))))) ;;; ---------------------------------------------------------------------- diff --git a/src/clos/load.lsp.in b/src/clos/load.lsp.in index ae4f88e90..8e84fe39d 100644 --- a/src/clos/load.lsp.in +++ b/src/clos/load.lsp.in @@ -6,8 +6,8 @@ "src:clos;method.lsp" "src:clos;slot.lsp" "src:clos;combin.lsp" - "src:clos;boot.lsp" "src:clos;defclass.lsp" + "src:clos;boot.lsp" "src:clos;standard.lsp" "src:clos;builtin.lsp" "src:clos;change.lsp"