File: defenum.scm

package info (click to toggle)
scsh 0.5.1-2
  • links: PTS
  • area: non-free
  • in suites: potato, slink
  • size: 6,540 kB
  • ctags: 8,656
  • sloc: lisp: 39,346; ansic: 13,466; sh: 1,669; makefile: 624
file content (72 lines) | stat: -rw-r--r-- 2,921 bytes parent folder | download
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
; Copyright (c) 1993, 1994 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)))))))