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
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
|
;;; -*-Scheme-*-
(define type-name #f)
(define classes '())
(define callbacks '())
(define primitives '())
(define converters '())
(define f)
(define (check-string proc x name)
(if (not (memq (type x) '(symbol string)))
(error proc (format #f "~s must be string or symbol" name))))
(define (define-widget-type name include)
(if type-name
(error 'define-widget-type "must be called once"))
(check-string 'define-widget-type name 'name)
(if (pair? include)
(for-each
(lambda (i) (check-string 'define-widget-type i 'include)) include)
(check-string 'define-widget-type include 'include))
(set! type-name name)
(format f "#include \"../xt.h\"~%")
(case widget-set
(motif
(format f "#include <Xm/Xm.h>~%")))
(if (and (not (eqv? include "")) (not (null? include)))
(begin
(define dir)
(case widget-set
(motif
(set! dir "Xm"))
(xaw
(set! dir "X11/Xaw")))
(if (pair? include)
(for-each
(lambda (i)
(if (char=? (string-ref (format #f "~a" i) 0) #\<)
(format f "#include ~a~%" i)
(format f "#include <~a/~a>~%" dir i)))
include)
(if (char=? (string-ref (format #f "~a" include) 0) #\<)
(format f "#include ~a~%" include)
(format f "#include <~a/~a>~%" dir include)))))
(newline f))
(define (prolog code)
(if (not type-name)
(error 'prolog "must define a widget-type first"))
(check-string 'prolog code 'code)
(display code f)
(format f "~%~%"))
(define (define-callback class name has-arg?)
(check-string 'define-callback class 'class)
(check-string 'define-callback name 'name)
(if (not (boolean? has-arg?))
(error 'define-callback "has-arg? must be boolean"))
(set! callbacks (cons (list class name has-arg?) callbacks)))
(define (c->scheme name body)
(check-string 'c->scheme name 'name)
(define c-name (scheme-to-c-name name))
(string-set! c-name 0 #\S)
(format f "static Object ~a (XtArgVal x) {~%" c-name)
(display body f)
(format f "~%}~%~%")
(define s
(format #f " Define_Converter_To_Scheme (\"~a\", ~a);~%"
name c-name))
(set! converters (cons s converters)))
(define (scheme->c name body)
(check-string 'scheme->c name 'name)
(define c-name (scheme-to-c-name name))
(string-set! c-name 0 #\C)
(format f "static XtArgVal ~a (Object x) {~%" c-name)
(display body f)
(format f "~%}~%~%")
(define s
(format #f " Define_Converter_To_C (\"~a\", ~a);~%"
name c-name))
(set! converters (cons s converters)))
(define (define-primitive scheme-name args body)
(check-string 'define-primitive scheme-name 'scheme-name)
(if (not (pair? args))
(error 'define-primitive "args must be a list"))
(define c-name (scheme-to-c-name scheme-name))
(format f "static Object ~a (" c-name)
(do ((a args a)) ((null? a))
(display "Object " f)
(display (car a) f)
(set! a (cdr a))
(if (not (null? a)) (display ", " f)))
(display ") {" f)
(newline f)
(display body f)
(format f "~%}~%~%")
(define s
(format #f " Define_Primitive (~a, \"~a\", ~a, ~a, EVAL);~%"
c-name scheme-name (length args) (length args)))
(set! primitives (cons s primitives)))
;;; [missing conversion from -> to "to"]
(define (scheme-to-c-name s)
(if (symbol? s)
(set! s (symbol->string s)))
(define len (string-length s))
(if (char=? (string-ref s (1- len)) #\?)
(string-set! s (1- len) #\p))
(if (char=? (string-ref s (1- len)) #\!)
(set! len (1- len)))
(let loop ((ret "P") (i 0))
(if (>= i len)
ret
(define next
(do ((j i (1+ j)))
((or (= j len) (memq (string-ref s j) '(#\- #\:))) j)))
(loop (format #f "~a_~a~a" ret (char-upcase (string-ref s i))
(substring s (1+ i) next)) (1+ next)))))
(define (define-widget-class name class . sub-resources)
(check-string 'define-widget-class name 'name)
(check-string 'define-widget-class class 'class)
(set! classes (cons (list name class sub-resources) classes)))
(define (feature-name fn)
(let ((i (substring? ".d" fn)))
(display "filename: ") (display fn) (newline)
(if (not i)
(error 'mkwidget "bad filename suffix in ~a (expected .d)" fn))
(string->symbol (substring fn 0 i))))
(define args (command-line-args))
(if (not (= (length args) 3))
(error 'mkwidget "expected three arguments"))
(define widget-set (string->symbol (caddr args)))
(set! f (open-output-file (cadr args)))
(load (car args))
(if (not type-name)
(error 'mkwidget "no widget type defined"))
(format f "void elk_init_~a_~a () {~%" widget-set type-name)
(if (not (null? classes))
(format f " XtResourceList r = 0;~%"))
(do ((c classes (cdr c))) ((null? c))
(define cl (car c))
(define res (caddr cl))
(if (not (null? res))
(begin
(format f
" r = (XtResourceList)XtMalloc (~a * sizeof (XtResource));~%"
(length res))
(do ((r res (cdr r)) (num 0 (1+ num))) ((null? r))
(define x (car r))
(if (not (= (length x) 3))
(error 'mkwidget "bad sub-resource declaration"))
(for-each
(lambda (r)
(if (not (memq (type r) '(symbol string)))
(error 'mkwidget "bad type in sub-resource declaration")))
x)
(format f " r[~a].resource_name = \"~a\";~%" num (car x))
(format f " r[~a].resource_class = \"~a\";~%" num (cadr x))
(format f " r[~a].resource_type = \"~a\";~%" num (caddr x)))))
(format f " Define_Class (\"~a\", ~a, r, ~a);~%" (car cl) (cadr cl)
(length res)))
(do ((c callbacks (cdr c))) ((null? c))
(define cb (car c))
(format f " Define_Callback (\"~a\", \"~a\", ~a);~%" (car cb) (cadr cb)
(if (caddr cb) 1 0)))
(for-each (lambda (x) (display x f)) primitives)
(for-each (lambda (x) (display x f)) converters)
(format f " P_Provide(Intern(\"~a:~a\"));~%" widget-set
(feature-name (car args)))
(format f "}~%")
|
