97 lines
2.7 KiB
Scheme
97 lines
2.7 KiB
Scheme
|
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING.
|
||
|
|
|
||
|
|
|
||
|
|
; Substitution
|
||
|
|
|
||
|
|
; ST stands for substitution template (cf. MAKE-SUBSTITUTION-TEMPLATE)
|
||
|
|
|
||
|
|
(define (inline-transform st aux-names)
|
||
|
|
(cons
|
||
|
|
(if (and (pair? st)
|
||
|
|
(eq? (car st) 'lambda))
|
||
|
|
(let ((formals (cadr st))
|
||
|
|
(body (caddr st)))
|
||
|
|
(lambda (e r c)
|
||
|
|
(let ((args (cdr e)))
|
||
|
|
(if (= (length formals) (length args))
|
||
|
|
(substitute body (make-substitution r formals args))
|
||
|
|
;; No need to generate warning since the type checker will
|
||
|
|
;; produce one. Besides, we don't want to produce a warning
|
||
|
|
;; for things like (> x y z).
|
||
|
|
e))))
|
||
|
|
(lambda (e r c)
|
||
|
|
(cons (substitute st r)
|
||
|
|
(cdr e))))
|
||
|
|
aux-names))
|
||
|
|
|
||
|
|
(define (make-substitution r formals args)
|
||
|
|
(let ((subs (map cons formals args)))
|
||
|
|
(lambda (name)
|
||
|
|
(let ((probe (assq name subs)))
|
||
|
|
(if probe
|
||
|
|
(cdr probe)
|
||
|
|
(if (generated? name)
|
||
|
|
(begin (signal 'note
|
||
|
|
"this shouldn't happen - make-substitution"
|
||
|
|
name)
|
||
|
|
name) ;TEMPORARY KLUDGE.
|
||
|
|
(r name)))))))
|
||
|
|
|
||
|
|
|
||
|
|
; Substitute into an expression.
|
||
|
|
; ST is an S-expression as returned by MAKE-SUBSTITUTION-TEMPLATE.
|
||
|
|
; Make nodes instead of s-expressions because otherwise TYPE-CHECK
|
||
|
|
; and SCHEMIFY will get confused.
|
||
|
|
|
||
|
|
(define (substitute st r)
|
||
|
|
(cond ((symbol? st)
|
||
|
|
(let ((foo (r st)))
|
||
|
|
(if (name? foo)
|
||
|
|
(make-node operator/name foo)
|
||
|
|
foo)))
|
||
|
|
((qualified? st)
|
||
|
|
(make-node operator/name
|
||
|
|
(qualified->name st r)))
|
||
|
|
((pair? st)
|
||
|
|
(case (car st)
|
||
|
|
((quote) (make-node (get-operator 'quote) st))
|
||
|
|
((call)
|
||
|
|
(make-node (get-operator 'call)
|
||
|
|
(map (lambda (st) (substitute st r))
|
||
|
|
(cdr st))))
|
||
|
|
((lambda) (error "lambda substitution NYI" st))
|
||
|
|
(else
|
||
|
|
(let ((keyword (car st)))
|
||
|
|
(make-node (get-operator keyword)
|
||
|
|
(cons keyword
|
||
|
|
(map (lambda (st) (substitute st r))
|
||
|
|
(cdr st))))))))
|
||
|
|
(else
|
||
|
|
(make-node (get-operator 'literal) st))))
|
||
|
|
|
||
|
|
(define operator/name (get-operator 'name))
|
||
|
|
|
||
|
|
; --------------------
|
||
|
|
; Convert a qualified name #(>> parent-name symbol) to an alias.
|
||
|
|
|
||
|
|
(define (qualified->name q r)
|
||
|
|
(let recur ((q q))
|
||
|
|
(if (qualified? q)
|
||
|
|
(let ((name (recur (qualified-parent-name q))))
|
||
|
|
(generate-name (qualified-symbol q)
|
||
|
|
(get-qualified-env (generated-env name)
|
||
|
|
(generated-symbol name))
|
||
|
|
name))
|
||
|
|
(r q))))
|
||
|
|
|
||
|
|
(define (get-qualified-env env parent)
|
||
|
|
(let ((binding (generic-lookup env parent)))
|
||
|
|
(if (binding? binding)
|
||
|
|
(let ((s (binding-static binding)))
|
||
|
|
(cond ((transform? s) (transform-env s))
|
||
|
|
((structure? s) s)
|
||
|
|
(else (error "invalid qualified reference"
|
||
|
|
env parent s))))
|
||
|
|
(error "invalid qualified reference"
|
||
|
|
env parent binding))))
|