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
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
|
; Copyright (c) 1993-2008 by Richard Kelsey and Jonathan Rees. See file COPYING.
; DEFINE-ENUMERATION macro hacked to use external (C enumeration) names
; instead of integers.
;(define-external-enumeration bing
; ((foo "BAR")
; baz))
; =>
;(define-syntax bing ...)
;(define bing/foo (make-external-constant 'bing 'foo "BAR"))
;(define bing/baz (make-external-constant 'bing 'baz "BAZ"))
;
;(enum bing foo) => bing/foo
(define-record-type external-constant :external-constant
(make-external-constant enum-name name c-string)
external-constant?
(enum-name external-constant-enum-name)
(name external-constant-name)
(c-string external-constant-c-string))
(define-record-discloser :external-constant
(lambda (external-const)
(list 'enum
(external-constant-enum-name external-const)
(external-constant-name external-const))))
(define-syntax define-external-enumeration
(lambda (form rename compare)
(let* ((name (cadr form))
(symbol->upcase-string
(lambda (s)
(list->string (map (lambda (c)
(if (char=? c #\-)
#\_
(char-upcase c)))
(string->list (symbol->string s))))))
(constant
(lambda (sym string)
`(,(rename 'make-external-constant) ',name ',sym ,string)))
(conc (lambda things
(string->symbol (apply string-append
(map (lambda (thing)
(if (symbol? thing)
(symbol->string thing)
thing))
things)))))
(var-name
(lambda (sym)
(conc name "/" sym)))
(components
(list->vector
(map (lambda (stuff)
(if (pair? stuff)
(cons (car stuff)
(var-name (car stuff)))
(cons stuff
(var-name stuff))))
(caddr form))))
(%define (rename 'define))
(%define-syntax (rename 'define-syntax))
(%begin (rename 'begin))
(%quote (rename 'quote))
(%make-external-constant (rename 'make-external-constant))
(e-name (conc name '- 'enumeration))
(count (vector-length components)))
`(,%begin
(,%define-syntax ,name
(let ((components ',components))
(lambda (e r c)
(let ((key (cadr e)))
(cond ((c key 'enum)
(let ((which (caddr e)))
(let loop ((i 0)) ;vector-posq
(if (< i ,count)
(if (c which (car (vector-ref components i)))
(r (cdr (vector-ref components i)))
(loop (+ i 1)))
;; (syntax-error "unknown enumerand name"
;; `(,(cadr e) ,(car e) ,(caddr e)))
e))))
(else e))))))
(,%define ,(conc name '- 'count) ,count)
. ,(map (lambda (stuff)
(if (pair? stuff)
`(,%define ,(var-name (car stuff))
(,%make-external-constant ',name
',(car stuff)
,(cadr stuff)))
`(,%define ,(var-name stuff)
(,%make-external-constant ',name
',stuff
,(symbol->upcase-string stuff)))))
(caddr form)))))
(begin define define-syntax quote external make-external-constant))
|
