mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-10 15:50:50 +02:00
Code Activity

tree-il on expanded-vtables

Browse source 
* module/language/tree-il.scm: In a somewhat daring move, inherit
  the "core" tree-il constructs from %expanded-vtables.
This commit is contained in:
Andy Wingo 2010-05-19 23:27:14 +02:00
parent e1ca91007a
commit f7b61b39d3
1 changed files with 60 additions and 18 deletions
Download patch file Download diff file Expand all files Collapse all files

78
module/language/tree-il.scm
View file

@ -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)