; How to build "identifiers" with syntax-rules: define-structure as a
; R5RS macro
; The code for Scheme48, SCM, Bigloo and Petite Chez Scheme
; (this code relies on more conventional interpretation of R5RS)
; See define-struct.html in this directory for explanation.
;
; How to run this code
;
; This code is meant to work with the reference implementation
; of SRFI-9. Please fetch the reference implementation of SRFI-9
; from srfi.schemers.org and save it into a file srfi-9.scm
;
; Scheme48:
; $ scheme48
; > ,load srfi-9.scm
; > ,load def-struct1.scm
;
; SCM (5d6):
; $ scm -r5 -l srfi-9.scm -l def-struct1.scm
;
; Bigloo (2.4b):
; $ bigloo -hygien -i srfi-9.scm def-struct1.scm
;
; Petite Chez Scheme  6.0a (download from www.scheme.com):
; $ petite srfi-9.scm def-struct1.scm
;
; $Id: def-struct1.scm,v 1.1 2004/05/16 23:19:29 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 ...) . body)
     (build-maker name (field ...) (set!) () (body) ))))

; 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'
; a 'letrec-syntax' for the dispatcher macro 'name'
;
; make-record-type, record-constructor, record-predicate,
; record-accessor and record-modifier are defined in
; the reference implementation of SRFI-9.

(define-syntax build-finish
  (syntax-rules ()
    ((_ (body
	  (constructor constructor-tag ...)
	  predicate
	  (field-tag getter setter) ...)
       name literals rules)
      (let
	((type
	   (make-record-type 'name '(field-tag ...))))
	(letrec
	 ((constructor
	   (record-constructor type '(constructor-tag ...)))
	 (predicate
	   (record-predicate type))
	 (getter (record-accessor type 'field-tag)) ...
	 (setter (record-modifier type 'field-tag)) ...
	  )
	(letrec-syntax
	  ((name (syntax-rules literals . rules)))
	  . body))))))

; 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)
))