123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121 |
- (define (name? thing)
- (or (symbol? thing)
- (generated? thing)))
- (define-record-type generated :generated
- (make-generated name token env parent-name)
- generated?
- (name generated-name)
- (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))))
- (define (generate-name name env parent-name)
- (make-generated name (cons #f #f) env parent-name))
- (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)))
- "##"
- (number->string (generated-uid name))))))
- (define (name-hash name)
- (cond ((symbol? name)
- (string-hash (symbol->string name)))
- ((generated? name)
- (name-hash (generated-name name)))
- (else
- (assertion-violation 'name-hash "invalid name" name))))
- (define make-name-table
- (make-table-maker eq? name-hash))
- (define (desyntaxify thing0)
- (let desyntaxify ((thing thing0))
- (cond ((or (boolean? thing) (null? thing) (number? thing)
- (symbol? thing) (char? thing))
- thing)
- ((string? thing)
- (make-immutable! thing))
- ((generated? thing)
- (desyntaxify (generated-name thing)))
- ((pair? thing)
- (make-immutable!
- (cons (desyntaxify (car thing))
- (desyntaxify (cdr thing)))))
- ((vector? thing)
- (make-immutable!
- (let ((new (make-vector (vector-length thing) #f)))
- (let loop ((i 0))
- (if (>= i (vector-length thing))
- new
- (begin
- (vector-set! new i (desyntaxify (vector-ref thing i)))
- (loop (+ i 1))))))))
- (else
- (syntax-violation 'quote "invalid datum in quotation" thing)))))
- (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))
-
|