scsh-0.6/scheme/rts/defenum.scm

73 lines
2.9 KiB
Scheme
Raw Normal View History

1999-09-14 08:45:02 -04:00
; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
; define-enumeration macro
(define-syntax define-enumeration
(lambda (form rename compare)
(let ((name (cadr form))
(components (list->vector (caddr form)))
(conc (lambda things
(string->symbol (apply string-append
(map (lambda (thing)
(if (symbol? thing)
(symbol->string thing)
thing))
things)))))
(%define (rename 'define))
(%define-syntax (rename 'define-syntax))
(%begin (rename 'begin))
(%quote (rename 'quote)))
(let ((e-name (conc name '- 'enumeration))
(count (vector-length components)))
`(,%begin (,%define-syntax ,name
(cons (let ((components ',components))
(lambda (e r c)
(let ((key (cadr e)))
(cond ((c key 'components)
(r ',e-name))
((c key 'enum)
(let ((which (caddr e)))
(let loop ((i 0)) ;vector-posq
(if (< i ,count)
(if (c which (vector-ref components i))
i
(loop (+ i 1)))
;; (syntax-error "unknown enumerand name"
;; `(,(cadr e) ,(car e) ,(caddr e)))
e))))
(else e)))))
'(,e-name))) ;Auxiliary binding
(,%define ,e-name ',components)
(,%define ,(conc name '- 'count) ,count)))))
(begin define define-syntax quote))
(define-syntax components
(cons (lambda (e r c) `(,(cadr e) components))
'()))
(define-syntax enum
(cons (lambda (e r c) `(,(cadr e) enum ,(caddr e)))
'()))
(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)))))))