conservatory
/
ikarus
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

get-import-spec* now uses an eq-hash-table to detect most dups.

This commit is contained in:
Abdulaziz Ghuloum 2007-12-13 06:15:21 -05:00
parent c181838f48
commit 112e00a6e6
2 changed files with 25 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
scheme/last-revision
View File

@ -1 +1 @@
1237 1238

34
scheme/psyntax.expander.ss
View File

@ -2976,6 +2976,8 @@
;;; returns: ((z . z$label) (y . x$label) (q . q$label)) ;;; returns: ((z . z$label) (y . x$label) (q . q$label))
;;; and (#<library (foo)> #<library (bar)>) ;;; and (#<library (foo)> #<library (bar)>)
(define (parse-import-spec* imp*) (define (parse-import-spec* imp*)
(define (dup-error name)
(error 'import "two imports with different bindings" name))
(define (merge-substs s subst) (define (merge-substs s subst)
(define (insert-to-subst a subst) (define (insert-to-subst a subst)
(let ((name (car a)) (label (cdr a))) (let ((name (car a)) (label (cdr a)))
@ -2984,10 +2986,7 @@
(lambda (x) (lambda (x)
(cond (cond
((eq? (cdr x) label) subst) ((eq? (cdr x) label) subst)
(else (else (dup-error name)))))
(error 'import
"two imports with different bindings"
name)))))
(else (else
(cons a subst))))) (cons a subst)))))
(cond (cond
@ -3090,8 +3089,11 @@
(define (get-import spec) (define (get-import spec)
(syntax-match spec () (syntax-match spec ()
((rename isp (old* new*) ...) ((rename isp (old* new*) ...)
(and (eq? rename 'rename) (for-all symbol? old*) (for-all symbol? new*)) (and (eq? rename 'rename)
(for-all symbol? old*)
(for-all symbol? new*))
(let ((subst (get-import isp))) (let ((subst (get-import isp)))
;;; rewrite this to eliminate find* and rem* and merge
(let ((old-label* (find* old* subst))) (let ((old-label* (find* old* subst)))
(let ((subst (rem* old* subst))) (let ((subst (rem* old* subst)))
;;; FIXME: make sure map is valid ;;; FIXME: make sure map is valid
@ -3139,14 +3141,26 @@
(not (memq x '(rename except only prefix library))) (not (memq x '(rename except only prefix library)))
(get-import `(library (,x . ,x*)))) (get-import `(library (,x . ,x*))))
(spec (error 'import "invalid import spec" spec)))) (spec (error 'import "invalid import spec" spec))))
(let f ((imp* imp*) (subst '())) (define (add-imports! imp h)
(let ([subst (get-import imp)])
(for-each
(lambda (x)
(let ([name (car x)] [label (cdr x)])
(cond
[(hashtable-ref h name #f) =>
(lambda (l)
(unless (eq? l label)
(dup-error name)))]
[else
(hashtable-set! h name label)])))
subst)))
(let f ((imp* imp*) (h (make-eq-hashtable)))
(cond (cond
((null? imp*) ((null? imp*)
(values (hashtable-entries h))
(list->vector (map car subst))
(list->vector (map cdr subst))))
(else (else
(f (cdr imp*) (merge-substs (get-import (car imp*)) subst)))))) (add-imports! (car imp*) h)
(f (cdr imp*) h)))))
;;; a top rib is constructed as follows: ;;; a top rib is constructed as follows:
;;; given a subst: name* -> label*, ;;; given a subst: name* -> label*,