From ac8e05bf528aef7d259c7f2526f579561e42c060 Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Fri, 29 Apr 2016 14:50:37 -0700 Subject: [PATCH] add `shared-syntax` as unhygienic helper --- beautiful-racket-lib/br/define.rkt | 35 ++++++++++++------- beautiful-racket-lib/br/main.rkt | 2 +- beautiful-racket/br/demo/hdl/tst/expander.rkt | 18 +++++----- 3 files changed, 34 insertions(+), 21 deletions(-) diff --git a/beautiful-racket-lib/br/define.rkt b/beautiful-racket-lib/br/define.rkt index d6f82a0..fdc9136 100644 --- a/beautiful-racket-lib/br/define.rkt +++ b/beautiful-racket-lib/br/define.rkt @@ -25,8 +25,9 @@ ;; expose the caller context within br:define macros with syntax parameter (begin-for-syntax (require (for-syntax racket/base) racket/stxparam) - (provide caller-stx) - (define-syntax-parameter caller-stx (λ(stx) (error 'not-parameterized)))) + (provide caller-stx shared-syntax) + (define-syntax-parameter caller-stx (λ(stx) (error 'caller-stx-not-parameterized))) + (define-syntax-parameter shared-syntax (λ(stx) (error 'shared-syntax-not-parameterized)))) (define-syntax (br:define-cases stx) @@ -69,7 +70,8 @@ (define result (syntax-case stx (LITERAL ...) [pat (syntax-parameterize ([caller-stx (make-rename-transformer #'stx)]) - result-expr)] ... + (syntax-parameterize ([shared-syntax (make-shared-syntax-macro caller-stx)]) + result-expr))] ... [else else-result-expr])) (if (not (syntax? result)) (datum->syntax #'top-id.name result) @@ -230,10 +232,6 @@ (define-for-syntax (expand-macro mac) (syntax-disarm (local-expand mac 'expression #f) #f)) -#| - [(_ (syntax (id pat-arg ... . rest-arg)) body ...) ; (define #'(foo arg) #'(+ arg arg)) - #'(br:define-cases (syntax id) [(syntax (_ pat-arg ... . rest-arg)) body ...])] -|# (define-syntax (br:define-inverting stx) (syntax-case stx (syntax) @@ -241,20 +239,33 @@ #'(br:define-cases-inverting (syntax _id) [(syntax (_ _patarg ... . _restarg)) _syntaxexpr ...])])) +(begin-for-syntax + (begin-for-syntax + (require (for-syntax racket/base)) + (define-syntax (make-shared-syntax-macro stx) + (syntax-case stx () + [(_ caller-stx) + #'(λ(stx) (syntax-case stx () + [(_ form) + #'(datum->syntax caller-stx (if (syntax? form) + (syntax-e form) + form))]))])))) (define-syntax (br:define-cases-inverting stx) (syntax-case stx (syntax) - [(_ (syntax _id) [(syntax _pat) _body ...] ...) + [(_ (syntax _id) [(syntax _pat) . _bodyexprs] ...) (with-syntax ([(LITERAL ...) (generate-literals #'(_pat ...))]) #'(define-syntax (_id stx) (syntax-case stx () [(_id . rest) - (let* ([expanded-stx (map expand-macro (syntax->list #'rest))] - [fused-stx #`(#,#'_id #,@expanded-stx)]) + (let* ([expanded-macros (map expand-macro (syntax->list #'rest))] + [fused-stx (with-syntax ([(expanded-macro (... ...)) expanded-macros]) + #`(_id expanded-macro (... ...)))]) (define result (syntax-case fused-stx (LITERAL ...) ;; put id back together with args to make whole pattern - [_pat (syntax-parameterize ([caller-stx (make-rename-transformer #'fused-stx)]) - _body ...)] ... + [_pat (syntax-parameterize ([caller-stx (make-rename-transformer #'stx)]) + (syntax-parameterize ([shared-syntax (make-shared-syntax-macro caller-stx)]) + . _bodyexprs))] ... [else (raise-syntax-error 'define-cases-inverting (format "no matching case for syntax pattern ~v" (syntax->datum stx)) (syntax->datum #'_id))])) (if (not (syntax? result)) (datum->syntax #'_id result) diff --git a/beautiful-racket-lib/br/main.rkt b/beautiful-racket-lib/br/main.rkt index e597dfc..01e80a6 100644 --- a/beautiful-racket-lib/br/main.rkt +++ b/beautiful-racket-lib/br/main.rkt @@ -6,7 +6,7 @@ (all-from-out racket/list racket/string racket/format racket/match racket/port br/syntax br/datum br/debug br/conditional) (for-syntax (all-from-out racket/base racket/syntax br/syntax)) - (for-syntax caller-stx) ; from br/define + (for-syntax caller-stx shared-syntax) ; from br/define (filtered-out (λ (name) (let ([pat (regexp "^br:")]) diff --git a/beautiful-racket/br/demo/hdl/tst/expander.rkt b/beautiful-racket/br/demo/hdl/tst/expander.rkt index 1e587eb..17e189d 100644 --- a/beautiful-racket/br/demo/hdl/tst/expander.rkt +++ b/beautiful-racket/br/demo/hdl/tst/expander.rkt @@ -15,19 +15,20 @@ (define-for-syntax output-here #'output-here) (define-inverting #'(header-expr (_filename-string _procname) (_colid ... _outid) ";") - (inject-syntax ([#'output (syntax-local-introduce output-here)]) + (inject-syntax ([#'shared-procname (shared-syntax #'_procname)] + [#'output (shared-syntax 'output)]) #'(begin (provide (all-defined-out)) - (define _procname (dynamic-require _filename-string '_procname)) + (define shared-procname (dynamic-require _filename-string 'shared-procname)) (display-header '_colid ... '_outid) - (define _colid #f) ... + (define _colid (make-parameter 0)) ... (define (_outid) - (keyword-apply _procname + (keyword-apply shared-procname (map (compose1 string->keyword symbol->string) (list '_colid ...)) - (list _colid ...) null)) + (list (_colid) ...) null)) (define (output) - (display-values _colid ... (_outid)))))) + (display-values (_colid) ... (_outid)))))) (define-inverting #'(load-expr "load" (_filename-string _procname) ",") #'(_filename-string _procname)) @@ -71,7 +72,7 @@ (define #'(set-expr "set" _id _val) - #'(set! _id _val)) + #'(_id _val)) (define #'(eval-expr "eval") @@ -79,4 +80,5 @@ (define #'(output-expr "output") - #'(output-here)) + (inject-syntax ([#'output (shared-syntax 'output)]) + #'(output)))