mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-09 21:40:33 +02:00
Code Activity

Refactor to <class> slot computation

Browse source 
* module/oop/goops.scm (macro-fold-right, fold-<class>-slots, <class>):
  Use a macro folder to define (and redefine) class slots.  We'll use
  this to compute static indices as well.
This commit is contained in:
Andy Wingo 2015-01-07 18:42:27 -05:00
parent 945652a87a
commit affe170e5c
1 changed files with 44 additions and 34 deletions
Download patch file Download diff file Expand all files Collapse all files

74
module/oop/goops.scm
View file

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