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

changed "parse-import-spec*" in psyntax.expander to return two 

vectors (names and labels) instead of an a-list subst.
This commit is contained in:
Abdulaziz Ghuloum 2007-12-13 05:57:15 -05:00
parent b5ae1e2361
commit c181838f48
4 changed files with 59 additions and 50 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
scheme/ikarus.reader.ss
View File

@ -22,7 +22,11 @@
(ikarus system $pairs) (ikarus system $pairs)
(ikarus system $bytevectors) (ikarus system $bytevectors)
(only (ikarus unicode-data) unicode-printable-char?) (only (ikarus unicode-data) unicode-printable-char?)
(except (ikarus) read read-token comment-handler get-datum)) (except (ikarus) read-char read read-token comment-handler get-datum))
(define-syntax read-char
(syntax-rules ()
[(_ p) (get-char p)]))
(define delimiter? (define delimiter?
(lambda (c) (lambda (c)

2
scheme/last-revision
View File

@ -1 +1 @@
1236 1237

99
scheme/psyntax.expander.ss
View File

@ -2775,25 +2775,27 @@
(($module) (($module)
(let ((iface value)) (let ((iface value))
(let ((id* (car iface)) (lab* (cdr iface))) (let ((id* (car iface)) (lab* (cdr iface)))
(values id* lab*)))) (values (list->vector id*)
(list->vector lab*)))))
(else (stx-error e "invalid import"))))))) (else (stx-error e "invalid import")))))))
(define (library-import e) (define (library-import e)
(syntax-match e () (syntax-match e ()
[(ctxt imp* ...) [(ctxt imp* ...)
(let ((subst (parse-import-spec* (let-values (((subst-names subst-labels)
(parse-import-spec*
(syntax->datum imp*)))) (syntax->datum imp*))))
(values (values
(map (lambda (x) (vector-map
(let ([name (car x)]) (lambda (name)
(datum->stx ctxt name))) (datum->stx ctxt name))
subst) subst-names)
(map cdr subst)))] subst-labels))]
[_ (stx-error e "invalid import form")])) [_ (stx-error e "invalid import form")]))
(let-values (((id* lab*) (let-values (((id* lab*)
(if (module-import? e) (if (module-import? e)
(module-import e r) (module-import e r)
(library-import e)))) (library-import e))))
(for-each (vector-for-each
(lambda (id lab) (extend-rib! rib id lab)) (lambda (id lab) (extend-rib! rib id lab))
id* lab*))) id* lab*)))
(chi-body* (cdr e*) r mr lex* rhs* mod** kwd* rib top?)) (chi-body* (cdr e*) r mr lex* rhs* mod** kwd* rib top?))
@ -2878,23 +2880,23 @@
(begin (begin
(syntax-match e () (syntax-match e ()
[(ctxt imp* ...) [(ctxt imp* ...)
(let ((subst (parse-import-spec* (syntax->datum imp*)))) (let-values (((subst-names subst-labels)
(parse-import-spec* (syntax->datum imp*))))
(cond (cond
((interaction-library) => ((interaction-library) =>
(lambda (lib) (lambda (lib)
(for-each (vector-for-each
(lambda (x) (lambda (sym label)
(let ([sym (car x)] [label (cdr x)]) (cond
(cond ((assq sym (library-subst lib)) =>
((assq sym (library-subst lib)) => (lambda (p)
(lambda (p) (unless (eq? (cdr p) label)
(unless (eq? (cdr p) label) (stx-error e
(stx-error e "identifier conflict"
"identifier conflict" sym))))
sym)))) (else
(else (extend-library-subst! lib sym label))))
(extend-library-subst! lib sym label))))) subst-names subst-labels)))
subst)))
(else (error 'import "BUG: cannot happen"))))]) (else (error 'import "BUG: cannot happen"))))])
(chi-top* (cdr e*) init*))) (chi-top* (cdr e*) init*)))
(else (else
@ -3139,7 +3141,10 @@
(spec (error 'import "invalid import spec" spec)))) (spec (error 'import "invalid import spec" spec))))
(let f ((imp* imp*) (subst '())) (let f ((imp* imp*) (subst '()))
(cond (cond
((null? imp*) subst) ((null? imp*)
(values
(list->vector (map car subst))
(list->vector (map cdr subst))))
(else (else
(f (cdr imp*) (merge-substs (get-import (car imp*)) subst)))))) (f (cdr imp*) (merge-substs (get-import (car imp*)) subst))))))
@ -3151,13 +3156,12 @@
;;; - label* as the rib-label* ;;; - label* as the rib-label*
;;; so, a name in a top rib maps to its label if and only if ;;; so, a name in a top rib maps to its label if and only if
;;; its set of marks is top-mark*. ;;; its set of marks is top-mark*.
(define (make-top-rib subst) (define (make-top-rib names labels)
(let ((rib (make-empty-rib))) (let ((rib (make-empty-rib)))
(for-each (vector-for-each
(lambda (x) (lambda (name label)
(let ((name (car x)) (label (cdr x))) (extend-rib! rib (mkstx name top-mark* '()) label))
(extend-rib! rib (mkstx name top-mark* '()) label))) names labels)
subst)
rib)) rib))
(define (make-collector) (define (make-collector)
@ -3206,8 +3210,9 @@
(define itc (make-collector)) (define itc (make-collector))
(parameterize ((imp-collector itc)) (parameterize ((imp-collector itc))
(let-values (((exp-int* exp-ext*) (parse-exports exp*))) (let-values (((exp-int* exp-ext*) (parse-exports exp*)))
(let ((subst (parse-import-spec* imp*))) (let-values (((subst-names subst-labels)
(let ((rib (make-top-rib subst))) (parse-import-spec* imp*)))
(let ((rib (make-top-rib subst-names subst-labels)))
(let ((b* (map (lambda (x) (mkstx x top-mark* (list rib))) b*)) (let ((b* (map (lambda (x) (mkstx x top-mark* (list rib))) b*))
(rtc (make-collector)) (rtc (make-collector))
(vtc (make-collector))) (vtc (make-collector)))
@ -3286,7 +3291,7 @@
;;; An env record encapsulates a substitution and a set of ;;; An env record encapsulates a substitution and a set of
;;; libraries. ;;; libraries.
(define-record env (subst itc) (define-record env (names labels itc)
(lambda (x p) (lambda (x p)
(unless (env? x) (unless (env? x)
(error 'record-type-printer "not an environment")) (error 'record-type-printer "not an environment"))
@ -3302,8 +3307,9 @@
(lambda imp* (lambda imp*
(let ([itc (make-collector)]) (let ([itc (make-collector)])
(parameterize ([imp-collector itc]) (parameterize ([imp-collector itc])
(let ((subst (parse-import-spec* imp*))) (let-values (((subst-names subst-labels)
(make-env subst itc)))))) (parse-import-spec* imp*)))
(make-env subst-names subst-labels itc))))))
;;; R6RS's null-environment and scheme-report-environment are ;;; R6RS's null-environment and scheme-report-environment are
;;; constructed simply using the corresponding libraries. ;;; constructed simply using the corresponding libraries.
@ -3324,19 +3330,18 @@
(lambda (x env) (lambda (x env)
(unless (env? env) (unless (env? env)
(error 'expand "not an environment" env)) (error 'expand "not an environment" env))
(let ((subst (env-subst env))) (let ((rib (make-top-rib (env-names env) (env-labels env))))
(let ((rib (make-top-rib subst))) (let ((x (mkstx x top-mark* (list rib)))
(let ((x (mkstx x top-mark* (list rib))) (itc (env-itc env))
(itc (env-itc env)) (rtc (make-collector))
(rtc (make-collector)) (vtc (make-collector)))
(vtc (make-collector))) (let ((x
(let ((x (parameterize ((inv-collector rtc)
(parameterize ((inv-collector rtc) (vis-collector vtc)
(vis-collector vtc) (imp-collector itc))
(imp-collector itc)) (chi-expr x '() '()))))
(chi-expr x '() '())))) (seal-rib! rib)
(seal-rib! rib) (values x (rtc)))))))
(values x (rtc))))))))
;;; This is R6RS's eval. It takes an expression and an environment, ;;; This is R6RS's eval. It takes an expression and an environment,
;;; expands the expression, invokes its invoke-required libraries and ;;; expands the expression, invokes its invoke-required libraries and

2
scheme/psyntax.library-manager.ss
View File

@ -79,7 +79,7 @@
(map (lambda (x) x) x) (map (lambda (x) x) x)
(error 'library-path "not a list of strings" x))))) (error 'library-path "not a list of strings" x)))))
(define (library-name->file-name x) (define (library-name->file-name x)
(let-values (((p extract) (open-string-output-port))) (let-values (((p extract) (open-string-output-port)))
(define (display-hex n) (define (display-hex n)
(cond (cond