96 lines
3.5 KiB
Scheme
96 lines
3.5 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))
|
||
|
|
|
||
|
|
;; TODO: port define-enumeration macro
|
||
|
|
(define-syntax define-enumeration (const #f))
|
||
|
|
(define-syntax enum (const #f))
|
||
|
|
(define-syntax name->enumerand (const #f))
|
||
|
|
(define-syntax enumerand->name (const #f))
|
||
|
|
|
||
|
|
#|
|
||
|
|
(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-violation 'enum "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)
|
||
|
|
(if (not (= (length e) 3))
|
||
|
|
'(syntax-violation 'enum "wrong number of arguments for enum" e)
|
||
|
|
`(,(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)))))))
|
||
|
|
|#
|