Subset of tagged language on er macro

tagged.scm

(import (scheme base) (scheme write) (scheme cxr))

(cond-expand
 (chibi (import (chibi) (chibi match)))
 (sagittarius (import (sagittarius) (match)))
 (gauche (import (gauche base) (util match)))
 (chicken (import-for-syntax (matchable)))
 (else #t))

(cond-expand
 ((and chicken csi) (import (matchable)))
 (else #t))

;; simple identifier-syntax
(define-syntax identifier-syntax
  (er-macro-transformer
   (lambda (f r c)
     (match f
       ((_ e)
	(let ((.f (r 'form))
	      (.r (r 'rename))
	      (.c (r 'compare)))
	  `(,(r 'er-macro-transformer)
	    (,(r 'lambda) (,.f ,.r ,.c)
	     (,(r 'match) ,.f
	      ((? symbol? id) ',e)
	      ((_ x ...) `(,',e ,@x)))))))))))

(define (make-tagged-variable-transformer tag-id src-var-id)
  (er-macro-transformer
   (lambda (f r c)
     (let ((TAG (r tag-id))
	   (SRC-VAR (r src-var-id)))
       (match f
	 ((??var . ??stuff) 
	  `(,TAG dispatch: ,SRC-VAR (,(r ??var) . ,(map r ??stuff))))
	 ;; how to check if this ??var is identifier/symbol
	 ;; should er-macro have identifier? procedure?
	 (??var src-var-id))))))

(cond-expand
 ((or chibi chicken)
  ;; Chicken has a problem on syntax-rules.
  ;; Chibi has a problem with define-with-caller.
  ;; so just make it like this for good sake.
  (define (parse-let-bindings bindings-stx rename compare top-id . rest)
    (let ((vars            (if (null? rest) '() (car rest)))
	  (tags            (if (null? rest) '() (cadr rest)))
	  (syntax-bindings (if (null? rest) '() (caddr rest))))
      (match bindings-stx
	(()
	 (list (reverse vars) (reverse tags) (reverse syntax-bindings)))
	(((?var ?tag) . ?other-bindings)
	 (let ((tag-id (rename ?tag)))
	   (parse-let-bindings ?other-bindings rename compare top-id
	       (cons (rename ?var) vars)
	       (cons tag-id tags)
	       (if (compare tag-id top-id)
		   syntax-bindings
		   (cons `(,?var
			   (make-tagged-variable-transformer ',tag-id
							     ',(rename ?var)))
			 syntax-bindings)))))
	(_
	 (error "parse-let-bindings: invalid bindings syntax" bindings-stx)))))
  )
 (else
  (define-syntax %define-inline
    (syntax-rules ()
      ((_ (?name ?arg ... . ?rest) ?form0 ?form ...)
       (define-syntax ?name
	 (syntax-rules ()
	   ((_ ?arg ... . ?rest)
	    (begin ?form0 ?form ...)))))))

  (define-syntax define-with-caller
    (er-macro-transformer
     (lambda (f r c)
       (define (rename* expr)
	 (cond ((null? expr) expr)
	       ((pair? expr)
		(cons (rename* (car expr))
		      (rename* (cdr expr))))
	       ((vector? expr)
		(list->vector (rename* (vector->list expr))))
	       ((string? expr) expr)
	       (else (r expr))))
       (match f
	 ((_ (?who (?caller-arg ...) ((?func-arg ?func-default) ...))
	     ?body0 ?body ...)
	  (let ((FUNCTION (r (string->symbol "dummy"))))
	    `(,(r 'begin)
	      (,(r 'define) (,FUNCTION ,@?caller-arg ,@?func-arg)
	       (,(r 'let-syntax) ((,?who (,(r 'identifier-syntax) ,FUNCTION)))
		,?body0
		,@?body))
	      (,(r '%define-inline) (,?who ,@?caller-arg)
	       (,FUNCTION ,@?caller-arg ,@?func-default)))))))))



  (define-with-caller (parse-let-bindings (bindings-stx rename compare top-id)
					  ((vars            '())
					   (tags            '())
					   (syntax-bindings '())))
    (match bindings-stx
      (()
       (list (reverse vars) (reverse tags) (reverse syntax-bindings)))
      (((?var ?tag) . ?other-bindings)
       (let ((tag-id (rename ?tag)))
	 (parse-let-bindings ?other-bindings rename compare top-id
	     (cons (rename ?var) vars)
	     (cons tag-id tags)
	     (if (compare tag-id top-id)
		 syntax-bindings
		 (cons `(,?var
			 (make-tagged-variable-transformer ',tag-id
							   ',(rename ?var)))
		       syntax-bindings)))))
      (_
       (error "parse-let-bindings: invalid bindings syntax" bindings-stx))))
  ))


(define-syntax with-tags
  (er-macro-transformer
   (lambda (f r c)
     (define (rename* expr)
       (cond ((null? expr) expr)
	     ((pair? expr)
	      (cons (rename* (car expr))
		    (rename* (cdr expr))))
	     ((vector? expr)
	      (list->vector (rename* (vector->list expr))))
	     (else (r expr))))
     (match f
       ((_ (?var ...) ?body0 ?body ...)
	(match (parse-let-bindings (rename* ?var) r c (r '<top>))
	  (((VAR ...) (TAG ...) (SYNTAX-BINDING ...))
	   `(,(r 'let-syntax) (,@SYNTAX-BINDING) 
	     ,(rename* ?body0)
	     ,@(rename* ?body)))))))))

(define-syntax <beta>
  (er-macro-transformer
   (lambda (f r c)
     (match f
       ((_ 'dispatch: src (var . stuff)) 
	(display 'dispatched!) (newline) (r src))))))

(define (beta-def-ref o)
  (with-tags ((o <beta>))
    (list (o d) (o e) (o f))))
(display (beta-def-ref 'a)) (newline)
;; (a a a)

(define (beta-def-ref2 o)
  (with-tags ((oo <beta>))
    (list (oo d) (oo e) (oo f))))
;; -> error

You can run this on CHICKEN by loading matchable for expansion with the following:

--- tagged.scm.orig 2015-04-22 16:11:33.172144443 +1200
+++ tagged.scm  2015-04-22 16:31:49.620108876 +1200
@@ -4,9 +4,14 @@
  (chibi (import (chibi) (chibi match)))
  (sagittarius (import (sagittarius) (match)))
  (gauche (import (gauche base) (util match)))
- (chicken (import (matchable)))
+ (chicken (import-for-syntax (matchable)))
  (else #t))

+(cond-expand
+  ((and chicken csi) ; when run with `csi -R r7rs -s ...`
+   (import (matchable)))
+  (else #t))
+
 ;; simple identifier-syntax
 (define-syntax identifier-syntax
   (er-macro-transformer

Then the script gives the following when compiled (with csc -R r7rs tagged.scm) or interpreted:

$ csi -R r7rs -s tagged.scm                                    
dispatched!
dispatched!
dispatched!
dispatched!
dispatched!
dispatched!

Awesome! Thanks :)