(module reqprov '#%kernel (#%require "more-scheme.ss" "small-scheme.ss" "define.ss" "../stxparam.ss" (for-syntax '#%kernel "define.ss" "stx.ss" "stxcase-scheme.ss" "small-scheme.ss" "stxloc.ss" "qqstx.ss" "../require-transform.ss" "../provide-transform.ss" "struct-info.ss")) (#%provide lib file planet for-syntax for-template for-label for-meta require only-in rename-in prefix-in except-in combine-in only-meta-in provide all-defined-out all-from-out rename-out except-out prefix-out struct-out combine-out protect-out) ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; helpers (define-for-syntax (filter pred l) (cond [(null? l) null] [(pred (car l)) (cons (car l) (filter pred (cdr l)))] [else (filter pred (cdr l))])) ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; lib (define-for-syntax (xlate-path stx) (if (pair? (syntax-e stx)) (let ([kw ;; symbolic-identifier=? identifers are not necessarily free-identifier=? (syntax-case stx (lib planet file quote) [(quote . _) 'quote] [(lib . _) 'lib] [(planet . _) 'planet] [(file . _) 'file])] [d (syntax->datum stx)]) (if (eq? (car d) kw) stx (datum->syntax stx (cons kw (cdr d)) stx stx))) stx)) (define-for-syntax (check-lib-form stx) (unless (module-path? (syntax->datum (xlate-path stx))) (raise-syntax-error #f "ill-formed module path" stx))) (define-syntaxes (lib file planet) (let ([t (lambda (stx) (check-lib-form stx) (let* ([mod-path (syntax->datum stx)] [namess (syntax-local-module-exports stx)]) (values (apply append (map (lambda (names) (let ([mode (car names)]) (map (lambda (name) (make-import (datum->syntax stx name stx) name mod-path mode 0 mode stx)) (cdr names)))) namess)) (list (make-import-source stx 0)))))]) (let ([t2 (let-values ([(s: mk s? s-ref s-set!) (make-struct-type 'req+prov #f 0 0 #f (list (cons prop:require-transformer (lambda (a) t))) (current-inspector) (lambda (p stx) (raise-syntax-error #f "misuse of module-path constructor (not within, e.g., `require' or `provide')" stx)))]) (mk))]) (values t2 t2 t2)))) ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; for-syntax, for-template, for-label (define-for-syntax (phase+ a b) (and a b (+ a b))) (define-for-syntax (shift-subs stx mode) (syntax-case stx () [(_ in ...) (let* ([imports+sourcess (map (lambda (in) (let-values ([(imports sources) (expand-import in)]) (cons imports sources))) (syntax->list #'(in ...)))] [imports (apply append (map car imports+sourcess))] [sources (apply append (map cdr imports+sourcess))]) (values (map (lambda (import) (make-import (import-local-id import) (import-src-sym import) (import-src-mod-path import) (phase+ mode (import-mode import)) (phase+ mode (import-req-mode import)) (import-orig-mode import) (import-orig-stx import))) imports) (map (lambda (source) (make-import-source (import-source-mod-path-stx source) (phase+ mode (import-source-mode source)))) sources)))])) (define-for-syntax (make-require+provide-transformer r p) (let-values ([(s: mk s? s-ref s-set!) (make-struct-type 'req+prov #f 0 0 #f (list (cons prop:require-transformer (lambda (a) r)) (cons prop:provide-transformer (lambda (a) p))))]) (mk))) (define-for-syntax (exports-at-phase stx modes mode) (if (not (null? modes)) (raise-syntax-error #f "nested phases specification not allowed" stx) (syntax-case stx () [(_ ex ...) (apply append (map (lambda (ex) (expand-export ex (list mode))) (syntax->list #'(ex ...))))]))) (define-syntax for-syntax (make-require+provide-transformer (lambda (stx) (shift-subs stx 1)) (lambda (stx modes) (exports-at-phase stx modes 1)))) (define-syntax for-template (make-require+provide-transformer (lambda (stx) (shift-subs stx -1)) (lambda (stx modes) (exports-at-phase stx modes -1)))) (define-syntax for-label (make-require+provide-transformer (lambda (stx) (shift-subs stx #f)) (lambda (stx modes) (exports-at-phase stx modes #f)))) (define-syntax for-meta (make-require+provide-transformer (lambda (stx) (syntax-case stx () [(_ mode in ...) (let ([base-mode (syntax-e #'mode)]) (unless (or (not base-mode) (exact-integer? base-mode)) (raise-syntax-error #f "phase level must be #f or an exact integer" stx #'mode)) (shift-subs #'(for-meta in ...) base-mode))])) (lambda (stx modes) (syntax-case stx () [(_ mode out ...) (let ([base-mode (syntax-e #'mode)]) (unless (or (not base-mode) (exact-integer? base-mode)) (raise-syntax-error #f "phase level must be #f or an exact integer" stx #'mode)) (exports-at-phase #'(for-meta out ...) modes base-mode))])))) ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; require (define-syntax (require stx) (unless (memq (syntax-local-context) '(module module-begin top-level)) (raise-syntax-error #f "not at module level or top level" stx)) (letrec ([mode-wrap (lambda (mode base) (cond [(eq? mode 0) base] [else #`(for-meta #,mode #,base)]))] [simple-path? (lambda (p) (syntax-case p (lib quote) [(lib . _) (check-lib-form p)] [(quote . _) (check-lib-form p)] [_ (or (identifier? p) (and (string? (syntax-e p)) (module-path? (syntax-e p))))]))] [transform-simple (lambda (in base-mode) (syntax-case in (lib file planet prefix-in except-in quote) ;; Detect simple cases first: [_ (string? (syntax-e in)) (begin (unless (module-path? (syntax-e in)) (raise-syntax-error #f "bad module-path string" stx in)) (list (mode-wrap base-mode in)))] [_ (and (identifier? in) (module-path? (syntax-e #'in))) (list (mode-wrap base-mode in))] [(quote . s) (check-lib-form in) (list (mode-wrap base-mode (xlate-path in)))] [(lib . s) (check-lib-form in) (list (mode-wrap base-mode (xlate-path in)))] [(file . s) (check-lib-form in) (list (mode-wrap base-mode (xlate-path in)))] [(planet . s) (check-lib-form in) (list (mode-wrap base-mode (xlate-path in)))] [(prefix-in pfx path) (simple-path? #'path) (list (mode-wrap base-mode (datum->syntax #'path (syntax-e (quasisyntax (prefix pfx #,(xlate-path #'path)))) in in)))] [(except-in path id ...) (and (simple-path? #'path) ;; check that it's well-formed... (call-with-values (lambda () (expand-import in)) (lambda (a b) #t))) (list (mode-wrap base-mode (datum->syntax #'path (syntax-e (quasisyntax/loc in (all-except #,(xlate-path #'path) id ...))))))] ;; General case: [_ (let-values ([(imports sources) (expand-import in)]) ;; TODO: collapse back to simple cases when possible (append (map (lambda (import) #`(just-meta #,(import-orig-mode import) #,(mode-wrap (phase+ base-mode (import-req-mode import)) #`(rename #,(import-src-mod-path import) #,(import-local-id import) #,(import-src-sym import))))) imports) (map (lambda (src) (mode-wrap (phase+ base-mode (import-source-mode src)) #`(only #,(import-source-mod-path-stx src)))) sources)))]))] [transform-one (lambda (in) ;; Recognize `for-syntax', etc. for simple cases: (syntax-case in (for-meta) [(for-meta n elem ...) (or (exact-integer? (syntax-e #'n)) (not (syntax-e #'n))) (apply append (map (lambda (in) (transform-simple in (syntax-e #'n))) (syntax->list #'(elem ...))))] [(for-something elem ...) (and (identifier? #'for-something) (ormap (lambda (i) (free-identifier=? i #'for-something)) (list #'for-syntax #'for-template #'for-label))) (apply append (map (lambda (in) (transform-simple in (cond [(free-identifier=? #'for-something #'for-syntax) 1] [(free-identifier=? #'for-something #'for-template) -1] [(free-identifier=? #'for-something #'for-label) #f]))) (syntax->list #'(elem ...))))] [_ (transform-simple in 0 #| run phase |#)]))]) (syntax-case stx () [(_ in ...) (with-syntax ([(new-in ...) (apply append (map transform-one (syntax->list #'(in ...))))]) (syntax/loc stx (#%require new-in ...)))]))) ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; require transformers (define-syntax only-in (make-require-transformer (lambda (stx) (syntax-case stx () [(_ in id ...) (let-values ([(imports sources) (expand-import #'in)] [(ids) (syntax->list #'(id ...))]) (for-each (lambda (id) (unless (or (identifier? id) (let ([l (syntax->list id)]) (and l (= 2 (length l)) (identifier? (car l)) (identifier? (cadr l))))) (raise-syntax-error #f "expected or [ ], but found something else" stx id))) ids) (let ([orig-ids (map (lambda (id) (if (identifier? id) id (car (syntax-e id)))) ids)] [new-ids (map (lambda (id) (if (identifier? id) id (cadr (syntax->list id)))) ids)]) (let ([dup-id (check-duplicate-identifier new-ids)]) (when dup-id (raise-syntax-error #f "duplicate identifier" stx dup-id))) (values (apply append (map (lambda (new-id orig-id) (let ([l (filter values (map (lambda (import) (and (free-identifier=? orig-id (import-local-id import)) ; don't compare at mode (if (eq? new-id orig-id) import (make-import new-id (import-src-sym import) (import-src-mod-path import) (import-mode import) (import-req-mode import) (import-orig-mode import) new-id)))) imports))]) (if (null? l) (raise-syntax-error #f (format "identifier `~a' not included in nested require spec" (syntax-e orig-id)) stx #'in) l))) new-ids orig-ids)) sources)))])))) (define-syntax except-in (make-require-transformer (lambda (stx) (syntax-case stx () [(_ in id ...) (let-values ([(imports sources) (expand-import #'in)] [(ids) (syntax->list #'(id ...))]) (for-each (lambda (id) (unless (identifier? id) (raise-syntax-error #f "expected , but found something else" stx id))) ids) (let ([dup-id (check-duplicate-identifier ids)]) (when dup-id (raise-syntax-error #f "duplicate identifier" stx dup-id))) (for-each (lambda (id) (or (ormap (lambda (import) (free-identifier=? id (import-local-id import))) imports) (raise-syntax-error #f (format "identifier `~a' not included in nested require spec" (syntax-e id)) stx #'in))) ids) (values (filter (lambda (import) (not (ormap (lambda (id) (free-identifier=? id (import-local-id import))) ids))) imports) sources))])))) (define-syntax combine-in (make-require-transformer (lambda (stx) (syntax-case stx () [(_ in ...) (let ([subs (map (lambda (in) (let-values ([(imports sources) (expand-import in)]) (cons imports sources))) (syntax->list #'(in ...)))]) (values (apply append (map car subs)) (apply append (map cdr subs))))])))) (define-syntax only-meta-in (make-require-transformer (lambda (stx) (syntax-case stx () [(_ mode in ...) (let ([base-mode (syntax-e #'mode)]) (unless (or (not base-mode) (exact-integer? base-mode)) (raise-syntax-error #f "phase level must be #f or an exact integer" stx #'mode)) (let ([subs (map (lambda (in) (let-values ([(imports sources) (expand-import in)]) (cons (filter (lambda (import) (equal? (import-mode import) base-mode)) imports) sources))) (syntax->list #'(in ...)))]) (values (apply append (map car subs)) (apply append (map cdr subs)))))])))) (define-syntax rename-in (make-require-transformer (lambda (stx) (syntax-case stx () [(_ in [orig-id bind-id] ...) (let-values ([(imports sources) (expand-import #'in)] [(orig-ids) (syntax->list #'(orig-id ...))] [(bind-ids) (syntax->list #'(bind-id ...))]) (for-each (lambda (id) (unless (identifier? id) (raise-syntax-error #f "expected an identifier, but found something else" stx id))) (append orig-ids bind-ids)) (let ([dup-id (check-duplicate-identifier bind-ids)]) (when dup-id (raise-syntax-error #f "duplicate identifier" stx dup-id))) (let ([new+olds (apply append (map (lambda (orig-id bind-id) (let ([rename-imports (filter (lambda (import) (free-identifier=? orig-id (import-local-id import))) imports)]) (unless (pair? rename-imports) (raise-syntax-error #f (format "identifier `~a' not included in nested require spec" (syntax-e orig-id)) stx #'in)) (map (lambda (import) (cons (make-import bind-id (import-src-sym import) (import-src-mod-path import) (import-mode import) (import-req-mode import) (import-orig-mode import) bind-id) import)) rename-imports))) orig-ids bind-ids))]) (let ([leftover-imports (let ([ht (make-immutable-hash (map (lambda (v) (cons (cdr v) #f)) new+olds))]) (filter (lambda (i) (hash-ref ht i #t)) imports))]) ;; Make sure no new name is in the leftover set: (for-each (lambda (bind-id) (when (ormap (lambda (import) (and (free-identifier=? bind-id (import-local-id import)) import)) leftover-imports) (raise-syntax-error #f (format "identifier `~a' already in nested require spec" (syntax-e bind-id)) stx #'in))) bind-ids) (values (append (map car new+olds) leftover-imports) sources))))])))) (define-syntax prefix-in (make-require-transformer (lambda (stx) (syntax-case stx () [(_ pfx in) (let-values ([(imports sources) (expand-import #'in)] [(pfx) #'pfx]) (unless (identifier? #'pfx) (raise-syntax-error #f "expected an for prefix, found something else" stx #'pfx)) (values (map (lambda (import) (let ([id (import-local-id import)]) (make-import (datum->syntax id (string->symbol (format "~a~a" (syntax-e pfx) (syntax-e id))) id id) (import-src-sym import) (import-src-mod-path import) (import-mode import) (import-req-mode import) (import-orig-mode import) (import-orig-stx import)))) imports) sources))])))) ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; provide (define-syntax (provide stx) (unless (memq (syntax-local-context) '(module module-begin)) (raise-syntax-error #f "not at module level" stx)) (syntax-case stx () [(_ out ...) (syntax-property (quasisyntax/loc stx (#%provide #,(syntax-property #`(expand (provide-trampoline out ...)) 'certify-mode 'transparent))) 'certify-mode 'transparent)])) (define-syntax (provide-trampoline stx) (syntax-case stx () [(_ out ...) (letrec ([transform-simple (lambda (out) (let ([exports (expand-export out null)]) (map (lambda (export) (let ([base (if (eq? (syntax-e (export-local-id export)) (export-out-sym export)) (export-local-id export) #`(rename #,(export-local-id export) #,(export-out-sym export)))] [mode (export-mode export)]) (let ([phased (cond [(eq? mode 0) base] [else #`(for-meta #,mode #,base)])]) (if (export-protect? export) #`(protect #,phased) phased)))) exports)))]) (syntax-case stx () [(_ out ...) (with-syntax ([(new-out ...) (apply append (map transform-simple (syntax->list #'(out ...))))]) (syntax/loc stx (begin new-out ...)))]))])) ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; provide transformers (define-syntax all-defined-out (make-provide-transformer (lambda (stx modes) (syntax-case stx () [(_) (let-values ([(ids stx-ids) (syntax-local-module-defined-identifiers)] [(same-ctx?) (lambda (free-identifier=?) (lambda (id) (free-identifier=? id (datum->syntax stx (syntax-e id)))))]) (append (if (memq 1 modes) (map (lambda (id) (make-export id (syntax-e id) 1 #f stx)) (filter (same-ctx? free-transformer-identifier=?) stx-ids)) null) (if (or (null? modes) (memq 0 modes)) (map (lambda (id) (make-export id (syntax-e id) 0 #f stx)) (filter (same-ctx? free-identifier=?) ids)) null)))])))) (define-syntax all-from-out (make-provide-transformer (lambda (stx modes) (syntax-case stx () [(_ mp ...) (apply append (map (lambda (mp) (unless (module-path? (syntax->datum mp)) (raise-syntax-error #f "bad module path" stx mp)) (let ([idss (apply append (map (lambda (mode) (let ([r (syntax-local-module-required-identifiers (syntax->datum mp) mode)]) (or r (raise-syntax-error #f (format "no corresponding require~a" (cond [(eq? mode 0) ""] [(not mode) " at the label phase level"] [else (format " at phase level ~a" mode)])) stx mp)))) (if (null? modes) '(0) modes)))] [ok-context? (lambda (id id=?) (id=? id (datum->syntax mp (syntax-e id))))]) (filter values (apply append (map (lambda (ids) (let ([mode (car ids)]) (map (lambda (id) (and (free-identifier=? id (datum->syntax mp (syntax-e id)) mode) (make-export id (syntax-e id) mode #f stx))) (cdr ids)))) idss))))) (syntax->list #'(mp ...))))])))) (define-syntax rename-out (make-provide-transformer (lambda (stx modes) (syntax-case stx () [(_ [orig-id bind-id] ...) (let ([orig-ids (syntax->list #'(orig-id ...))] [bind-ids (syntax->list #'(bind-id ...))]) (for-each (lambda (id) (unless (identifier? id) (raise-syntax-error #f "expected an identifier, but found something else" stx id))) (append orig-ids bind-ids)) (apply append (map (lambda (mode) (map (lambda (orig-id bind-id) (unless (list? (identifier-binding orig-id mode)) (raise-syntax-error #f (format "no binding~a for identifier" (cond [(eq? mode 0) ""] [(not mode) " in the label phase level"] [(not mode) (format " at phase level ~a" mode)] [else ""])) stx orig-id)) (make-export orig-id (syntax-e bind-id) mode #f bind-id)) orig-ids bind-ids)) (if (null? modes) '(0) modes))))])))) (define-syntax except-out (make-provide-transformer (lambda (stx modes) (syntax-case stx () [(_ out spec ...) (let ([exports (expand-export #'out modes)] [exceptions (apply append (map (lambda (spec) (expand-export spec modes)) (syntax->list #'(spec ...))))]) (for-each (lambda (exception) (or (ormap (lambda (export) (and (eq? (export-mode export) (export-mode exception)) (free-identifier=? (export-local-id exception) (export-local-id export) (export-mode export)))) exports) (raise-syntax-error #f (format "identifier to remove `~a' not included in nested provide spec" (syntax-e (export-local-id exception))) stx #'out))) exceptions) (filter (lambda (export) (not (ormap (lambda (exception) (and (eq? (export-mode export) (export-mode exception)) (free-identifier=? (export-local-id exception) (export-local-id export) (export-mode export)))) exceptions))) exports))])))) (define-for-syntax (build-name id . parts) (datum->syntax id (string->symbol (apply string-append (map (lambda (p) (if (syntax? p) (symbol->string (syntax-e p)) p)) parts))) id)) (define-syntax struct-out (make-provide-transformer (lambda (stx modes) (unless (or (null? modes) (equal? '(0) modes)) (raise-syntax-error #f "allowed only for phase level 0" stx)) (syntax-case stx () [(_ id) (let ([id #'id]) (unless (identifier? id) (raise-syntax-error #f "expected an identifier for a struct-type name, but found something else" stx id)) (let ([v (syntax-local-value id (lambda () #f))]) (if (struct-info? v) (let* ([v (extract-struct-info v)] [super-v (let ([super-id (list-ref v 5)]) (and (identifier? super-id) (let ([super-v (syntax-local-value super-id (lambda () #f))]) (and (struct-info? super-v) (extract-struct-info super-v)))))] [list-ize (lambda (ids super-ids) (let loop ([ids ids]) (cond [(not (pair? ids)) null] [(and (pair? super-ids) (car ids) (free-identifier=? (car ids) (car super-ids))) ;; stop because we got to ids that belong to the supertype null] [else (cons (car ids) (loop (cdr ids)))])))] ;; FIXME: we're building a list of all imports on every expansion ;; of `syntax-out'. That could become expensive if `syntax-out' is ;; used a lot. [avail-ids (append (let-values ([(ids _) (syntax-local-module-defined-identifiers)]) ids) (let ([idss (syntax-local-module-required-identifiers #f #t)]) (if idss (let ([a (assoc 0 idss)]) (if a (cdr a) null)) null)))] [find-imported/defined (lambda (id) (let ([ids (filter (lambda (id2) (and (free-identifier=? id2 id) id2)) avail-ids)]) (cond [(or (null? ids) (pair? (cdr ids))) (raise-syntax-error #f (if (null? ids) "no import for structure-type identifier" (format "multiple imports (~a~a~a~a) for structure-type identifier" (syntax-e (car ids)) (if (null? (cddr ids)) " and " ", ") (syntax-e (cadr ids)) (if (null? (cddr ids)) "" ", ..."))) stx id)] [else (car ids)])))]) (filter values (map (lambda (id) (and id (let ([id (find-imported/defined id)]) (make-export id (syntax-e id) 0 #f id)))) (append (list id (list-ref v 0) (list-ref v 1) (list-ref v 2)) (list-ize (list-ref v 3) (and super-v (list-ref super-v 3))) (list-ize (list-ref v 4) (and super-v (list-ref super-v 3))))))) (raise-syntax-error #f "identifier is not bound to struct type information" stx id))))])))) (define-syntax combine-out (make-provide-transformer (lambda (stx modes) (syntax-case stx () [(_ out ...) (apply append (map (lambda (out) (expand-export out modes)) (syntax->list #'(out ...))))])))) (define-syntax protect-out (make-provide-transformer (lambda (stx modes) (syntax-case stx () [(_ out ...) (let ([exports (apply append (map (lambda (out) (expand-export out modes)) (syntax->list #'(out ...))))]) (map (lambda (e) (make-export (export-local-id e) (export-out-sym e) (export-mode e) #t (export-orig-stx e))) exports))])))) (define-syntax prefix-out (make-provide-transformer (lambda (stx modes) (syntax-case stx () [(_ pfx out) (let ([exports (expand-export #'out modes)]) (unless (identifier? #'pfx) (raise-syntax-error #f "expected an for prefix, found something else" stx #'pfx)) (map (lambda (e) (make-export (export-local-id e) (string->symbol (format "~s~s" (syntax-e #'pfx) (export-out-sym e))) (export-mode e) (export-protect? e) (export-orig-stx e))) exports))])))) ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; )