(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") "rename-below.ss") (provide top/error rename-below import export define-values-below define-below define-values/invoke-unit/below) (define-syntax (top/error stx) (syntax-case stx () [(t/e . id) (identifier? #'id) (raise-syntax-error #f "undefined" #'id)])) (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 (define-values-below (var) 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-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 ;; This lines "declares" top-level names (define-syntaxes (above ...) (values)) (define-syntaxes (below ...) (values (lambda (below-stx) (rename-transform (syntax above) below-stx)) ...))))])) (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])) |# )