;;;- ---begin define-record.scm---
;;;
;;; DEFINE-RECORD and VARIANT-CASE macros for Scheme 48
;;;
;;; Brent Benson (bwb@icad.com)
;;;
;;; The macros are all bottled up inside of a package
;;; definition in order to make it easy to load.  The
;;; correct incantation (assuming that this file is
;;; called define-record.scm) is
;;;
;;; > ,config ,load define-record.scm
;;; > ,open define-record
;;;

(define-structure define-record
  (export (define-record :syntax)
	  (variant-case :syntax))
  (open scheme define-record-types)
  (begin

    ; (define-record foo (bar baz))
    ; =>
    ; (define-record-type foo :foo
    ;   (make-foo bar baz)
    ;   foo?
    ;   (bar foo->bar)
    ;   (baz foo->baz))

    (define-syntax define-record
      (lambda (exp rename compare)
	(let* ((name-symbol (cadr exp))
	       (name-string (symbol->string name-symbol))
	       (type-symbol (string->symbol (string-append ":" name-string)))
	       (const-symbol (string->symbol 
			      (string-append "make-" name-string)))
	       (pred-symbol (string->symbol (string-append name-string "?")))
	       (slot-symbols (caddr exp))
	       (slot-descrs (map (lambda (symbol)
				   (list 
				    symbol
				    (string->symbol 
				     (string-append name-string 
						    "->" 
						    (symbol->string symbol)))))
				 slot-symbols)))
	  `(,(rename 'define-record-type) ,name-symbol ,type-symbol
	     (,const-symbol ,@slot-symbols)
	     ,pred-symbol
	     ,@slot-descrs))))

    ; (variant-case expr
    ;   (foo (bar baz) (list 'foo bar baz))
    ;   (bloo () (list 'bloo))
    ;   (else (list 'dont-know)))
    ; =>
    ; (let ((%g1 expr))
    ;   (cond
    ;    ((foo? %g1) (let ((bar (foo->bar %g1)) 
    ;                      (baz (foo->baz %g1))) 
    ;	  	   (list 'foo bar baz)))
    ;    ((bloo? %g1) (let () (list 'bloo)))
    ;    (else (list 'dont-know))))

    (define-syntax variant-case
      (lambda (exp rename compare)
    
	(define (vc-clause->cond-clause clause test-var)
	  (let* ((name-symbol (car clause))
		 (name-string (symbol->string name-symbol))
		 (pred-symbol (string->symbol (string-append name-string "?")))
		 (field-symbols (cadr clause))
		 (field-letters (map (lambda (symbol)
				       `(,symbol
					 (,(string->symbol 
					    (string-append 
					     name-string 
					     "->" 
					     (symbol->string symbol)))
					  ,test-var)))
				     field-symbols))
		 (exprs (cddr clause)))
	    `((,pred-symbol ,test-var)
	      (let ,field-letters ,@exprs))))

	(define gensym
	  (let ((counter 0))
	    (lambda ()
	      (set! counter (+ counter 1))
	      (string->symbol (string-append "%g" (number->string counter))))))

	(let* ((the-expr (cadr exp))
	       (fresh-symbol (gensym))
	       (clauses (cddr exp))
	       (cond-clauses (map (lambda (clause)
				    (if (eq? (car clause) 'else)
					clause
					(vc-clause->cond-clause clause 
								fresh-symbol)))
				  clauses)))
	  `(,(rename 'let) ((,fresh-symbol ,the-expr))
			   (,(rename 'cond)
			    ,@cond-clauses)))))))

;;; - ---end define-record.scm---