[plt-scheme] Binding transformers in a macro
Oh Great Gods of Syntax Transformation!
I am trying to define a form of units that
1. Is linked at expansion time (so there is no indirection at
evaluation time; i.e. defunctorisation)
2. Allow macro (aka transformer) imports
The second one is tripping me up. I call tell if an import is a
transformer with this piece of code:
(define-for-syntax (transformer? id)
(if (and (identifier? id) (syntax-local-value id (lambda () #f)))
#t
#f))
I thought I could define imports using the following piece of code:
(define-for-syntax (make-define-form import-id real-import-id context)
(if (transformer? real-import-id)
(let ([transformer (syntax-local-value real-import-id)])
(datum->syntax context
`(define-syntax ,import-id ,transformer)))
(datum->syntax context
`(define ,import-id ,real-import-id))))
But alas! I get an error:
compile: bad syntax; literal data is not allowed, because no #%datum
syntax transformer is bound in: #<procedure:...e/more-scheme.ss:90:4>
Here is the complete code:
<unet.ss>
#lang scheme/base
(require
(for-syntax scheme/base))
(define-for-syntax (transformer? id)
(if (and (identifier? id) (syntax-local-value id (lambda () #f)))
#t
#f))
(define-for-syntax (make-define-form import-id real-import-id context)
(if (transformer? real-import-id)
(let ([transformer (syntax-local-value real-import-id)])
(datum->syntax context
`(define-syntax ,import-id ,transformer)))
(datum->syntax context
`(define ,import-id ,real-import-id))))
(define-syntax (define-unet stx)
(syntax-case stx (import export)
[(define-unet name
(import import-id ...)
(export export-id ...)
impl-expr ...)
(syntax
(define-syntax (name stx)
(syntax-case stx (import export)
[(_ (import real-import-id (... ...))
(export real-export-id (... ...)))
(with-syntax ([(import (... ...))
(map
(lambda (id real-id)
(make-define-form id real-id stx))
(syntax->list (syntax (import-id ...)))
(syntax->list (syntax (real-import-id (... ...)))))])
(syntax
(begin
import (... ...)
(define-values (real-export-id (... ...))
(let ()
impl-expr ...
(values export-id ...)))
)))])))]))
(provide define-unet)
<unet-test.ss>
#lang scheme/base
(require
(planet schematics/schemeunit:3)
"unet.ss")
(define-unet basic-unet
(import foo bar)
(export baz quux)
(define baz foo)
(define quux bar))
(basic-unet
(import (lambda () 'foo)
(lambda () 'bar))
(export basic-baz basic-quux))
(basic-unet
(import (lambda () 'burp)
(lambda () 'belch))
(export burp-baz burp-quux))
(define-unet macro-unet
(import parameterize-form)
(export foo)
(define (foo)
(let ([op (open-output-string)])
(parameterize-form
([current-output-port op])
(display "foo"))
(get-output-string op))))
(macro-unet
(import parameterize)
(export macro-foo))
(define/provide-test-suite unet-tests
(test-case
"basic unet"
(check-eq? (basic-baz) 'foo)
(check-eq? (basic-quux) 'bar)
(check-eq? (burp-baz) 'burp)
(check-eq? (burp-quux) 'belch))
(test-case
"macro unet"
(check-equal? "foo" (foo))))
Your help, as always, is much appreciated.
N.