guile-prescheme/prescheme/s48-defenum.scm

;;; Ported from Scheme 48 1.9.  See file COPYING for notices and license.
;;;
;;; Port Author: Andrew Whatson
;;;
;;; Original Authors: Richard Kelsey, Jonathan Rees, Mike Sperber
;;;
;;;  scheme48-1.9.2/scheme/rts/defenum.scm
;;;
;;; define-enumeration macro
;;;

(define-module (prescheme s48-defenum)
  #:export (define-enumeration
            enum
            enumerand->name
            name->enumerand))

(define (syntax-conc sob . syms)
  (datum->syntax sob (apply symbol-append
                            (syntax->datum sob)
                            syms)))

(define-syntax define-enumeration
  (lambda (x)
    (syntax-case x ()
      ((_ e-name (elems ...))
       (with-syntax ((e-elems (syntax-conc #'e-name '-enumeration))
                     (e-count (syntax-conc #'e-name '-count)))
         (let* ((elements #'(elems ...))
                (count (length elements))
                (indexes (iota count)))
           #`(begin
               (define e-elems #(elems ...))
               (define e-count #,count)
               (define-syntax e-name
                 (syntax-rules (components enum elems ...)
                   ((_ components) e-elems)
                   #,@(map (lambda (elem ix)
                             #`((_ enum #,elem) #,ix))
                           elements indexes))
                 ))))))))

(define-syntax components
  (syntax-rules (components)
    ((_ ?type)
     (?type components))))

(define-syntax enum
  (syntax-rules (enum)
    ((_ ?type ?enumerand)
     (?type enum ?enumerand))))

(define-syntax enumerand->name
  (syntax-rules ()
    ((enumerand->name ?enumerand ?type)
     (vector-ref (components ?type) ?enumerand))))

(define-syntax name->enumerand
  (syntax-rules ()
    ((name->enumerand ?name ?type)
     (lookup-enumerand (components ?type) ?name))))

(define (lookup-enumerand components name)
  (let ((len (vector-length components)))
    (let loop ((i 0))                   ;;vector-posq
      (if (>= i len)
          #f
          (if (eq? name (vector-ref components i))
              i
              (loop (+ i 1)))))))