[plt-scheme] Binding transformers in a macro

From: Noel Welsh (noelwelsh at gmail.com)
Date: Thu Oct 23 12:13:20 EDT 2008

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.


Posted on the users mailing list.