From dbe8d678a46429053c7717d4d20071cbe0677ff1 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 25 Sep 2003 15:20:50 +0000 Subject: [PATCH] . original commit: 75beb3133b241cb48c5b65824be7968f87a8cfc1 --- collects/mzlib/private/package-helper.ss | 280 +++++++++++++---------- 1 file changed, 163 insertions(+), 117 deletions(-) diff --git a/collects/mzlib/private/package-helper.ss b/collects/mzlib/private/package-helper.ss index 6c7887f..2cc32f7 100644 --- a/collects/mzlib/private/package-helper.ss +++ b/collects/mzlib/private/package-helper.ss @@ -8,24 +8,18 @@ re-pre-register-package remove-dups stx-assoc mark-to-localize rebuild rebuild-cons split open - protect not-bound-tag + protect walk-path) ;; A compile-time struct for package info: (define-struct str (renames all-renames)) - ;; renames = renames for exports + ;; renames = renames for exports: (list (id-stx . id-stx) ...) ;; all-renames = all internal renames (needed to determine ;; the appropriate shadowing variable when `open' ;; appears in a `package' body) - ;; The mark-to-localize function detects uses of `protect' - ;; to prevent localization. - (define-syntax protect - (syntax-rules () - [(_ id) (quote-syntax id)])) - - ;; Used in a macro expansion to check that an id was defined: - (define not-bound-tag (gensym)) + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; General utilities ;; Helper: (define (check-defn-context stx) @@ -35,90 +29,6 @@ "allowed only in definition contexts" stx))) - (define pre-registered (make-hash-table 'weak)) - ;; maps context keys to context-hash, - ;; where a contetx hash maps id to (cons renames sub-context-hash-or-#f) - - (define (pre-register-package expand-ctx name renames all-renames introducers protect-stx) - ;; expand-ctx is the context used for expanding the body; - ;; if it's a list longer than 1, then the package itself was - ;; expanded in an internal-def position. In that case, - ;; we register the just-created package in the table. We - ;; also remember any packages that were registered with - ;; `(car expand-ctx)'. - (when (> (length expand-ctx) 1) - (let ([sub-ht (hash-table-get pre-registered (car expand-ctx) (lambda () #f))]) - (do-pre-register-package - (cadr expand-ctx) - (syntax-local-introduce name) - (list (map (lambda (i) - (cons (syntax-local-introduce (car i)) - (syntax-local-introduce (cdr i)))) - renames) - (map (lambda (i) - (cons (syntax-local-introduce (car i)) - (syntax-local-introduce (cdr i)))) - all-renames) - (convert-subs sub-ht introducers protect-stx)))))) - - (define (do-pre-register-package immediate-ctx name val) - (let ([ht (hash-table-get pre-registered immediate-ctx - (lambda () - (let ([ht (make-bound-identifier-mapping)]) - (hash-table-put! pre-registered immediate-ctx ht) - ht)))]) - (bound-identifier-mapping-put! - ht - name - val))) - - ;; As pre-registration shifts the registrations of packages - ;; within the pre-registered package, it needs to localize - ;; the info in the sub-pre-register - (define (convert-subs rn introducers protect-stx) - (and rn - (let ([naya (make-bound-identifier-mapping)]) - (bound-identifier-mapping-for-each - rn - (lambda (id v) - (bound-identifier-mapping-put! - naya - id - (list (map (lambda (i) - (cons (car i) - (intro-mark-to-localize (cdr i) introducers protect-stx))) - (car v)) - (map (lambda (i) - (cons (car i) - (intro-mark-to-localize (cdr i) introducers protect-stx))) - (cadr v)) - (convert-subs (caddr v) introducers protect-stx))))) - naya))) - - ;; Gets info for a package that has been expanded but not - ;; yet executed as syntax. - (define (get-pre-registered-package use-ctx name) - (and (pair? use-ctx) - (ormap (lambda (ctx) - (let ([ht (hash-table-get pre-registered ctx (lambda () #f))]) - (and ht - (bound-identifier-mapping-get ht - name - (lambda () #f))))) - use-ctx))) - - ;; When `open' exposes a package, we need to pre-register it. - ;; Ditto for renaming a package. - (define (re-pre-register-package subs expand-ctx name id) - (let ([v (if subs - (bound-identifier-mapping-get subs id (lambda () #f)) - (get-renames id (lambda (x) (lambda () #f))))]) - (when v - (do-pre-register-package - (car expand-ctx) - name - v)))) - ;; Removes dups from * defns (define (remove-dups l) (let ((ht (make-bound-identifier-mapping))) @@ -144,6 +54,122 @@ (define (rebuild-cons car cdr stx) (rebuild stx (cons car cdr))) + (define (split path) + (let ((r (reverse path))) + (values (reverse (cdr r)) (car r)))) + + ;; The mark-to-localize function detects uses of `protect' + ;; to prevent localization. + (define-syntax protect + (syntax-rules () + [(_ id) (quote-syntax id)])) + + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; Side registration table of packages + + (define pre-registered (make-hash-table 'weak)) + ;; maps context keys to context-hash, + ;; where a contetx hash maps id to (cons renames sub-context-hash-or-#f) + + (define (pre-register-package expand-ctx name renames all-renames introducers protect-stx) + ;; expand-ctx is the context used for expanding the body; + ;; if it's a list longer than 1, then the package itself was + ;; expanded in an internal-def position. In that case, + ;; we register the just-created package in the table. We + ;; also remember any packages that were registered with + ;; `(car expand-ctx)'. + (when (> (length expand-ctx) 1) + (let ([sub-ht (hash-table-get pre-registered (car expand-ctx) (lambda () #f))]) + (do-pre-register-package + (cadr expand-ctx) + (syntax-local-introduce name) + (list (map (lambda (i) + (cons (syntax-local-introduce (car i)) + (syntax-local-introduce (cdr i)))) + renames) + (map (lambda (i) + (cons (syntax-local-introduce (car i)) + (syntax-local-introduce (cdr i)))) + all-renames) + ;; Each package in the sub-ht table needs to be fixed + ;; up with the renamings introduced by the enclosing package. + (convert-subs sub-ht introducers protect-stx)))))) + + ;; Just a hash-table wrapper + (define (do-pre-register-package immediate-ctx name val) + (let ([ht (hash-table-get pre-registered immediate-ctx + (lambda () + (let ([ht (make-bound-identifier-mapping)]) + (hash-table-put! pre-registered immediate-ctx ht) + ht)))]) + (bound-identifier-mapping-put! + ht + name + val))) + + ;; Gets info for a package that has been expanded but not + ;; yet executed as syntax. Used only by get-renames. + (define (get-pre-registered-package use-ctx name) + (and (pair? use-ctx) + (ormap (lambda (ctx) + (let ([ht (hash-table-get pre-registered ctx (lambda () #f))]) + (and ht + (bound-identifier-mapping-get ht + name + (lambda () #f))))) + use-ctx))) + + ;; When `open' exposes a package, we need to pre-register it. + ;; Ditto for renaming a package. + (define (re-pre-register-package subs expand-ctx name id) + (let ([v (if subs + (bound-identifier-mapping-get subs id (lambda () #f)) + (get-renames id (lambda (x) (lambda () #f)) #t))]) + (when v + (do-pre-register-package + (car expand-ctx) + name + v)))) + + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; Fixup + + ;; See pre-register-package. In each package's rename mappings, + ;; the source is the original name, so it needs no conversion, + ;; but the rename targets need to be the final names. + ;; Recursively fix up nasted-package info. + (define (convert-subs rn introducers protect-stx) + (and rn + (let ([naya (make-bound-identifier-mapping)]) + (bound-identifier-mapping-for-each + rn + (lambda (id v) + (bound-identifier-mapping-put! + naya + id + (list (map (lambda (i) + (cons (car i) + ;; The main fixup operation: + (intro-mark-to-localize (cdr i) introducers protect-stx))) + (car v)) + (map (lambda (i) + (cons (car i) + ;; The main fixup operation: + (intro-mark-to-localize (cdr i) introducers protect-stx))) + (cadr v)) + (convert-subs (caddr v) introducers protect-stx))))) + naya))) + + ;; Mainly applies the introducers, but those introducers are + ;; for the package currently being expanded, and the saved + ;; syntax objects were stored in a table on the side from a + ;; previous expansion. So, we need to "introduce" the + ;; expressions before applying the renaming introducers, then + ;; un-introduce nack to neutral to store in the table. + (define (intro-mark-to-localize def introducers protect-stx) + (syntax-local-introduce + (mark-to-localize (syntax-local-introduce def) introducers protect-stx))) + ;; Traverses an S-expression, "introducing" identifiers ;; so that they refer to bindings that will be hidden ;; by the package. Don't localize protected ids, though. @@ -169,22 +195,26 @@ (vector->list contents))))) (else def)))) - (define (intro-mark-to-localize def introducers protect-stx) - (syntax-local-introduce - (mark-to-localize (syntax-local-introduce def) introducers protect-stx))) - - (define (split path) - (let ((r (reverse path))) - (values (reverse (cdr r)) (car r)))) + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; Open ;; Finds a package, either as a syntax definition or in the - ;; pre-registration table. - (define (get-renames id err) - (let ((x (or (get-pre-registered-package (syntax-local-context) id) - (let ([v (syntax-local-value id (err id))]) - (and (str? v) - (list (str-renames v) (str-all-renames v) #f)))))) - (or x + ;; pre-registration table. + ;; If the id was input to the current macro expander, it + ;; as been introduced (so we need to un-introduce it + ;; before using syntax-local-value). + ;; The resulting env+rns+subs will have #f for subs when + ;; the package is found by `syntax-local-introduce'. In + ;; that case, sub-packages will be found in the + ;; environment, too. + (define (get-renames id err try-pre?) + (let ([env+rns+subs + (or (and try-pre? + (get-pre-registered-package (syntax-local-context) id)) + (let ([v (syntax-local-value (syntax-local-introduce id) (err id))]) + (and (str? v) + (list (str-renames v) (str-all-renames v) #f))))]) + (or env+rns+subs ((err id))))) ;; Wraps `get-renames' with suitable error handling. @@ -196,29 +226,45 @@ (raise-syntax-error #f "unknown package" stx (if (identifier? orig-name) orig-name name)))))) - (get-renames (syntax-local-introduce name) err))) + (get-renames (syntax-local-introduce name) err #t))) + ;; Given an initial package description (as env+rns+subs), find + ;; the innermost package indicated by `path'. The `stx' + ;; argument is for error reporting, the `rename' argument + ;; accumulates a renamer for environment lookups, and + ;; `cp-rename' reverse-maps source ids for table lookups + ;; (when we're in an enclosing package). + ;; When env+rns+subs has a non-#f subs, then we'll always + ;; walk pre-registration info, and the renamer is + ;; not extended. (define (walk-path path env+rns+subs stx rename cp-rename) (let loop ([path path][env+rns+subs env+rns+subs][rename rename]) (cond [(null? path) (values env+rns+subs rename)] - [else (let* ([id (cp-rename (syntax-local-introduce (car path)))] + [else (let* (;; Revser-map id, in case we're in an enclosing package: + [id (cp-rename (syntax-local-introduce (car path)))] + ;; If we have a sub-package table, it maps the + ;; original name, otherwise we need to search + ;; based on the renamed package in an enclosing package. [new-name (if (caddr env+rns+subs) (cons id id) (stx-assoc id (cadr env+rns+subs)))] [v (and new-name (if (caddr env+rns+subs) (bound-identifier-mapping-get (caddr env+rns+subs) - (rename (cdr new-name)) + (cdr new-name) (lambda () #f)) (get-renames (rename (cdr new-name)) - (lambda (x) (lambda () #f)))))]) + (lambda (x) (lambda () #f)) + #f)))]) (if v - (loop (cdr path) v (lambda (id) - (let ([a (stx-assoc id (cadr env+rns+subs))]) - (rename (if a - (cdr a) - id))))) + (loop (cdr path) v (if (caddr env+rns+subs) + rename + (lambda (id) + (let ([a (stx-assoc id (cadr env+rns+subs))]) + (rename (if a + (cdr a) + id)))))) (raise-syntax-error #f "no such exported subpackage"