(module define-below mzscheme (require-for-syntax (planet "syntax-utils.ss" ("cce" "syntax-utils.plt" 1 1)) (planet "combinators.ss" ("cce" "combinators.plt" 1 4)) (planet "stx.ss" ("ryanc" "macros.plt" 1 0)) (lib "boundmap.ss" "syntax") (lib "unit-exptime.ss")) (require (planet "phase.ss" ("cce" "syntax-utils.plt" 1 1)) (lib "unit.ss")) (provide top/error rename-below define-values-below define-below define-values/invoke-unit/below import export) (define-for-syntax defined-name-mapping (make-module-identifier-mapping)) (define-syntax (top/error stx) (syntax-case stx () [(t/e . id) (identifier? #'id) (raise-syntax-error #f "undefined" #'id)])) (define-syntax (rename-below stx) (syntax-case stx () [(r-b [above below] ...) (begin (for-each (lambda (id) (unless (identifier? id) (raise-syntax-error #f "expected an identifier" stx id))) (syntax->list #'(above ... below ...))) (case (syntax-local-context) [( module module-begin ) (syntax/loc stx (rename-below/module [above below] ...))] [( top-level ) (syntax/loc stx (rename-below/top-level [above below] ...))] [else (raise-syntax-error #f "used outside a top-level context" stx)]))])) (define-syntax (rename-below/module rename-stx) (syntax-case rename-stx () [(r-b/m [above below] ...) (begin (syntax-local-lift-module-end-declaration (syntax/loc rename-stx (in-phase1 (set-box! below? #f)))) (syntax/loc rename-stx (begin (define-for-syntax below? (box #t)) (in-phase1 (set-box! below? #t)) (#%expression (in-phase1 (set-box! below? #t))) (define-syntax (below below-stx) (unless (unbox below?) (raise-syntax-error #f "used before definition" below-stx)) (rename-transform (syntax above) below-stx)) ...)))])) (define-syntax (rename-below/top-level rename-stx) (syntax-case rename-stx () [(r-b/t-l [above below] ...) (syntax/loc rename-stx (begin (define-syntax (below below-stx) (rename-transform (syntax above) below-stx)) ...))])) (define-syntax (define-values/invoke-unit/below stx) (syntax-case stx ( import export ) [(d/i/b u@ (import i^ ...) (export e^ ...)) (let*-values ([(exports) (syntax->list (syntax (e^ ...)))] [(parents var-lists def-lists stx-lists) (map/values 4 (yrruc signature-members stx) exports)]) (with-syntax* ([((e^-orig ...) ...) (map append var-lists def-lists stx-lists)] [((e^-name ...) ...) (map (lambda (names) (map syntax-local-introduce (syntax->list names))) (syntax->list (syntax ((e^-orig ...) ...))))] [((e^-temp ...) ...) (map generate-temporaries (syntax->list #'((e^-name ...) ...)))]) (syntax/loc stx (begin (define-values/invoke-unit u@ (import i^ ...) (export (rename e^ [e^-temp e^-name] ...) ...)) (rename-below [e^-temp e^-name] ... ...)))))])) (define-syntax (define-below stx) (syntax-case stx () [(d-b (header . formals) . body) (syntax/loc stx (d-b header (lambda formals . body)))] [(d-b var body) (syntax/loc stx (begin (rename-below [hidden var]) (define hidden body)))])) (define-syntax (define-values-below stx) (syntax-case stx () [(d-v-b (var ...) body) (with-syntax ([(hidden ...) (generate-temporaries #'(var ...))]) (syntax/loc stx (begin (rename-below [hidden var] ...) (define-values (hidden ...) body))))])) (define-for-syntax (rename-transform id stx) (syntax-case stx () [(head . rest) (identifier? #'head) (with-syntax ([id id]) (syntax/loc stx (id . rest)))] [_ (identifier? stx) id])) )