; How to build "identifiers" with syntax-rules: define-structure as a
; R5RS macro
; The code for Scheme48
; See define-struct.html in this directory for explanation.
;
; How to run this code
;
; $ scheme48
; > ,open srfi-9 
; > ,load def-struct.scm
;
; $Id: def-struct.scm,v 1.2 2004/05/16 23:12:14 oleg Exp oleg $


; The following is a set of CPS macros for 'define-structure'
; All the build macros can be made internal and thus hidden.
; Top-level macros are more lucid however. Code with top-level
; macros is also easier to debug.


(define-syntax define-structure
  (syntax-rules (set!)
    ((_ name field ...)
     (build-maker name (field ...) (set!) () () ))))

; The creator of the structure will be bound to a fresh, colored identifier
; 'maker'
; Generate rules to expand (name *maker*) to that identifier
; Generate rules to expand (name *maker* fld1 fld2 ...) to (maker fld1 fld2...)
(define-syntax build-maker
  (syntax-rules (*make*)
    ((_ name fields (set!-lit . literals) rules defines)
     (build-predicate
       name fields
       (set!-lit *make* . literals)  ; add *make* to list of literal symbs
       ( ((name *make*) maker) 
	 ((name *make* . args) (maker . args))
       . rules)
       ((maker . fields) . defines)))))


; The predicate of the structure will be bound to a fresh, colored identifier
; 'predicate'
; We generate expansion rules for the 'name' macro to be defined later

(define-syntax build-predicate
  (syntax-rules (?)
    ((_ name fields (set!-lit . literals) rules defines)
     (build-field
       name fields (set!-lit ? . literals) 
       ( ((name ?) predicate) 
	 ((name ? arg) (predicate arg))
       . rules)
       (predicate . defines)))))

; The getter and the setter for a field will be bound to a fresh,
; colored identifiers 'getter' and 'setter'. The names are the same for
; all fields, but the colors are different.

(define-syntax build-field
  (syntax-rules ()
    ((_ name (field . fields) (set! . literals) rules defines)
     (build-field
       name fields (set! field . literals)
       ; expansion rules for the 'name' macro regarding field access
       (			; Order is important! match for set! first
	 ((name field set!) setter)
	 ((name field set!  rec new-val) (setter rec new-val))
	 ((name field)      getter) 
	 ((name field arg)  (getter arg))
       . rules)
       ((field getter setter) . defines)))
    ; no more fields, we're almost finished. Reverse the defines first
    ((_ name () literals rules defines)
     (reverse-cps defines () (build-finish () name literals rules)))))

; (reverse-cps lst () k) reverses lst and passes the result to k
(define-syntax reverse-cps
  (syntax-rules ()
    ((_ () accum (head () . args))
     (head accum . args))
    ((_ (x . rest) accum k)
     (reverse-cps rest (x . accum) k))))

; Finish the processing of 'define-structure'
; Generate 'define-record-type' form and a 'define-syntax' for the name
; macro
(define-syntax build-finish
  (syntax-rules ()
    ((_ defines name literals rules)
     (begin
       (define-record-type rectype . defines)
       (define-syntax name
	 (syntax-rules literals . rules))))))

; Redirect (make name args) to (name *maker* args)
; I think in C++ parlance, this trick is called a secondary dispatch
(define-syntax make
  (syntax-rules (*make*)
    ((_ name . args) (name *make* . args))))

; examples
(display "Example from Gambit-C") (newline)
(define-structure point x y color)
(let ((p (make point 3 5 'red)))  ; cf (make-point 3 5 'red)
  (display (point x p))           ; cf (point-x p)
  (newline)
  (display (point color p))       ; cf (point-color p)
  (newline)
  (point color set! p 'black)     ; (point-color-set! p 'black)
  (display (point color p))       ; cf (point-color p)
  (newline)
)


(display "Example with higher-order functions") (newline)
(define-structure wish adj noun punct)
(let ((w (make wish #f #f #f)))
   (for-each
     (lambda (setter value) (setter w value))
     (list (wish adj set!) (wish noun set!) (wish punct set!))
     (list "Happy" "Holidays" "!"))
  (for-each
    (lambda (pred getter)
      (if (pred w) (display (getter w)) (display #\space)))
    `(,(wish ?) ,(lambda (_) #f) ,(wish ?) ,(wish ?))
    `(,(wish adj) #f ,(wish noun) ,(wish punct)))
  (newline)
)