tree-il on expanded-vtables

* module/language/tree-il.scm: In a somewhat daring move, inherit
  the "core" tree-il constructs from %expanded-vtables.

diff --git a/module/language/tree-il.scm b/module/language/tree-il.scm
index bec3bec..5f4c014 100644 (file)
--- a/module/language/tree-il.scm
+++ b/module/language/tree-il.scm
@@ -61,28 +61,70 @@
             post-order!
             pre-order!))
 
+(define-syntax borrow-core-vtables
+  (lambda (x)
+    (syntax-case x ()
+      ((_)
+       (let lp ((n 0) (out '()))
+         (if (< n (vector-length %expanded-vtables))
+             (lp (1+ n)
+                 (let* ((vtable (vector-ref %expanded-vtables n))
+                        (stem (struct-ref vtable (+ vtable-offset-user 0)))
+                        (fields (struct-ref vtable (+ vtable-offset-user 2)))
+                        (sfields (map
+                                  (lambda (f) (datum->syntax x f))
+                                  fields))
+                        (type (datum->syntax x (symbol-append '< stem '>)))
+                        (ctor (datum->syntax x (symbol-append 'make- stem)))
+                        (pred (datum->syntax x (symbol-append stem '?))))
+                   (let lp ((n 0) (fields fields)
+                            (out (cons*
+                                  #`(define (#,ctor #,@sfields)
+                                      (make-struct #,type 0 #,@sfields))
+                                  #`(define (#,pred x)
+                                      (and (struct? x)
+                                           (eq? (struct-vtable x) #,type)))
+                                  #`(define #,type
+                                           (vector-ref %expanded-vtables #,n))
+                                       out)))
+                     (if (null? fields)
+                         out
+                         (lp (1+ n)
+                             (cdr fields)
+                             (let ((acc (datum->syntax
+                                         x (symbol-append stem '- (car fields)))))
+                               (cons #`(define #,acc
+                                         (make-procedure-with-setter
+                                          (lambda (x) (struct-ref x #,n))
+                                          (lambda (x v) (struct-set! x #,n v))))
+                                     out)))))))
+             #`(begin #,@(reverse out))))))))
+
+(borrow-core-vtables)
+
+  ;; (<void>)
+  ;; (<const> exp)
+  ;; (<primitive-ref> name)
+  ;; (<lexical-ref> name gensym)
+  ;; (<lexical-set> name gensym exp)
+  ;; (<module-ref> mod name public?)
+  ;; (<module-set> mod name public? exp)
+  ;; (<toplevel-ref> name)
+  ;; (<toplevel-set> name exp)
+  ;; (<toplevel-define> name exp)
+  ;; (<conditional> test consequent alternate)
+  ;; (<application> proc args)
+  ;; (<sequence> exps)
+  ;; (<lambda> meta body)
+  ;; (<lambda-case> req opt rest kw inits gensyms body alternate)
+  ;; (<let> names gensyms vals body)
+  ;; (<letrec> names gensyms vals body)
+  ;; (<dynlet> fluids vals body)
+
 (define-type (<tree-il> #:common-slots (src))
-  (<void>)
-  (<const> exp)
-  (<primitive-ref> name)
-  (<lexical-ref> name gensym)
-  (<lexical-set> name gensym exp)
-  (<module-ref> mod name public?)
-  (<module-set> mod name public? exp)
-  (<toplevel-ref> name)
-  (<toplevel-set> name exp)
-  (<toplevel-define> name exp)
-  (<conditional> test consequent alternate)
-  (<application> proc args)
-  (<sequence> exps)
-  (<lambda> meta body)
-  (<lambda-case> req opt rest kw inits gensyms body alternate)
-  (<let> names gensyms vals body)
-  (<letrec> names gensyms vals body)
   (<fix> names gensyms vals body)
   (<let-values> exp body)
   (<dynwind> winder body unwinder)
-  (<dynlet> fluids vals body)
   (<dynref> fluid)
   (<dynset> fluid exp)
   (<prompt> tag body handler)