From 35af3d14d07f284db9a97f254d88cf6084143e2b Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 31 Mar 2015 08:05:17 -0600 Subject: [PATCH] re-implement `racket/package` for the new macro system The new implementation is considerably simpler than the old implementation, and it avoids `syntax-local-make-definition-context`, `syntax-local-get-shadower`, and `syntax-local-make-delta-introducer`. --- compatibility-lib/compatibility/package.rkt | 672 ++++++++------------ 1 file changed, 275 insertions(+), 397 deletions(-) diff --git a/compatibility-lib/compatibility/package.rkt b/compatibility-lib/compatibility/package.rkt index 103e77d..649474b 100644 --- a/compatibility-lib/compatibility/package.rkt +++ b/compatibility-lib/compatibility/package.rkt @@ -1,11 +1,8 @@ #lang racket/base (require (for-syntax racket/base - racket/list - syntax/kerncase - syntax/boundmap syntax/define - syntax/flatten-begin - syntax/context)) + syntax/boundmap + racket/pretty)) (provide define-package package-begin @@ -22,6 +19,279 @@ package-exported-identifiers package-original-identifiers)) + +;; ---------------------------------------- + +(begin-for-syntax + (struct package (root-id sig-ids impl-ids)) + + (define (get-package who id) + (let ([p (syntax-local-value id (lambda () #f))]) + (unless (package? p) + (error who + "not defined as a package\n identifier: ~a" + id)))) + + (define (package-exported-identifiers id) + (define p (get-package 'package-exported-identifiers id)) + (map + (lambda (sig-id) + (make-syntax-delta-introducer sig-id (package-root-id p)) + (datum->syntax id (syntax-e sig-id) sig-id sig-id)) + (syntax->list (package-sig-ids p)))) + + (define (package-original-identifiers id) + (define p (get-package 'package-original-identifiers id)) + (syntax->list (package-impl-ids p)))) + +(define-syntax (define-package stx) + (check-definition-context stx) + (syntax-case stx () + [(_ id . _) + (let ([id #'id]) + (unless (identifier? id) + (raise-syntax-error #f + "expected an identifier for the package name" + stx + id)) + (define (accumulate exports forms) + (define intro (make-syntax-introducer)) + #`(drive-top-level + (accumulate-package #,id #,(intro id) #,(intro id) #f #,stx + #,exports + () + #,(intro forms)))) + (syntax-case stx () + [(_ _ #:only (export-id ...) form ...) + (accumulate #'(#:only (export-id ...)) #'(form ...))] + [(_ _ #:all-defined-except (export-id ...) form ...) + (accumulate #'(#:all-defined-except (export-id ...)) #'(form ...))] + [(_ _ #:all-defined form ...) + (accumulate #'(#:all-defined-except ()) #'(form ...))] + [(_ _ (export-id ...) form ...) + (accumulate #'(#:only (export-id ...)) #'(form ...))]))])) + +(define-syntax (accumulate-package stx) + (syntax-case stx () + [(_ id intro-id star-id any-stars? orig-form exports defined-ids (form . forms)) + (let ([exp-form (local-expand #'form + (list (gensym)) + (list #'define-values + #'-define*-values + #'define-syntaxes + #'-define*-syntaxes + #'begin) + #f)]) + (syntax-case exp-form (begin) + [(begin seq-form ...) + #`(accumulate-package id intro-id star-id any-stars? orig-form + exports + defined-ids + (seq-form ... . forms))] + [(def (new-def-id ...) rhs) + (or (free-identifier=? #'def #'define-values) + (free-identifier=? #'def #'define-syntaxes) + (free-identifier=? #'def #'-define*-values) + (free-identifier=? #'def #'-define*-syntaxes)) + (let* ([star? (or (free-identifier=? #'def #'-define*-values) + (free-identifier=? #'def #'-define*-syntaxes))] + [next-intro (if star? + (make-syntax-introducer) + (lambda (s) s))] + [exp-form + (with-syntax ([(new-def-id ...) (if star? + ;; Add another scope layer: + (next-intro #'(new-def-id ...)) + ;; Remove star layers: + ((make-syntax-delta-introducer #'star-id #'intro-id) + #'(new-def-id ...) + 'remove))]) + (syntax/loc exp-form + (def (new-def-id ...) rhs)))]) + (with-syntax ([(_ (new-def-id ...) _) exp-form]) ; sync with above adjustments to `new-def-id` + (when (and (not star?) + (syntax-e #'any-stars?)) + ;; Make sure that a name is not defined with `define` if + ;; there's a preceeding `define*` + (let ([intro (make-syntax-delta-introducer #'star-id #'intro-id)]) + (for ([id (in-list (syntax->list #'(new-def-id ...)))]) + (unless (free-identifier=? id (intro id)) + (raise-syntax-error #f + "duplicate definition for identifier" + #'orig-form + id))))) + ;; Let definition out of `accumulate-package` form, accumulate new + ;; defintions, and continue with the rest of the package body: + (with-syntax ([forms (next-intro #'forms)] + [star-id (next-intro #'star-id)] + [any-stars? (or star? (syntax-e #'any-stars?))]) + #`(begin + #,exp-form + (accumulate-package id intro-id star-id any-stars? orig-form + exports + (new-def-id ... . defined-ids) + forms)))))] + [_ + (and (not (syntax-e #'id)) + (null? (syntax-e #'forms))) + ;; Allow last expression to produce a result for `package-begin` + exp-form] + [_ + #`(begin + (begin0 (void) #,exp-form) + (accumulate-package id intro-id star-id any-stars? orig-form + exports + defined-ids + forms))]))] + [(_ #f #f #f _ orig-form exports defined-ids ()) + ;; Last thing in `begin-package` was a definition; add a `(void)` + #'(void)] + [(_ id intro-id star-id any-stars? orig-form exports defined-ids ()) + (let () + (define (find-ids ids keep?) + (define intro (make-syntax-delta-introducer #'star-id #'id)) + (let ([ids (syntax->list ids)] + [defined-ids (syntax->list #'defined-ids)]) + (define defined-bindings (make-bound-identifier-mapping)) + ;; `defined-ids` were accumulated in reverse order; add them + ;; in the original order, so that we end up with the last + ;; definition of each equilavent id (in the case of `define*`s + (for-each + (lambda (defined-id) + (bound-identifier-mapping-put! defined-bindings + (syntax-local-identifier-as-binding + (intro defined-id 'remove)) + defined-id)) + (reverse defined-ids)) + ;; Check that each explicitly named `id` is defined: + (define mentioned-ids (make-bound-identifier-mapping)) + (for-each (lambda (id) + (define bind-id (syntax-local-identifier-as-binding + id)) + (unless (bound-identifier-mapping-get defined-bindings + bind-id + (lambda () #f)) + (raise-syntax-error #f + "identifier not defined within the package" + #'orig-form + id)) + (bound-identifier-mapping-put! mentioned-ids + bind-id + #t)) + ids) + ;; Get identifiers that should be exported: + (filter + values + (bound-identifier-mapping-map + defined-bindings + (lambda (bind-id defined-id) + (and (keep? (bound-identifier-mapping-get mentioned-ids bind-id + (lambda () #f))) + (cons bind-id + defined-id))))))) + (define mapping + (syntax-case #'exports () + [(#:only (id ...)) + (find-ids #'(id ...) values)] + [(#:all-defined-except (id ...)) + (find-ids #'(id ...) not)])) + #`(define-syntax id (package (quote-syntax star-id) + (quote-syntax #,(map car mapping)) + (quote-syntax #,(map cdr mapping)))))])) + +(define-for-syntax (do-open-package stx def-stxes) + (check-definition-context stx) + (syntax-case stx () + [(_ id) + (let ([id #'id]) + (unless (identifier? id) + (raise-syntax-error #f + "not an identifier for a package to open" + stx + id)) + (let ([p (syntax-local-value id (lambda () #f))]) + (unless (package? p) + (raise-syntax-error #f + "not defined as a package" + stx + id)) + (define (locally sig-id) + ((make-syntax-delta-introducer sig-id (package-root-id p)) + (datum->syntax id (syntax-e sig-id) sig-id sig-id))) + #`(begin + #,@(map (lambda (sig-id impl-id) + #`(#,def-stxes (#,(locally sig-id)) + (make-rename-transformer (quote-syntax #,impl-id)))) + (syntax->list (package-sig-ids p)) + (syntax->list (syntax-local-introduce (package-impl-ids p)))))))])) + +(define-syntax (open-package stx) + (do-open-package stx #'define-syntaxes)) +(define-syntax (open*-package stx) + (do-open-package stx #'define*-syntaxes)) + +(define-syntax (package-begin stx) + (if (eq? 'expression (syntax-local-context)) + #`(let () #,stx) + (syntax-case stx () + [(_ form ...) + #`(drive-top-level + (accumulate-package #f #f #f #,stx + #f + () + #,((make-syntax-introducer) + #'(form ...))))]))) + +(define-for-syntax (check-definition-context stx) + (when (eq? 'expression (syntax-local-context)) + (raise-syntax-error #f + "not in a definition context" + stx))) + +;; ---------------------------------------- + +(define-syntax (drive-top-level stx) + (syntax-case stx () + [(_ form) + (cond + [(eq? 'top-level (syntax-local-context)) + ;; In a opt-level context, we need to use the `(define-syntaxes + ;; (...) (values))` trick to introduce all defined names before + ;; expanding expressions. + #'(accumulate-top-level () (form))] + [else + ;; No special treatment needed: + #'form])])) + +(define-syntax (accumulate-top-level stx) + (syntax-case stx () + [(_ exp-forms ()) + #`(begin + #,@(reverse (syntax->list #'exp-forms)))] + [(_ exp-forms (form . forms)) + (let ([exp-form (local-expand #'form + (list (gensym)) + (list #'define-values + #'define-syntaxes + #'begin) + #f)]) + (syntax-case exp-form (begin define-values define-syntaxes) + [(begin form ...) + #'(accumulate-top-level exp-forms (form ... . forms))] + [(define-values (new-def-id ...) rhs) + #`(begin + (define-syntaxes (new-def-id ...) (values)) + (accumulate-top-level (#,exp-form . exp-forms) + forms))] + [(define-syntaxes . _) + #`(begin + #,exp-form + (accumulate-top-level exp-forms forms))] + [_ + #`(accumulate-top-level (#,exp-form . exp-forms) forms)]))])) + +;; ---------------------------------------- + (define-for-syntax (do-define-* stx define-values-id) (syntax-case stx () [(_ (id ...) rhs) @@ -64,395 +334,3 @@ (let-values ([(id rhs) (normalize-definition stx #'lambda)]) (quasisyntax/loc stx (define*-syntaxes (#,id) #,rhs)))) - -(begin-for-syntax - (define-struct package (exports hidden) - #:omit-define-syntaxes - #:property prop:procedure (lambda (r stx) - (raise-syntax-error - #f - "misuse of a package name" - stx))) - - (define (generate-hidden id) - ;; Like `generate-temporaries', but preserve the symbolic name - ((make-syntax-introducer) (datum->syntax #f (syntax-e id)))) - - (define (reverse-mapping who id exports hidden) - (or (ormap (lambda (m) - (and (free-identifier=? id (cdr m)) - (car m))) - exports) - (ormap (lambda (h) - (and (free-identifier=? id h) - ;; Not at top level, where free-id=? is unreliable, - ;; and re-definition is ok: - (identifier-binding id) - ;; Name is inaccessible. Generate a temporary to - ;; avoid potential duplicate-definition errors - ;; when the name is bound in the same context as - ;; the package. - (generate-hidden id))) - hidden) - id))) - -(define-for-syntax (move-props orig new) - (datum->syntax new - (syntax-e new) - orig - orig)) - -(define-for-syntax code-insp (variable-reference->module-declaration-inspector - (#%variable-reference))) -(define-for-syntax (disarm* stx) - (cond - [(and (syntax? stx) - (pair? (syntax-e stx))) - (let ([stx (syntax-disarm stx code-insp)]) - (datum->syntax stx (disarm* (syntax-e stx)) stx stx))] - [(pair? stx) (cons (disarm* (car stx)) (disarm* (cdr stx)))] - [else stx])) - -(define-for-syntax (do-define-package stx exp-stx) - (syntax-case exp-stx () - [(_ pack-id mode exports form ...) - (let ([id #'pack-id] - [exports #'exports] - [mode (syntax-e #'mode)]) - (unless (eq? mode '#:begin) - (unless (identifier? id) - (raise-syntax-error #f - "expected an identifier" - stx - id))) - (let ([exports - (cond - [(syntax->list exports) - => (lambda (l) - (for-each (lambda (i) - (unless (identifier? i) - (raise-syntax-error #f - "expected identifier to export" - stx - i))) - l) - (let ([dup-id (check-duplicate-identifier l)]) - (when dup-id - (raise-syntax-error - #f - "duplicate export" - stx - dup-id))) - l)] - [else (raise-syntax-error #f - (format "expected a parenthesized sequence of identifiers ~a" - (case mode - [(#:only) "to export"] - [(#:all-defined-except) "to exclude from export"] - [else (format "for ~a" mode)])) - stx - exports)])]) - (let* ([def-ctx (syntax-local-make-definition-context)] - [ctx (generate-expand-context #t)] - [pre-package-id (lambda (id def-ctxes) - (identifier-remove-from-definition-context - id - def-ctxes))] - [kernel-forms (list* - #'-define*-values - #'-define*-syntaxes - (kernel-form-identifier-list))] - [init-exprs (syntax->list #'(form ...))] - [new-bindings (make-bound-identifier-mapping)] - [fixup-sub-package (lambda (renamed-exports renamed-defines def-ctxes) - (lambda (stx) - (syntax-case* (disarm* stx) (define-syntaxes #%plain-app make-package quote-syntax - list cons #%plain-lambda) - free-transformer-identifier=? - [(define-syntaxes (pack-id) - (#%plain-app - make-package - (#%plain-lambda () - (#%plain-app list - (#%plain-app cons - (quote-syntax export) - (quote-syntax renamed)) - ...)) - hidden)) - (with-syntax ([(export ...) - (map (lambda (id) - (if (or (ormap (lambda (e-id) - (bound-identifier=? id e-id)) - renamed-exports) - (not (ormap (lambda (e-id) - (bound-identifier=? id e-id)) - renamed-defines))) - ;; Need to preserve the original - (pre-package-id id def-ctxes) - ;; It's not accessible, so just hide the name - ;; to avoid re-binding errors. (Is this necessary, - ;; or would `pre-package-id' take care of it?) - (generate-hidden id))) - (syntax->list #'(export ...)))]) - (syntax/loc stx - (define-syntaxes (pack-id) - (make-package - (lambda () - (list (cons (quote-syntax export) - (quote-syntax renamed)) - ...)) - hidden))))] - [_ stx])))] - [complement (lambda (bindings ids) - (let ([tmp (make-bound-identifier-mapping)]) - (bound-identifier-mapping-for-each bindings - (lambda (k v) - (bound-identifier-mapping-put! tmp k #t))) - (for-each (lambda (id) - (bound-identifier-mapping-put! tmp id #f)) - ids) - (filter - values - (bound-identifier-mapping-map tmp (lambda (k v) (and v k))))))]) - (let ([register-bindings! - (lambda (ids) - (for-each (lambda (id) - (when (bound-identifier-mapping-get new-bindings id (lambda () #f)) - (raise-syntax-error #f - "duplicate binding" - stx - id)) - (bound-identifier-mapping-put! new-bindings - id - #t)) - ids))] - [add-package-context (lambda (def-ctxes) - (lambda (stx) - (let ([q (local-expand #`(quote #,stx) - ctx - (list #'quote) - def-ctxes)]) - (syntax-case q () - [(_ stx) #'stx]))))]) - (let loop ([exprs init-exprs] - [rev-forms null] - [def-ctxes (list def-ctx)]) - (cond - [(null? exprs) - (for-each (lambda (def-ctx) - (internal-definition-context-seal def-ctx)) - def-ctxes) - (let ([exports-renamed (map (add-package-context def-ctxes) exports)] - [defined-renamed (bound-identifier-mapping-map new-bindings - (lambda (k v) k))]) - (for-each (lambda (ex renamed) - (unless (bound-identifier-mapping-get new-bindings - renamed - (lambda () #f)) - (raise-syntax-error #f - (format "no definition for ~a identifier" - (case mode - [(#:only) "exported"] - [(#:all-defined-except) "excluded"])) - stx - ex))) - exports - exports-renamed) - (let-values ([(exports exports-renamed) - (if (memq mode '(#:only #:begin)) - (values exports exports-renamed) - (let ([all-exports-renamed (complement new-bindings exports-renamed)]) - ;; In case of define*, get only the last definition: - (let ([tmp (make-bound-identifier-mapping)]) - (for-each (lambda (id) - (bound-identifier-mapping-put! - tmp - ((add-package-context def-ctxes) - (pre-package-id id def-ctxes)) - #t)) - all-exports-renamed) - (let* ([exports-renamed (bound-identifier-mapping-map tmp (lambda (k v) k))] - [exports (map (lambda (id) (pre-package-id id def-ctxes)) - exports-renamed)]) - (values exports exports-renamed)))))] - [(prune) - (lambda (stx) - (identifier-prune-lexical-context stx (list (syntax-e stx) '#%top)))]) - (with-syntax ([(export ...) (map prune exports)] - [(renamed ...) (map prune exports-renamed)] - [(hidden ...) (map prune (complement new-bindings exports-renamed))]) - (let ([body (map (fixup-sub-package exports-renamed defined-renamed def-ctxes) - (reverse rev-forms))]) - (if (eq? mode '#:begin) - (if (eq? 'expression (syntax-local-context)) - (quasisyntax/loc stx (let () #,@body)) - (quasisyntax/loc stx (begin #,@body))) - (quasisyntax/loc stx - (begin - #,@(if (eq? 'top-level (syntax-local-context)) - ;; delcare all bindings before they are used: - #`((define-syntaxes #,defined-renamed (values))) - null) - #,@body - (define-syntax pack-id - (make-package - (lambda () - (list (cons (quote-syntax export) - (quote-syntax renamed)) - ...)) - (lambda () - (list (quote-syntax hidden) ...)))))))))))] - [else - (let ([expr (local-expand (car exprs) - ctx - kernel-forms - def-ctxes)]) - (syntax-case expr (begin) - [(begin . rest) - (loop (append (flatten-begin expr) (cdr exprs)) - rev-forms - def-ctxes)] - [(def (id ...) rhs) - (and (or (free-identifier=? #'def #'define-syntaxes) - (free-identifier=? #'def #'-define*-syntaxes)) - (andmap identifier? (syntax->list #'(id ...)))) - (with-syntax ([rhs (local-transformer-expand - #'rhs - 'expression - null)]) - (let ([star? (free-identifier=? #'def #'-define*-syntaxes)] - [ids (syntax->list #'(id ...))]) - (let* ([def-ctx (if star? - (syntax-local-make-definition-context (car def-ctxes)) - (last def-ctxes))] - [ids (map - (lambda (id) (syntax-property id 'unshadowable #t)) - (if star? - (map (add-package-context (list def-ctx)) ids) - ids))]) - (syntax-local-bind-syntaxes ids #'rhs def-ctx) - (register-bindings! ids) - (loop (cdr exprs) - (cons (move-props expr #`(define-syntaxes #,ids rhs)) - rev-forms) - (if star? (cons def-ctx def-ctxes) def-ctxes)))))] - [(def (id ...) rhs) - (and (or (free-identifier=? #'def #'define-values) - (free-identifier=? #'def #'-define*-values)) - (andmap identifier? (syntax->list #'(id ...)))) - (let ([star? (free-identifier=? #'def #'-define*-values)] - [ids (syntax->list #'(id ...))]) - (let* ([def-ctx (if star? - (syntax-local-make-definition-context (car def-ctxes)) - (last def-ctxes))] - [ids (map - (lambda (id) (syntax-property id 'unshadowable #t)) - (if star? - (map (add-package-context (list def-ctx)) ids) - ids))]) - (syntax-local-bind-syntaxes ids #f def-ctx) - (register-bindings! ids) - (loop (cdr exprs) - (cons (move-props expr #`(define-values #,ids rhs)) rev-forms) - (if star? (cons def-ctx def-ctxes) def-ctxes))))] - [else - (loop (cdr exprs) - (cons (if (and (eq? mode '#:begin) - (null? (cdr exprs))) - expr - #`(define-values () (begin #,expr (values)))) - rev-forms) - def-ctxes)]))]))))))])) - -(define-syntax (define-package stx) - (syntax-case stx () - [(_ id #:all-defined form ...) - (do-define-package stx #'(define-package id #:all-defined () form ...))] - [(_ id #:all-defined-except ids form ...) - (do-define-package stx stx)] - [(_ id #:only ids form ...) - (do-define-package stx stx)] - [(_ id ids form ...) - (do-define-package stx #'(define-package id #:only ids form ...))])) - -(define-syntax (package-begin stx) - (syntax-case stx () - [(_ form ...) - (do-define-package stx #'(define-package #f #:begin () form ...))])) - -(define-for-syntax (do-open stx define-syntaxes-id) - (syntax-case stx () - [(_ pack-id) - (let ([id #'pack-id]) - (unless (identifier? id) - (raise-syntax-error #f - "expected an identifier for a package" - stx - id)) - (let ([v (syntax-local-value id (lambda () #f))]) - (unless (package? v) - (raise-syntax-error #f - "identifier is not bound to a package" - stx - id)) - (let ([introduce (syntax-local-make-delta-introducer - (syntax-local-introduce id))]) - (with-syntax ([(intro ...) - (map (lambda (i) - (syntax-local-introduce - (syntax-local-get-shadower - (introduce i)))) - (map car ((package-exports v))))] - [(defined ...) - (map (lambda (v) (syntax-local-introduce (cdr v))) - ((package-exports v)))] - [((a . b) ...) (map (lambda (p) - (cons (syntax-local-introduce (car p)) - (syntax-local-introduce (cdr p)))) - ((package-exports v)))] - [(h ...) (map syntax-local-introduce ((package-hidden v)))]) - (syntax-property - #`(#,define-syntaxes-id (intro ...) - (let ([rev-map (lambda (x) - (reverse-mapping - 'pack-id - x - (list (cons (quote-syntax a) - (quote-syntax b)) - ...) - (list (quote-syntax h) ...)))]) - (values (make-rename-transformer #'defined rev-map) - ...))) - 'disappeared-use - (syntax-local-introduce id))))))])) - -(define-syntax (open-package stx) - (do-open stx #'define-syntaxes)) -(define-syntax (open*-package stx) - (do-open stx #'define*-syntaxes)) - -(define-for-syntax (package-exported-identifiers id) - (let ([v (and (identifier? id) - (syntax-local-value id (lambda () #f)))]) - (unless (package? v) - (if (identifier? id) - (raise-arguments-error 'package-exported-identifiers "identifier is not bound to a package" - "identifier" id) - (raise-argument-error 'package-exported-identifiers "identifier?" id))) - (let ([introduce (syntax-local-make-delta-introducer - (syntax-local-introduce id))]) - (map (lambda (i) - (syntax-local-introduce - (syntax-local-get-shadower - (introduce (car i))))) - ((package-exports v)))))) - -(define-for-syntax (package-original-identifiers id) - (let ([v (and (identifier? id) - (syntax-local-value id (lambda () #f)))]) - (unless (package? v) - (if (identifier? id) - (raise-arguments-error 'package-original-identifiers "identifier is not bound to a package" - "identifier" id) - (raise-argument-error 'package-original-identifiers "identifier?" id))) - (map cdr ((package-exports v)))))