Composable macro

composable-macro.scm

#!r6rs
(import (rnrs))

;; composing macro needs to be done CPS.
(define-syntax composem (syntax-rules ()))
(define-syntax extract/cps
  (syntax-rules (composem extract/cps)
    ;; assume k is a macro which accepts cps in first argument
    ((_ (composem k) args ...) (k args ...))
    ((_ (composem k k* ...) args ...)
     (extract/cps "compose" () (k k* ...) (args ...)))

    ;; flatten the composem cps macros
    ((_ "compose" (cps ...) ((composem k ...) k* ...) args)
     (extract/cps "compose" (cps ... k ...) (k* ...) args))
    ((_ "compose" (cps ...) (k k* ...) args)
     (extract/cps "compose" (cps ... k) (k* ...) args))
    ((_ "compose" (k cps ...) () (args ...))
     (k (extract/cps (composem cps ...)) args ...))

    ;; a bit awkward...
    ((_ (extract/cps (composem k)) args ...) (k args ...))
    ((_ (extract/cps (composem k k* ...)) args ...)
     (k (extract/cps (composem k* ...)) args ...))
    ((_ (extract/cps k) args ...) (k args ...))

    ;; short cut/end point 
    ((_ k args ...) (k args ...))))

(define-syntax valuesm
  (syntax-rules ()
    ((_ args) args)
    ;; not really values but no choice
    ((_ args ...) (args ...))))

(define-syntax assocm/cps
  (syntax-rules ()
    ((_ k key (alist ...))
     (letrec-syntax ((foo (syntax-rules (key)
                            ((_ (key . d) rest (... ...))
                             (extract/cps k (key . d)))
                            ((_ (a . d) rest (... ...)) (foo rest (... ...)))
                            ((_) #f))))
       (foo alist ...)))))

(define-syntax cdrm/cps
  (syntax-rules ()
    ((_ k #f) (extract/cps k #f))
    ((_ k ()) (extract/cps k #f))
    ((_ k (a . d)) (extract/cps k d))))

(define-syntax carm/cps
  (syntax-rules ()
    ((_ k #f) (extract/cps k #f))
    ((_ k ()) (extract/cps k #f))
    ((_ k (a . d)) (extract/cps k a))))

(define-syntax define-noncps
  (syntax-rules ()
    ((_ name cps)
     (define-syntax name
       (syntax-rules ()
         ((_ args (... ...)) (cps valuesm args (... ...))))))))
(define-noncps cdrm cdrm/cps)
(define-noncps carm carm/cps)

;; testing utility macros
(define (print . args) (for-each display args) (newline))
(define d 1)
(print (assocm/cps (composem cdrm/cps carm) c ((a . b) (b . c) (c d))))

;; bit more complex one
(define-syntax define-aux
  (syntax-rules ()
    ((_ name name* ...)
     (begin
       (define-syntax name (syntax-rules ()))
       (define-aux name* ...)))
    ((_)
     (begin))))

(define-aux super slots make)

(define-syntax define-class/field-definitions
  (syntax-rules ()
    ((_ (cps k args ...))
     (extract/cps 
      (composem cps k define-class/field-definitions/cps) args ...))))
(define-syntax define-class/field-definitions/cps
  (syntax-rules ()
    ((_ slots)
     (define-class/field-definitions/cps "parse" () slots))
    ((_ "parse" (acc ...) ((slot ref/set ...) next ...))
     (define-class/field-definitions/cps "parse" 
       (acc ... 
            ((define-class/field-definitions/cps "mutable" ref/set ...) 'slot))
       (next ...)))
    ((_ "parse" ((mutable slot) ...) ()) (vector (list mutable slot) ...))
    ((_ "mutable" ref) 'immutable)
    ((_ "mutable" ref set) 'mutable)))

(define-syntax define-class/field-accessor
  (syntax-rules ()
    ((_ rtd (cps k args ...))
     (letrec-syntax ((field/cps 
                      (syntax-rules ()
                        ((_ slots)
                         (field/cps "parse" rtd () 0 slots))
                        ((_ "parse" rtd (acc (... ...)) kth
                            ((slot ref/set (... ...)) next (... ...)))
                         (field/cps "parse" rtd
                            (acc (... ...)
                                 (field/cps "define" rtd 
                                            (ref/set (... ...)) kth))
                            (+ kth 1)
                            (next (... ...))))
                        ((_ "parse" rtd (acc (... ...)) kth ())
                         (begin acc (... ...)))
                        ((_ "define" rtd (ref) kth)
                         (define ref (record-accessor rtd kth)))
                        ((_ "define" rtd (ref set) kth) 
                         (begin
                           (define ref (record-accessor rtd kth))
                           (define set (record-mutator rtd kth)))))))
     (extract/cps (composem cps k field/cps) args ...)))))

(define-syntax define-class/cps
  (syntax-rules ()
    ((_ name ctr pred super slots/cps make)
     (begin
       ;; name = rtd
       (define rtd (make-record-type-descriptor
                     'name 
                     (let ((s super)) (and s (car s)))
                     #f #f #t 
                     (define-class/field-definitions slots/cps)))
       (define rcd (make-record-constructor-descriptor
                    rtd
                    (let ((s super)) (and s (cdr s)))
                    make))
       (define name (cons rtd rcd))
       (define ctr (record-constructor rcd))
       (define pred (record-predicate rtd))
       (define-class/field-accessor rtd slots/cps)))))

(define-syntax define-class
  (syntax-rules ()
    ((_ (name ctr pred) specs ...)
     (define-class/cps name ctr pred
       (assocm/cps (composem cdrm/cps carm) super (specs ...))
       (assocm/cps cdrm/cps slots (specs ...))
       (assocm/cps (composem cdrm/cps carm) make (specs ...))))))

(define-class (<a> make-a a?)
  (slots (foo a-foo)
         (bar a-bar a-bar-set!)))

(define-class (<b> make-b b?)
  (super <a>)
  (slots (baz b-baz))
  (make (lambda (p)
          (lambda ()
            ((p 'foo 'bar) 'baz)))))

;; test
(let ((b (make-b)))
  (print "b?: " (b? b))
  (print "a?: " (a? b))
  (print "foo: " (a-foo b))
  (print "bar: " (a-bar b))
  (print "baz: " (b-baz b))
  (print "set: " (a-bar-set! b 'grr))
  (print "bar: " (a-bar b)))
;; for vicare
(flush-output-port (current-output-port))