; Copyright (c) 1993-2008 by Richard Kelsey and Jonathan Rees. See file COPYING.


; define-enumeration macro

(define-syntax define-enumeration
  (make-transformer/free-identifier=?
   (lambda (x free-identifier=?)
     (let ((form (syntax-e x))
	   (here (code-quote here)))
       (define (rename id)
	 (datum->syntax here id))
       (let ((name (cadr form))
	     (components (list->vector (syntax-e (caddr form))))
	     (conc (lambda things
		     (string->symbol (apply string-append
					    (map (lambda (thing)
						   (cond
						    ((symbol? thing)
						     (symbol->string thing))
						    ((identifier? thing)
						     (symbol->string (syntax->datum thing)))
						    (else
						     thing)))
						 things)))))
	     (%define (rename 'define))
	     (%define-syntax (rename 'define-syntax))
	     (%begin (rename 'begin))
	     (%quote (rename 'quote))
	     (%cons (rename 'cons))
	     (%let (rename 'let))
	     (%lambda (rename 'lambda))
	     (%cond (rename 'cond))
	     (%if (rename 'if))
	     (%< (rename '<))
	     (%vector-ref (rename 'vector-ref))
	     (%+ (rename '+))
	     (%eq? (rename 'eq?))
	     (%else (rename 'else))
	     (%cadr (rename 'cadr))
	     (%caddr (rename 'caddr))
	     (%stx-car (rename 'stx-car))
	     (%stx-cadr (rename 'stx-cadr))
	     (%stx-cdr (rename 'stx-cdr))
	     (%datum->syntax (rename 'datum->syntax))
	     (%syntax->datum (rename 'syntax->datum))
	     (%components (rename 'components))
	     (%enum (rename 'enum))
	     (%code-quote (rename 'code-quote))
	     (%syntax-violation (rename 'syntax-violation))
	     (%make-transformer/free-identifier=? (rename 'make-transformer/free-identifier=?)))
	 (let ((e-name (datum->syntax name (conc name '- 'enumeration)))
	       (count-name (datum->syntax name (conc name '- 'count)))
	       (count (vector-length components)))
	   (datum->syntax
	    here
	    `(,%begin
	      (,%define-syntax 
	       ,name
	       (,%let ((components (,%quote ,components)))
		      (,%make-transformer/free-identifier=?
		       (,%lambda (x free-identifier=?)
				 (,%let ((key (,%stx-cadr x))
					 (here (,%stx-car x)))
					(,%cond ((free-identifier=? key (,%code-quote ,%components))
						 (,%datum->syntax here (,%quote ,e-name)))
						((free-identifier=? key (,%code-quote ,%enum))
						 (,%let ((which (,%syntax->datum (,%stx-cadr (,%stx-cdr x)))))
							(,%let loop ((i 0)) ;vector-posq
							       (,%if (,%< i ,count)
								     (,%if (,%eq? which (,%vector-ref components i))
									   i
									   (loop (,%+ i 1)))
								     (,%syntax-violation 'enum "unknown enumerand name"
											 x which)))))
						(,%else
						 (,%syntax-violation 'enum "unknown command argument"
								     x key))))))))
	      (,%define ,e-name (,%quote ,components))
	      (,%define ,count-name ,count)))))))))

(define-syntax components
  (lambda (x) 
    (datum->syntax
     (stx-car x)
     `(,(stx-cadr x) components))))

(define-syntax enum
  (lambda (x) 
    (let* ((form (syntax-e x))
	   (here (car form)))
      (if (not (= (length form) 3))
	  (syntax-violation 'enum "invalid syntax" x)
	  (datum->syntax
	   here
	   `(,(cadr form) enum ,(caddr form)))))))

