[Guile-commits] 36/88: Statically compute offsets for slots of <class> in Scheme

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit ebca094b50d4885866cc1c3c3f3d6e2ed600aeac
Author: Andy Wingo <address@hidden>
Date:   Fri Jan 9 19:10:51 2015 +0100

    Statically compute offsets for slots of <class> in Scheme
    
    * module/oop/goops.scm (macro-fold-left): New helper.
      (define-class-index): Define class-index-FOO for each slot FOO.
      (fold-<class>-slots): Make the slots list have the marks of the
      "visit" macro.
---
 module/oop/goops.scm |   69 ++++++++++++++++++++++++++++++++++++-------------
 1 files changed, 50 insertions(+), 19 deletions(-)

diff --git a/module/oop/goops.scm b/module/oop/goops.scm
index 7ebe0c0..d00ce67 100644
--- a/module/oop/goops.scm
+++ b/module/oop/goops.scm
@@ -207,31 +207,62 @@
 (define (compute-cpl class)
   (compute-std-cpl class class-direct-supers))
 
+(define-syntax macro-fold-left
+  (syntax-rules ()
+    ((_ folder seed ()) seed)
+    ((_ folder seed (head . tail))
+     (macro-fold-left folder (folder head seed) tail))))
+
 (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-<class>-slots fold visit seed)
-  (fold visit seed
-        ((layout <protected-read-only-slot>)
-         (flags <hidden-slot>)
-         (self <self-slot>)
-         (instance-finalizer <hidden-slot>)
-         (print)
-         (name <protected-hidden-slot>)
-         (reserved-0 <hidden-slot>)
-         (reserved-1 <hidden-slot>)
-         (redefined)
-         (direct-supers)
-         (direct-slots)
-         (direct-subclasses)
-         (direct-methods)
-         (cpl)
-         (slots)
-         (getters-n-setters)
-         (nfields))))
+(define-syntax fold-<class>-slots
+  (lambda (x)
+    (define slots
+      '((layout <protected-read-only-slot>)
+        (flags <hidden-slot>)
+        (self <self-slot>)
+        (instance-finalizer <hidden-slot>)
+        (print)
+        (name <protected-hidden-slot>)
+        (reserved-0 <hidden-slot>)
+        (reserved-1 <hidden-slot>)
+        (redefined)
+        (direct-supers)
+        (direct-slots)
+        (direct-subclasses)
+        (direct-methods)
+        (cpl)
+        (slots)
+        (getters-n-setters)
+        (nfields)))
+    (syntax-case x ()
+      ((_ fold visit seed)
+       ;; The datum->syntax makes it as if the identifiers in `slots'
+       ;; were present in the initial form, which allows them to be used
+       ;; as (components of) introduced identifiers.
+       #`(fold visit seed #,(datum->syntax #'visit slots))))))
+
+;; Define class-index-layout to 0, class-index-flags to 1, and so on.
+(let-syntax ((define-class-index
+              (lambda (x)
+                (define (id-append ctx a b)
+                  (datum->syntax ctx (symbol-append (syntax->datum a)
+                                                    (syntax->datum b))))
+                (define (tail-length tail)
+                  (syntax-case tail ()
+                    ((begin) 0)
+                    ((visit head tail) (1+ (tail-length #'tail)))))
+                (syntax-case x ()
+                  ((_ (name . _) tail)
+                   #`(begin
+                       (define #,(id-append #'name #'class-index- #'name)
+                         #,(tail-length #'tail))
+                       tail))))))
+  (fold-<class>-slots macro-fold-left define-class-index (begin)))
 
 (define (build-slots-list dslots cpl)
   (define (check-cpl slots class-slots)