cowan.scm

;; Vectorish syntactic parameterize for jcowan using only syntax rules

(define-syntax define-syntax-rule
  (syntax-rules ()
    ((_ (name . patterns) template)
     (define-syntax name
       (syntax-rules ()
         ((_ . patterns)
          template))))))

;; Oleg Kiselyov's CK macro
;; see http://okmij.org/ftp/Scheme/macros.html#ck-macros
(define-syntax ck
  (syntax-rules (quote)
    ((ck () 'v) v)                    ; yield the value on empty stack
     
    ((ck (((op ...) ea ...) . s) 'v) ; re-focus on the other argument, ea
     (ck s "arg" (op ... 'v) ea ...))
     
    ((ck s "arg" (op va ...))           ; all arguments are evaluated,
     (op s va ...))                     ; do the redex
     
    ((ck s "arg" (op ...) 'v ea1 ...) ; optimization when the first ea
     (ck s "arg" (op ... 'v) ea1 ...))  ; was already a value
     
    ((ck s "arg" (op ...) ea ea1 ...)   ; focus on ea, to evaluate it
     (ck (((op ...) ea1 ...) . s) ea))
     
    ((ck s (op ea ...))                ; Focus: handle an application;
     (ck s "arg" (op) ea ...))         ; check if args are values
    ))

(define-syntax c-cons
  (syntax-rules (quote)
    ((c-cons s 'h 't) (ck s '(h . t)))))

;; My macros
(define-syntax c-subst
  (syntax-rules (quote)
    ((_ s '() var val) (ck s '()))
    ((_ s '(a . d) var val)
     (ck s (c-cons (c-subst 'a var val)
                   (c-subst 'd var val))))
    ((_ s 'id 'var 'val)
     (let-syntax ((cont (syntax-rules (quote var)
                          ((_ var) (ck s 'val))
                          ((_ id*) (ck s 'id)))))
       (cont id)))))

(define-syntax-rule (set!! . _) (syntax-error #f "shit happen"))
(define-syntax-rule (ref   . _) (syntax-error #f "shit happen"))
(define-syntax-rule (make  . _) (syntax-error #f "shit happen"))

(define-syntax-rule (use-implementation-helper setter reffer maker body bodies ...)
  (ck () (c-subst (c-subst (c-subst '(begin body bodies ...) 'set!! 'setter)
                           'ref 'reffer)
                  'make 'maker)))

(define-syntax define-implementation
  (syntax-rules ()
    ((_ name set ref make)
     (define-syntax name
       (syntax-rules ()
         ((_ k args (... ...))
          (k set ref make args (... ...))))))))

(define-syntax-rule (use-implementation type body bodies ...)
  (type use-implementation-helper body bodies ...))

;; Example
(define-implementation %string%
  string-set! string-ref string)

(define-implementation %vector%
  vector-set! vector-ref vector)

(define-syntax-rule (define-modifier name type)
  (use-implementation type
    (define (name obj idx f)
      (set!! obj idx (f (ref obj idx))))))

(define-modifier string-modify! %string%)
(define-modifier vector-modify! %vector%)

;; scheme@(guile-user)> ,expand (define-modifier string-modify! %string%)
;; $2 = (define (string-modify! obj idx f)
;;   (string-set! obj idx (f (string-ref obj idx))))
;; scheme@(guile-user)> ,expand (define-modifier vector-modify! %vector%)
;; $3 = (define (vector-modify! obj idx f)
;;   (vector-set! obj idx (f (vector-ref obj idx))))
;; scheme@(guile-user)>