;;; This implementation of define-record and variant-case
;;; was developed by John Lacey.  This version uses the
;;; new version of define-syntax as described in the following
;;; technical reports:
;;;
;;; "Syntactic Abstraction in Scheme", Robert Hieb, R. Kent Dybvig,
;;;      and Carl Bruggeman, TR 355.
;;; "Writing Hygienic Macros in Scheme with Syntax-Case", R. Kent Dybvig,
;;;      TR 356.
;;; 
;;; The code for define-syntax, as well as PostScript versions of the above
;;; technical reports, can be ftp'ed from
;;;
;;;     cs.indiana.edu:pub/scheme/syntax-case/
;;;
;;; Compressed versions of the reports are available in pub/techreports.
;;; A compressed tar file with the source for define-syntax is in pub/scheme.

(define construct-name          ; From TR 356
  (lambda (template-id . args)
    (implicit-identifier
      template-id
      (string->symbol
	(apply string-append
	  (map (lambda (x)
		 (if (string? x)
		   x
		   (symbol->string (syntax-object->datum x))))
	    args))))))

(define-syntax define-record
  (lambda (x)
    (syntax-case x ()
      ((_ name (field0 ...))
       (with-syntax
	 ((constructor (construct-name (syntax name) "make-" (syntax name)))
	  (predicate (construct-name (syntax name) (syntax name) "?"))
	  ((reader ...)
	   (map (lambda (field)
		  (construct-name (syntax name) (syntax name) "->" field))
	     (syntax (field0 ...))))
	  (count (length (syntax (name field0 ...)))))
	 (with-syntax
	   (((index ...)
	     (let f ((i 1))
	       (if (= i (syntax-object->datum (syntax count)))
		 '()
		 (cons i (f (1+ i)))))))
	   (syntax
	     (begin
	       (define constructor
		 (lambda (field0 ...)
		   (vector 'name field0 ...)))
	       (define predicate
		 (lambda (object)
		   (and (vector? object)
		     (= (vector-length object) count)
		     (eq? (vector-ref object 0) 'name))))
	       (define reader
		 (lambda (object)
		   (vector-ref object index)))
	       ...))))))))

(define-syntax variant-case
  (lambda (x)
    (syntax-case x (else)
      ((_ var) (syntax (error 'variant-case "no clause matches ~s" var)))
      ((_ var (else exp1 exp2 ...)) (syntax (begin exp1 exp2 ...)))
      ((_ exp clause ...)
       (not (identifier? (syntax exp)))
       (syntax (let ((var exp)) (_ var clause ...))))
      ((_ var (name (field ...) exp1 exp2 ...) clause ...)
       (with-syntax
	 ((predicate (construct-name (syntax name) (syntax name) "?"))
	  ((reader ...)
	   (map (lambda (fld)
		  (construct-name (syntax name) (syntax name) "->" fld))
	     (syntax (field ...)))))
	 (syntax
	   (if (predicate var)
	     (let ((field (reader var)) ...) exp1 exp2 ...)
	     (_ var clause ...))))))))