126 lines
3.6 KiB
Scheme
126 lines
3.6 KiB
Scheme
|
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING.
|
||
|
|
|
||
|
|
; schemify
|
||
|
|
|
||
|
|
|
||
|
|
; Flush nodes and generated names in favor of something a little more
|
||
|
|
; readable. Eventually, (schemify node) ought to produce an
|
||
|
|
; s-expression that has the same semantics as node, when node is fully
|
||
|
|
; expanded.
|
||
|
|
|
||
|
|
(define (schemify node . env-option)
|
||
|
|
(schemify1 node (if (null? env-option) #f (car env-option))))
|
||
|
|
|
||
|
|
(define (schemify1 node env)
|
||
|
|
(if (node? node)
|
||
|
|
(or (node-ref node 'schemify)
|
||
|
|
(let ((form ((operator-table-ref schemifiers (node-operator-id node))
|
||
|
|
node env)))
|
||
|
|
(node-set! node 'schemify form)
|
||
|
|
form))
|
||
|
|
(schemify-sexp node env)))
|
||
|
|
|
||
|
|
(define schemifiers
|
||
|
|
(make-operator-table (lambda (node env)
|
||
|
|
(let ((form (node-form node)))
|
||
|
|
(if (list? form)
|
||
|
|
(map (lambda (f) (schemify1 f env)) form)
|
||
|
|
form)))))
|
||
|
|
|
||
|
|
(define (define-schemifier name type proc)
|
||
|
|
(operator-define! schemifiers name type proc))
|
||
|
|
|
||
|
|
(define-schemifier 'name 'leaf
|
||
|
|
(lambda (node env)
|
||
|
|
(name->qualified (node-form node) env)))
|
||
|
|
|
||
|
|
(define-schemifier 'quote syntax-type
|
||
|
|
(lambda (node env)
|
||
|
|
(let ((form (node-form node)))
|
||
|
|
(list (schemify1 (car form) env) (cadr form)))))
|
||
|
|
|
||
|
|
; Convert an alias (generated name) to S-expression form ("qualified name").
|
||
|
|
;
|
||
|
|
; As an optimization, we elide intermediate steps in the lookup path
|
||
|
|
; when possible. E.g.
|
||
|
|
; #(>> #(>> #(>> define-record-type define-accessors)
|
||
|
|
; define-accessor)
|
||
|
|
; record-ref)
|
||
|
|
; is replaced with
|
||
|
|
; #(>> define-record-type record-ref)
|
||
|
|
|
||
|
|
(define (name->qualified name env)
|
||
|
|
(if env
|
||
|
|
(if (generated? name)
|
||
|
|
(if (same-denotation? (lookup env name)
|
||
|
|
(lookup env (generated-symbol name)))
|
||
|
|
(generated-symbol name) ;+++
|
||
|
|
(make-qualified
|
||
|
|
(let recur ((name (generated-parent-name name)))
|
||
|
|
(if (generated? name)
|
||
|
|
(let ((parent (generated-parent-name name)))
|
||
|
|
(if (let ((b1 (lookup env name))
|
||
|
|
(b2 (lookup env parent)))
|
||
|
|
(or (same-denotation? b1 b2)
|
||
|
|
(and (binding? b1)
|
||
|
|
(binding? b2)
|
||
|
|
(let ((s1 (binding-static b1))
|
||
|
|
(s2 (binding-static b2)))
|
||
|
|
(and (transform? s1)
|
||
|
|
(transform? s2)
|
||
|
|
(eq? (transform-env s1)
|
||
|
|
(transform-env s2)))))))
|
||
|
|
(recur parent) ;+++
|
||
|
|
`#(>> ,(recur parent)
|
||
|
|
,(generated-symbol name))))
|
||
|
|
name))
|
||
|
|
(generated-symbol name)))
|
||
|
|
name)
|
||
|
|
(desyntaxify name)))
|
||
|
|
|
||
|
|
; lambda, let-syntax, letrec-syntax...
|
||
|
|
|
||
|
|
(define-schemifier 'letrec syntax-type
|
||
|
|
(lambda (node env)
|
||
|
|
(let ((form (node-form node)))
|
||
|
|
`(letrec ,(map (lambda (spec)
|
||
|
|
`(,(car spec) ,(schemify1 (cadr spec) env)))
|
||
|
|
(cadr form))
|
||
|
|
,@(map (lambda (f) (schemify1 f env))
|
||
|
|
(cddr form))))))
|
||
|
|
|
||
|
|
(define (schemify-sexp thing env)
|
||
|
|
(cond ((name? thing)
|
||
|
|
(name->qualified thing env))
|
||
|
|
((pair? thing)
|
||
|
|
(let ((x (schemify-sexp (car thing) env))
|
||
|
|
(y (schemify-sexp (cdr thing) env)))
|
||
|
|
(if (and (eq? x (car thing))
|
||
|
|
(eq? y (cdr thing)))
|
||
|
|
thing ;+++
|
||
|
|
(cons x y))))
|
||
|
|
((vector? thing)
|
||
|
|
(let ((new (make-vector (vector-length thing) #f)))
|
||
|
|
(let loop ((i 0) (same? #t))
|
||
|
|
(if (>= i (vector-length thing))
|
||
|
|
(if same? thing new) ;+++
|
||
|
|
(let ((x (schemify-sexp (vector-ref thing i) env)))
|
||
|
|
(vector-set! new i x)
|
||
|
|
(loop (+ i 1)
|
||
|
|
(and same? (eq? x (vector-ref thing i)))))))))
|
||
|
|
(else thing)))
|
||
|
|
|
||
|
|
|
||
|
|
; Qualified names
|
||
|
|
|
||
|
|
(define (make-qualified transform-name sym)
|
||
|
|
(vector '>> transform-name sym))
|
||
|
|
|
||
|
|
(define (qualified? thing)
|
||
|
|
(and (vector? thing)
|
||
|
|
(= (vector-length thing) 3)
|
||
|
|
(eq? (vector-ref thing 0) '>>)))
|
||
|
|
|
||
|
|
(define (qualified-parent-name q) (vector-ref q 1))
|
||
|
|
(define (qualified-symbol q) (vector-ref q 2))
|