71 lines
2 KiB
Scheme
71 lines
2 KiB
Scheme
;;; 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)))))))
|