;;; -*- Mode: Scheme -*-

;;;; Integer Enumeration Utility

;;; Copyright (c) 2005-2009, Taylor R. Campbell
;;;
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;;
;;; * Redistributions of source code must retain the above copyright
;;;   notice, this list of conditions and the following disclaimer.
;;;
;;; * Redistributions in binary form must reproduce the above copyright
;;;   notice, this list of conditions and the following disclaimer in
;;;   the documentation and/or other materials provided with the
;;;   distribution.
;;;
;;; * Neither the names of the authors nor the names of contributors
;;;   may be used to endorse or promote products derived from this
;;;   software without specific prior written permission.
;;;
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

;;; This is compatible with Scheme48's ENUMERATED and ENUM-CASE
;;; structures.

(declare (usual-integrations))

(define-syntax define-enumeration
  (rsc-macro-transformer
   (lambda (form closing-environment)
     (define (close form) (close-syntax form closing-environment))
     (if (not (syntax-match? '(IDENTIFIER (+ IDENTIFIER))
                             (cdr form)))
         (ill-formed-syntax form)
         (let ((name (cadr form))
               (enumerands
                (list->vector (map identifier->symbol (caddr form)))))
           (let ((vector-name (symbol-append (identifier->symbol name)
                                             '- 'ENUMERATION))
                 (count-name (symbol-append (identifier->symbol name)
                                            '- 'COUNT))
                 (count (vector-length enumerands)))
             (capture-syntactic-environment
              (lambda (environment)
                `(,(close 'BEGIN)
                   (,(close 'DEFINE-SYNTAX) ,name
                     ,(make-syntactic-closure closing-environment '()
                        (make-enumeration-transformer name
                                                      enumerands)))
                   (,(close 'DEFINE) ,vector-name ',enumerands)
                   (,(close 'DEFINE) ,count-name ,count))))))))))

(define (make-enumeration-transformer enumeration enumerands)
  `(SC-MACRO-TRANSFORMER
    (LET ((ENUMERANDS ',enumerands))
      (LAMBDA (FORM ENVIRONMENT)
        (COND ((SYNTAX-MATCH? '('ENUMERANDS) (CDR FORM))
               `',ENUMERANDS)
              ((SYNTAX-MATCH? '('ENUMERAND IDENTIFIER) (CDR FORM))
               (LET ((NAME (IDENTIFIER->SYMBOL (CADDR FORM))))
                 (OR (VECTOR-FIND-NEXT-ELEMENT ENUMERANDS NAME)
                     (CALL-WITH-SYNTAX-ERROR-PROCEDURE
                      (LAMBDA (SYNTAX-ERROR)
                        (SYNTAX-ERROR "No such enumerand:"
                                      (LIST 'ENUM
                                            ',enumeration
                                            NAME)))))))
              (ELSE (ILL-FORMED-SYNTAX FORM)))))))

(define-syntax enum
  (sc-macro-transformer
   (lambda (form environment)
     (if (syntax-match? '(IDENTIFIER IDENTIFIER) (cdr form))
         (let ((enumeration (close-syntax (cadr form) environment))
               (enumerand (caddr form)))
           `(,enumeration ENUMERAND ,enumerand))
         (ill-formed-syntax form)))))

(define-syntax enumerand->name
  (sc-macro-transformer
   (lambda (form environment)
     (if (syntax-match? '(EXPRESSION IDENTIFIER) (cdr form))
         (let ((enumerand-index (cadr form))
               (enumeration (close-syntax (caddr form) environment)))
           `(VECTOR-REF (,enumeration ENUMERANDS) ,enumerand-index))
         (ill-formed-syntax form)))))

(define-syntax name->enumerand
  (sc-macro-transformer
   (lambda (form environment)
     (if (syntax-match? '(EXPRESSION IDENTIFIER) (cdr form))
         (let ((enumerand-name (cadr form))
               (enumeration (close-syntax (caddr form) environment)))
           `(LET ((ENUMERAND-NAME ,enumerand-name))
              (OR (VECTOR-FIND-NEXT-ELEMENT (,enumeration ENUMERANDS)
                                            ENUMERAND-NAME)
                  (ERROR "No such enumerand:"
                         ENUMERAND-NAME
                         ',enumeration))))
         (ill-formed-syntax form)))))

(define-syntax enum-case
  (syntax-rules (ELSE)

    ((ENUM-CASE enumeration (subform ...)
       clause
       ...)
     (LET ((ENUMERAND-INDEX (subform ...)))
       (ENUM-CASE enumeration ENUMERAND-INDEX
         clause
         ...)))

    ((ENUM-CASE enumeration enumerand-index
       (ELSE body0 body1 ...))
     ;; Prohibit definitions in the body, even if this is at the top
     ;; level.  This is consistent with R5RS's COND & CASE.
     (IF #T (BEGIN body0 body1 ...)))

    ((ENUM-CASE enumeration enumerand-index
       ((name ...) body0 body1 ...)
       clause
       ...)
     (IF (ENUM-CASE:TEST enumeration enumerand-index name ...)
         (BEGIN body0 body1 ...)
         (ENUM-CASE enumeration enumerand-index
           clause
           ...)))

    ((ENUM-CASE enumeration enumerand-index)
     UNSPECIFIC)))

;;; This is a painful kludge due to MIT Scheme's enforcement of a
;;; ridiculous restriction imposed on SYNTAX-RULES templates by R5RS
;;; whereby a pattern variable can occur in a template only with the
;;; same dimension as the pattern in which it occurred, i.e. the
;;; number of ellipses must match exactly: even if there is no
;;; ambiguity, they cannot be varied, such as in the above rule for
;;; ENUM-CASE where I should like to write
;;;
;;;   (IF (OR (FIX:= enumerand-index (ENUM enumeration name))
;;;           ...)
;;;       <consequent>
;;;       <alternative>).

(define-syntax enum-case:test
  (sc-macro-transformer
   (lambda (form environment)
     (let ((enumeration (close-syntax (cadr form) environment))
           (enumeration-index (close-syntax (caddr form) environment))
           (case-enumerands (cdddr form)))
       `(OR ,@(map (lambda (name)
                     `(FIX:= ,enumeration-index
                             (ENUM ,enumeration ,name)))
                   case-enumerands))))))

;;; Edwin Variables:
;;; Eval: (scheme-indent-method 'ENUM-CASE 2)
;;; End: