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/simple #,type #,@sfields)) #`(define (#,pred x) (and (struct? x) (eq? (struct-vtable x) #,type))) #`(struct-set! #,type vtable-index-printer print-tree-il) #`(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) ;; () ;; ( exp) ;; ( name) ;; ( name gensym) ;; ( name gensym exp) ;; ( mod name public?) ;; ( mod name public? exp) ;; ( mod name) ;; ( mod name exp) ;; ( mod name exp) ;; ( test consequent alternate) ;; ( proc args) ;; ( name args) ;; ( head tail) ;; ( meta body) ;; ( req opt rest kw inits gensyms body alternate) ;; ( names gensyms vals body) ;; ( in-order? names gensyms vals body) (define-type ( #:common-slots (src) #:printer print-tree-il) ( names gensyms vals body) ( exp body) ( escape-only? tag body handler) ( tag args tail)) (define tree-il-src/ensure-alist (make-procedure-with-setter (lambda (tree) "Return the source location of TREE as a source property alist." ;; psyntax gives us "source vectors"; convert them lazily to reduce ;; allocations. (match (tree-il-src tree) (#(file line column) `((filename . ,file) (line . ,line) (column . ,column))) (src src))) (lambda (tree src) (set! (tree-il-src tree) src))))