diff --git a/module/oop/goops.scm b/module/oop/goops.scm index 5068d14b0..7ebe0c053 100644 --- a/module/oop/goops.scm +++ b/module/oop/goops.scm @@ -207,33 +207,31 @@ (define (compute-cpl class) (compute-std-cpl class class-direct-supers)) -;; During boot, the specialized slot classes aren't defined yet, so we -;; initialize with unspecialized slots. -(define-syntax-rule (build--slots specialized?) - (let-syntax ((unspecialized-slot (syntax-rules () - ((_ name) (list 'name)))) - (specialized-slot (syntax-rules () - ((_ name class) - (if specialized? - (list 'name #:class class) - (list 'name)))))) - (list (specialized-slot layout ) - (specialized-slot flags ) - (specialized-slot self ) - (specialized-slot instance-finalizer ) - (unspecialized-slot print) - (specialized-slot name ) - (specialized-slot reserved-0 ) - (specialized-slot reserved-1 ) - (unspecialized-slot redefined) - (unspecialized-slot direct-supers) - (unspecialized-slot direct-slots) - (unspecialized-slot direct-subclasses) - (unspecialized-slot direct-methods) - (unspecialized-slot cpl) - (unspecialized-slot slots) - (unspecialized-slot getters-n-setters) - (unspecialized-slot nfields)))) +(define-syntax macro-fold-right + (syntax-rules () + ((_ folder seed ()) seed) + ((_ folder seed (head . tail)) + (folder head (macro-fold-right folder seed tail))))) + +(define-syntax-rule (fold--slots fold visit seed) + (fold visit seed + ((layout ) + (flags ) + (self ) + (instance-finalizer ) + (print) + (name ) + (reserved-0 ) + (reserved-1 ) + (redefined) + (direct-supers) + (direct-slots) + (direct-subclasses) + (direct-methods) + (cpl) + (slots) + (getters-n-setters) + (nfields)))) (define (build-slots-list dslots cpl) (define (check-cpl slots class-slots) @@ -381,8 +379,14 @@ z))) (define - (let ((dslots (build--slots #f))) - (%make-root-class ' dslots (%compute-getters-n-setters dslots)))) + (let-syntax ((visit + ;; The specialized slot classes have not been defined + ;; yet; initialize with unspecialized slots. + (syntax-rules () + ((_ (name) tail) (cons (list 'name) tail)) + ((_ (name class) tail) (cons (list 'name) tail))))) + (let ((dslots (fold--slots macro-fold-right visit '()))) + (%make-root-class ' dslots (%compute-getters-n-setters dslots))))) (define-syntax define-standard-class (syntax-rules () @@ -418,11 +422,17 @@ (define-standard-class ()) (define-standard-class ()) -;; Finish initialization of . -(let ((dslots (build--slots #t))) - (slot-set! 'direct-slots dslots) - (slot-set! 'slots dslots) - (slot-set! 'getters-n-setters (%compute-getters-n-setters dslots))) +;; Finish initialization of with specialized slots. +(let-syntax ((visit + (syntax-rules () + ((_ (name) tail) + (cons (list 'name) tail)) + ((_ (name class) tail) + (cons (list 'name #:class class) tail))))) + (let ((dslots (fold--slots macro-fold-right visit '()))) + (slot-set! 'direct-slots dslots) + (slot-set! 'slots dslots) + (slot-set! 'getters-n-setters (%compute-getters-n-setters dslots)))) ;; Applicables and their classes. (define-standard-class ())