scsh-0.6/scheme/bcomp/name.scm

172 lines
5.2 KiB
Scheme
Raw Normal View History

1999-09-14 08:45:02 -04:00
; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
; Names (symbols) and generated names.
(define (name? thing)
(or (symbol? thing)
(generated? thing)))
; Generated names
; Generated names make lexically-scoped macros work. They're the same
; as what Alan Bawden and Chris Hanson call "aliases". The parent
; field is always another name (perhaps generated). The parent chain
; provides an access path to the name's binding, should one ever be
; needed. That is: If name M is bound to a transform T that generates
; name G as an alias for name N, then M is (generated-parent-name G),
; so we can get the binding of G by accessing the binding of N in T's
; environment of closure, and we get T by looking up M in the
; environment in which M is *used*.
(define-record-type generated :generated
(make-generated name token env parent-name)
1999-09-14 08:45:02 -04:00
generated?
(name generated-name)
1999-09-14 08:45:02 -04:00
(token generated-token)
(env generated-env)
(parent-name generated-parent-name))
(define-record-discloser :generated
(lambda (name)
(list 'generated (generated-name name) (generated-uid name))))
1999-09-14 08:45:02 -04:00
(define (generate-name name env parent-name) ;for opt/inline.scm
(make-generated name (cons #f #f) env parent-name))
1999-09-14 08:45:02 -04:00
(define (generated-uid generated-name)
(let ((token (generated-token generated-name)))
(or (car token)
(let ((uid *generated-uid*))
(set! *generated-uid* (+ *generated-uid* 1))
(set-car! token uid)
uid))))
(define *generated-uid* 0)
(define (name->symbol name)
(if (symbol? name)
name
(string->symbol (string-append (symbol->string
(name->symbol (generated-name name)))
1999-09-14 08:45:02 -04:00
"##"
(number->string (generated-uid name))))))
(define (name-hash name)
(cond ((symbol? name)
(string-hash (symbol->string name)))
((generated? name)
(name-hash (generated-name name)))
1999-09-14 08:45:02 -04:00
(else
(error "invalid name" name))))
(define make-name-table
(make-table-maker eq? name-hash))
1999-09-14 08:45:02 -04:00
; Used by QUOTE to turn generated names back into symbols
(define (desyntaxify thing)
(cond ((or (boolean? thing) (null? thing) (number? thing)
(symbol? thing) (char? thing))
thing)
((string? thing)
(make-immutable! thing))
((generated? thing)
(desyntaxify (generated-name thing)))
1999-09-14 08:45:02 -04:00
((pair? thing)
(make-immutable!
(let ((x (desyntaxify (car thing)))
(y (desyntaxify (cdr thing))))
(if (and (eq? x (car thing))
(eq? y (cdr thing)))
thing
(cons x y)))))
((vector? thing)
(make-immutable!
(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 (desyntaxify (vector-ref thing i))))
(vector-set! new i x)
(loop (+ i 1)
(and same? (eq? x (vector-ref thing i))))))))))
(else
(warn "invalid datum in quotation" thing)
thing)))
;----------------
; Qualified names
;
; A qualified name is a generated name that has been translated into a path.
; For example, if syntax A introduces a reference to procedure B, then the
; reference to B, as a qualified name, will be #(>> A B). If B refers to
1999-09-14 08:45:02 -04:00
; C and is substituted in-line, then the reference to C is #(>> #(>> A B) C).
; The binding for C can be located by going to the structure which supplies A,
; finding where it gets B from, and then looking up C there.
; These can't be records because they are included in linked images.
(define (make-qualified transform-name sym uid)
(vector '>> transform-name sym uid))
(define (qualified? thing)
(and (vector? thing)
(= (vector-length thing) 4)
(eq? (vector-ref thing 0) '>>)))
(define (qualified-parent-name q) (vector-ref q 1))
(define (qualified-symbol q) (vector-ref q 2))
(define (qualified-uid q) (vector-ref q 3))
1999-09-14 08:45:02 -04:00
; Convert an alias (generated name) to S-expression form ("qualified name").
(define (name->qualified name env)
(cond ((not (generated? name))
name)
((let ((d0 (lookup env name))
(d1 (lookup env (generated-name name))))
1999-09-14 08:45:02 -04:00
(and d0 d1 (same-denotation? d0 d1)))
(generated-name name)) ;+++
1999-09-14 08:45:02 -04:00
(else
(make-qualified (qualify-parent (generated-parent-name name)
env)
(generated-name name)
1999-09-14 08:45:02 -04:00
(generated-uid 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)
;
; I think that this is buggy. The RECUR calls are using the wrong environment.
; ENV is not the environment in which the names will be looked up.
1999-09-14 08:45:02 -04:00
(define (qualify-parent name env)
(let recur ((name name))
(if (generated? name)
(let ((parent (generated-parent-name name)))
(if (let ((b1 (lookup env name))
(b2 (lookup env parent)))
(and b1
b2
(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) ;+++
(make-qualified (recur parent)
(generated-name name)
1999-09-14 08:45:02 -04:00
(generated-uid name))))
name)))