gaba.scm 18.9 KB
Newer Older
Niels Möller's avatar
Niels Möller committed
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
;; gaba.scm
;;
;; Run with
;;   $ scsh -e main -l scsh-compat.scm -l compiler.scm -s gaba.scm
;;   $ guile -e main -l guile-compat.scm -l compiler.scm -s gaba.scm

;; Reads a C source file on stdin. Comments of the form
;;
;; /*
;; GABA:
;;    expression
;; */
;;
;; are treated specially, and C code for the class is written to
;; stdout. Typically, the code is saved to a file and included by the
;; C source file in question.

;; FIXME: Perhaps the files should somehow be fed through the
;; preprocessor first?

(define (werror f . args)
  (display (apply format #f f args) (current-error-port)))

(define (string-prefix? prefix s)
  (let ((l (string-length prefix)))
    (and (<= l (string-length s))
	 (string=? prefix (substring s 0 l)))))

(define (read-expression p)
  (let ((line (read-line)))
    ; (werror "read line: '~s'\n" (if (eof-object? line) "<EOF>" line))
    (cond ((eof-object? line) line)
	  ((p line) (read))
	  (else (read-expression p)))))

(define (get key alist select)
  (cond ((assq key alist) => select)
	(else #f)))

(define (identity x) x)

(define (filter p list)
  (cond ((null? list) list)
	((p (car list)) (cons (car list)
			      (filter p (cdr list))))
	(else (filter p (cdr list)))))

(define (list-prefix l n)
  (if (zero? n) '()
      (cons (car l) (list-prefix (cdr l) (- n 1)))))

(define (atom? o) (not (list? o)))

54
55
56
57
58
59
60
61
62
63
(define-syntax when
  (syntax-rules ()
    ((when <cond> . <body>)
     (if <cond> (begin . <body>)))))

(define-syntax unless
  (syntax-rules ()
    ((unless <cond> . <body>)
     (if (not <cond>) (begin . <body>)))))
  
Niels Möller's avatar
Niels Möller committed
64
65
66
;; Variables are describes as lists (name . type)
;; Known types (and corresponding C declarations) are
;;
67
68
69
70
;; (string)                     struct lsh_string *name
;; (object class)               struct class *name
;; (bignum)                     mpz_t name
;; (simple c-type)              c-type
Niels Möller's avatar
Niels Möller committed
71
;; (special c-type mark-fn free-fn)
72
;; (indirect-special c-type mark-fn free-fn)
Niels Möller's avatar
Niels Möller committed
73
74
75
;;
;; (struct tag)
;;
76
77
78
79
80
;; (array type size)            type name[size]
;;
;; size-field, when present, is the name of a field that holds
;; the current size of variable size objects.
;;
Niels Möller's avatar
Niels Möller committed
81
82
83
;; Variable size array (must be last) */
;; (var-array type size-field)  type name[1]
;;
84
85
86
;; FIXME: Split into var-pointer and var-space?
;; (pointer type [size-field])  type *name
;; (space type [size-field])    Like pointer, but should be freed
Niels Möller's avatar
Niels Möller committed
87
88
89
90
91
92
93
94
95
96
;;
;; (function type . arg-types) type name(arg-types)
;;
;; NOTE: For function types, the arguments are represented simply as
;; strings or lists containing C declarations; they do not use the
;; type syntax.
;;
;; (method type args)
;; is transformed into (pointer (function type self-arg args)) before
;; processing,
97
98
99
;;
;; (const . type)               Like type, but declared const.
;;                              Primarily used for const string.
Niels Möller's avatar
Niels Möller committed
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
;;; C code generation

;; A portion of C code is represented as a either
;;
;; an atom (string, symbol or number), or
;;
;; procedure taking a single INDENT argument, sending
;; output to current-output-stream, or
;;
;; a list, whose elements are displayed indented one more level.
;;
;; It would be cleaner to let indent be a dynamically bound variable.

(define (out level . args)
  (for-each (lambda (o)
	      (cond ((procedure? o) (o level))
		    ((list? o) (apply out (+ 1 level) o))
		    (else (display o))))
	    args))

; This isn't very optimal
(define (indent i)
  (display "\n")
  (let loop ((count 0))
    (when (< count i)
	  (display "  ")
	  (loop (+ 1 count)))))
	     
(define (c-append . args)
  (lambda (i) (apply out i args)))

(define (c-string name)
  ;; FIXME: Could do quoting better
  (c-append "\"" name "\""))

(define (c-address expr)
  (c-append "&(" expr ")"))

(define (c-list separator list)
      (if (null? list) '()
	  (cons (car list)
		(map (lambda (o)
		       (c-append separator o))
		     (cdr list)))))

(define (c-block statements)
  (c-append "{" (map (lambda (s) (c-append indent s ";"))
		     statements)
	    indent "}"))

(define (c-block* . statements) (c-block statements))

(define (c-initializer expressions)
  (c-append "{" (map (lambda (s) (c-append indent s ","))
		     expressions)
	    indent "}"))

(define (c-initializer* . expressions) (c-initializer expressions))

Niels Möller's avatar
Niels Möller committed
160
(define (c-prototype return name args)
161
162
  (c-append return indent name
	    "("
Niels Möller's avatar
Niels Möller committed
163
	    (if (null? args ) "void"
164
		(c-list (c-append "," indent) args))
165
166
	    ")"))

Niels Möller's avatar
Niels Möller committed
167
168
169
(define (c-prototype* return name . args)
  (c-prototype return name args))

170
171
172
173
(define (c-for var range body)
  (c-append "for(" var "=0; "
	    var "<" range "; "
	    var "++)"
Niels Möller's avatar
Niels Möller committed
174
	    (list indent body)))
175

Niels Möller's avatar
Niels Möller committed
176
(define (c-call f args)
177
178
  (c-append f "(" (c-list (c-append "," indent) args) ")"))

Niels Möller's avatar
Niels Möller committed
179
180
(define (c-call* f . args) (c-call f args))

181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
(define (c-declare var)
  (define (c-decl-1 type expr)
    (case (car type)
      ((simple special indirect-special)
       (c-append (cadr type) " " expr))
      ((string)
       (c-append "struct lsh_string *" expr))
      ((object)
       (c-append "struct " (cadr type) " *" expr))
      ((struct)
       (c-append "struct " (cadr type) " " expr))
      ((bignum)
       (c-append "mpz_t " expr))
      ((pointer space)
       (c-decl-1 (cadr type) 
		 (c-append "(*(" expr "))")))
      ((array)
       (c-decl-1 (cadr type)
		 (c-append "((" expr ")[" (caddr type) "])")))
      ((var-array)
       (c-decl-1 (cadr type)
		 (c-append "((" expr ")[1])")))
      ((function)
       (c-decl-1 (cadr type) 
		 (c-append expr "(" (c-list "," (cddr type)) ")")))
      ((const)
Niels Möller's avatar
Niels Möller committed
207
       (c-append "const " (c-decl-1 (cdr type) expr)))
208
209
210
211
212
213
214
215
      (else (error "c-decl: Invalid type " type))))
  (c-decl-1 (var-type var) (var-name var)))

(define (c-struct name vars)
  (c-append "struct " name indent
	    (c-block (map c-declare vars))
	    ";" indent))

Niels Möller's avatar
Niels Möller committed
216
217
218
219

(define var-name car)
(define var-type cdr)

220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
; New version
(define (make-instance-struct name super vars)
  (c-struct name (cons `(super struct ,(or super "lsh_object"))
		       vars)))

; For counter variables
(define make-var
  (let ((*count* 0))
    (lambda ()
      (set! *count* (+ 1 *count*))
      (c-append "k" *count*))))

; Invokes f on type and expression for each variable.
(define (map-variables f vars pointer)
  (filter identity (map (lambda (var)
			  (f (var-type var)
			     (c-append pointer "->" (var-name var))))
			vars)))

(define (make-marker type expr)
  (case (car type)
    ((string simple function bignum) #f)
Niels Möller's avatar
Niels Möller committed
242
243
244
245
    ((object) (c-call* "mark" (c-append "(struct lsh_object *) " expr)))
    ((struct) (c-call* (c-append (cadr type) "_mark")
		       (c-address expr)
		       "mark"))
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
    ((pointer space)
     (if (null? (cddr type))
	 (make-marker (cadr type)
		      (c-append "*(" expr ")"))
	 ;; The optional argument should be the name of
	 ;; an instance variable holding the length of
	 ;; the area pointed to.
	 (let* ((counter (make-var))
		(mark-k (make-marker (cadr type)
				     (c-append "(" expr ")[" counter "]"))))
	   (and mark-k
		(c-block* (c-declare `( ,counter simple unsigned))
			  (c-for counter (c-append "i->" (caddr type))
				 mark-k))))))
    ((special)
     (let ((mark-fn (caddr type)))
Niels Möller's avatar
Niels Möller committed
262
       (and mark-fn (c-call* mark-fn expr "mark"))))
263
264
265
      
    ((indirect-special)
     (let ((mark-fn (caddr type)))
Niels Möller's avatar
Niels Möller committed
266
267
268
       (and mark-fn (c-call* mark-fn
			     (c-address expr)
			     "mark"))))
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
    ((array)
     (let* ((counter (make-var))
	    (mark-k (make-marker (cadr type)
				 (c-append "(" expr ")[" counter "]"))))
       (and mark-k
	    (c-block* (c-declare `( ,counter simple unsigned))
		      (c-for counter (caddr type)
			     mark-k)))))
    ((var-array)
     (let* ((counter (make-var))
	    (mark-k (make-marker (cadr type)
				 (c-append "(" expr ")[" counter "]"))))
       (and mark-k
	    (c-block* (c-declare `( ,counter simple unsigned))
		      (c-for counter (c-append "i->" (caddr type))
			     mark-k)))))
    ((const) (make-marker (cdr type) expr))
    (else (error "make-marker: Invalid type " type))))

(define (make-mark-function name vars)
  (let ((markers (map-variables make-marker vars "i")))
    (and (not (null? markers))
Niels Möller's avatar
Niels Möller committed
291
292
293
	 (c-append (c-prototype* "static void" (c-append "do_" name "_mark")
				 "struct lsh_object *o"
				 "void (*mark)(struct lsh_object *o)")
294
295
		   indent
		   (c-block (cons (c-append "struct " name
Niels Möller's avatar
Niels Möller committed
296
					    " *i = (struct " name " *) o")
297
298
299
300
301
302
				  markers))
		   indent))))

(define (make-freer type expr)
  (case (car type)
    ((object simple function pointer) #f)
Niels Möller's avatar
Niels Möller committed
303
304
305
306
307
    ((struct) (c-call* (c-append (cadr type) "_free") (c-address expr)))
    ((string) (c-call* "lsh_string_free" expr))
    ((bignum) (c-call* "mpz_clear" expr))
    ((space) (c-call* "lsh_space_free" expr))
    ((special) (c-call* (cadddr type) expr))
308
309
    ((indirect-special)
     (let ((free (cadddr type)))
Niels Möller's avatar
Niels Möller committed
310
       (and free (c-call* free (c-address expr)))))
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
    ((array)
     (let* ((counter (make-var))
	    (free-k (make-freer (cadr type)
				(c-append "(" expr ")[" counter "]"))))
       (and free-k
	    (c-block* (c-declare `( ,counter simple unsigned))
		      (c-for counter (caddr type)
			     free-k)))))

    ((var-array)
     (let* ((counter (make-var))
	    (free-k (make-freer (cadr type)
				(c-append "(" expr ")[" counter "]"))))
       (and free-k
	    (c-block* (c-declare `( ,counter simple unsigned))
		      (c-for counter (c-append "i->" (caddr type))
			     free-k)))))
    ((const) (make-freer (cdr type) expr))
    (else (error "make-freer: Invalid type " type))))

(define (make-free-function name vars)
  (let ((freers (map-variables make-freer vars "i")))
    (and (not (null? freers))
Niels Möller's avatar
Niels Möller committed
334
335
336
	 (c-append (c-prototype* "static void" (c-append "do_" name "_free")
				 "struct lsh_object *o")
		   indent
337
		   (c-block (cons (c-append "struct " name
Niels Möller's avatar
Niels Möller committed
338
					    " *i = (struct " name " *) o")
339
340
341
342
343
344
345
346
347
348
349
				  freers))
		   indent))))
	 
(define (struct-mark-prototype name)
  (c-append "void " name "_mark(struct " name " *i,\n"
	    " void (*mark)(struct lsh_object *o))"))

(define (struct-mark-function name vars)
  (c-append (struct-mark-prototype name) indent
	    (c-block
	     ;; To avoid warnings for unused parameters
Niels Möller's avatar
Niels Möller committed
350
351
352
	     (cons "(void) mark; (void) i"
		   (map-variables make-marker vars "i")))
	    indent))
353
354
355
356
357

(define (struct-free-prototype name)
  (c-append "void " name "_free(struct " name " *i)"))

(define (struct-free-function name vars)
Niels Möller's avatar
Niels Möller committed
358
  (c-append (struct-free-prototype name) indent
359
360
	    (c-block
	     ;; To avoid warnings for unused parameters
Niels Möller's avatar
Niels Möller committed
361
362
363
	     (cons "(void) i"
		   (map-variables make-freer vars "i")))
	    indent))
364
365
366
367
368
369
370
371
372
373
374
375
376
377

(define (make-class name super mark free meta methods)
  (let ((initializer
	 (c-initializer*
	  "STATIC_HEADER"
	  (if super
	      ;; FIXME: A cast (struct lsh_class *) or something
	      ;; equivalent is needed if the super class is not a
	      ;; struct lsh_class *. For now, fixed with macros
	      ;; expanding to the right component of extended class
	      ;; structures.
	      (c-address (c-append super "_class"))
	      "NULL")
	  (c-string name)
Niels Möller's avatar
Niels Möller committed
378
	  (c-call* "sizeof" (c-append "struct " name))
379
380
381
382
383
384
385
386
387
388
389
390
	  (if mark (c-append "do_" name "_mark") "NULL")
	  (if free (c-append "do_" name "_free") "NULL"))))
    (if meta
	(c-append "struct " meta "_meta "name "_class_extended ="
		  indent
		  (c-initializer (cons initializer (or methods '())))
		  ";" indent)
	(c-append "struct lsh_class " name "_class ="
		  indent initializer ";" indent))))

(define (make-meta name methods)
  (c-append "struct " name "_meta" indent
Niels Möller's avatar
Niels Möller committed
391
392
393
	    (c-block (cons "struct lsh_class super"
			   methods))
	    ";" indent)) 
Niels Möller's avatar
Niels Möller committed
394
395
396
397
398
399
400
401

(define (declare-struct-mark-function name)
  (list "void "	name "_mark(struct " name " *i, \n"
	"    void (*mark)(struct lsh_object *o))"))

(define (declare-struct-free-function name)
  (list "void " name "_free(struct " name " *i)"))

Niels Möller's avatar
Niels Möller committed
402
(define (preprocess-vars name vars)
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
  (define (preprocess-type type)
    (if (atom? type)
	`(simple ,type)
	(case (car type)
	  ;; Primitive types
	  ((string object bignum simple special indirect-special struct)
	   type)
	  ;; Second element is a type
	  ((array var-array pointer space function)
	   `( ,(car type) ,(preprocess-type (cadr type)) ,@(cddr type)))
	  ;; Tail is a type
	  ((const)
	   (cons 'const (preprocess-type (cdr type))))
	  ;; Shorthands
	  ((method)
	   `(pointer (function ,(preprocess-type (cadr type))
			       ("struct " ,name " *self")
Niels Möller's avatar
Niels Möller committed
420
421
422
423
424
425
426
			       ,@(cddr type))))
	  ((indirect-method)
	   `(pointer (function ,(preprocess-type (cadr type))
			       ("struct " ,name " **self")
			       ,@(cddr type))))
	  (else (error "preprocess-type: Invalid type " type)))))
    
427
428
429
430
  (map (lambda (var)
	 (cons (var-name var) (preprocess-type (var-type var))))
       vars))

431
(define (class-annotate name super meta)
432
433
434
  (c-append "/*\nCLASS:" name ":" (or super "")
	    (if meta (list ":" meta "_meta") "") "\n*/\n"))

Niels Möller's avatar
Niels Möller committed
435
(define (process-class attributes)
Niels Möller's avatar
Niels Möller committed
436
437
438
439
440
  (let* ((name (get 'name attributes cadr))
	 (super (get 'super attributes cadr))
	 (vars (preprocess-vars name (get 'vars attributes cdr)))
	 (meta (get 'meta attributes cadr))
	 (methods (get 'methods attributes cdr)))
Niels Möller's avatar
Niels Möller committed
441
442
    (werror "Processing class ~S\n" name)
    ; (werror "foo\n")
Niels Möller's avatar
Niels Möller committed
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
    (let ((mark-function (make-mark-function name vars))
	  (free-function (make-free-function name vars)))
					; (werror "baar\n")
      (c-append (class-annotate name super meta)
		"#ifndef GABA_DEFINE\n"	
		(make-instance-struct name super vars)
		(if meta
		    (c-append "extern struct " meta "_meta "
			      name "_class_extended;\n"
			      "#define " name "_class (" name
			      "_class_extended.super)\n")
		    (c-append "extern struct lsh_class " name "_class;\n"))
		"#endif /* !GABA_DEFINE */\n\n"
		"#ifndef GABA_DECLARE\n"
		(or mark-function "")
		(or free-function "")
		(make-class name super mark-function free-function
			    meta methods)
		"#endif /* !GABA_DECLARE */\n\n"))))
Niels Möller's avatar
Niels Möller committed
462
463
464
465
466

(define (process-meta attributes)
  (let ((name (get 'name attributes cadr))
	(methods (get 'methods attributes cdr)))
    (werror "Processing meta ~S\n" name)
467
    (c-append "#ifndef GABA_DEFINE\n"
Niels Möller's avatar
Niels Möller committed
468
	      (make-meta name methods)
469
470
	      "#endif /* !GABA_DEFINE */"
	      indent)))
Niels Möller's avatar
Niels Möller committed
471
472

(define (process-struct attributes)
Niels Möller's avatar
Niels Möller committed
473
474
475
476
477
478
  (let* ((name (get 'name attributes cadr))
	 ;; FIXME: Do we really handle super?
	 (super (get 'super attributes cadr))
	 (vars (preprocess-vars name (get 'vars attributes cdr)))
	 (meta (get 'meta attributes cadr))
	 (methods (get 'methods attributes cdr)))
Niels Möller's avatar
Niels Möller committed
479
    (werror "Processing struct ~S\n" name)
Niels Möller's avatar
Niels Möller committed
480
    ;; (werror "foo\n")
Niels Möller's avatar
Niels Möller committed
481
    ;; FIXME: Is this really needed?
Niels Möller's avatar
Niels Möller committed
482
483
484
485
486
487
488
489
490
491
    ;; (werror "baar\n")
    (c-append "#ifndef GABA_DEFINE\n"	
	      (c-struct name vars)
	      "extern " (struct-mark-prototype name) ";\n"
	      "extern " (struct-free-prototype name) ";\n"
	      "#endif /* !GABA_DEFINE */\n\n"
	      "#ifndef GABA_DECLARE\n"
	      (struct-mark-function name vars)
	      (struct-free-function name vars)
	      "#endif /* !GABA_DECLARE */\n\n")))
Niels Möller's avatar
Niels Möller committed
492
493


494
;;;; Expression compiler
Niels Möller's avatar
Niels Möller committed
495
496
497
498
499

;; Constants is an alist of (name value call_1 call_2 ... call_n)
;; where value is a C expression representing the value. call_i is
;; present, it is a function that can be called to apply the value to
;; i arguments directly.
Niels Möller's avatar
Niels Möller committed
500
(define (make-output constants expr)
Niels Möller's avatar
Niels Möller committed
501
502
503
504
  ;; OP and ARGS are C expressons
  (define (apply-generic op args)
    ;; (werror "(apply-generic ~S)\n" (cons op args))
    (if (null? args) op
Niels Möller's avatar
Niels Möller committed
505
	(apply-generic (c-call* "A" op (car args))
Niels Möller's avatar
Niels Möller committed
506
507
508
509
510
511
512
513
514
515
516
		       (cdr args))))
  ;; INFO is the (value [n]) associated with a constant,
  ;; and ARGS is a list of C expressions
  (define (apply-constant info args)
    ;; (werror "apply-constant : ~S\n" info)
    ;; (werror "          args : ~S\n" args)
    (let ((calls (cdr info)))
      (if (null? calls)
	(apply-generic (car info) args)
	(let ((n (min (length calls) (length args))))
	  ;; (werror "n: ~S\n" n)
Niels Möller's avatar
Niels Möller committed
517
518
	  (apply-generic (c-call (nth info n)
				 (list-prefix args n))
Niels Möller's avatar
Niels Möller committed
519
520
521
522
523
524
525
526
527
528
529
530
531
532
			 (list-tail args n))))))
  (define (lookup-global v)
    (cond ((assq v constants) => cdr)
	  (else (list (string-upcase (symbol->string v))))))
  
  (define (output-expression expr)
    ;; (werror "output-expression ~S\n" expr)
    (if (atom? expr)
	(car (lookup-global expr))
	(let ((op (application-op expr))
	      (args (map output-expression (application-args expr))))
	  (if (atom? op)
	      (apply-constant (lookup-global op) args)
	      (apply-generic op args)))))
Niels Möller's avatar
Niels Möller committed
533
  (output-expression expr))
Niels Möller's avatar
Niels Möller committed
534
535
536
537
538
539
540
541
542
543
544

(define (process-expr attributes)
  (define (params->alist params)
    (map (lambda (var)
	   (let ((name (var-name var)))
	     (list name (list "((struct lsh_object *) " name ")" ))))
	 params))
  
  ;; (werror "foo\n")
  (let ((name (get 'name attributes cadr))
	(globals (or (get 'globals attributes cdr) '()))
545
546
	(params (preprocess-vars #f
				 (or (get 'params attributes cdr) '())))
Niels Möller's avatar
Niels Möller committed
547
548
549
550
	(expr (get 'expr attributes cadr)))
    (werror "Processing expression ~S\n" name)
    (let ((translated (translate expr)))
      (werror "Compiled to ~S\n" translated)
551
552
      ;; (werror "Globals: ~S\n" globals)
      ;; (werror "Params: ~S\n" params)
553
      (c-append (c-prototype "static struct lsh_object *" name
Niels Möller's avatar
Niels Möller committed
554
555
			     (map c-declare params))
		indent
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
		(format #f "  /* ~S */\n" translated)
		"#define A GABA_APPLY\n"
		"#define I GABA_VALUE_I\n"
		"#define K GABA_VALUE_K\n"
		"#define K1 GABA_APPLY_K_1\n"
		"#define S GABA_VALUE_S\n"
		"#define S1 GABA_APPLY_S_1\n"
		"#define S2 GABA_APPLY_S_2\n"
		"#define B GABA_VALUE_B\n"
		"#define B1 GABA_APPLY_B_1\n"
		"#define B2 GABA_APPLY_B_2\n"
		"#define C GABA_VALUE_C\n"
		"#define C1 GABA_APPLY_C_1\n"
		"#define C2 GABA_APPLY_C_2\n"
		"#define Sp GABA_VALUE_Sp\n"
		"#define Sp1 GABA_APPLY_Sp_1\n"
		"#define Sp2 GABA_APPLY_Sp_2\n"
		"#define Sp3 GABA_APPLY_Sp_3\n"
		"#define Bp GABA_VALUE_Bp\n"
		"#define Bp1 GABA_APPLY_Bp_1\n"
		"#define Bp2 GABA_APPLY_Bp_2\n"
		"#define Bp3 GABA_APPLY_Bp_3\n"
		"#define Cp GABA_VALUE_Cp\n"
		"#define Cp1 GABA_APPLY_Cp_1\n"
		"#define Cp2 GABA_APPLY_Cp_2\n"
		"#define Cp3 GABA_APPLY_Cp_3\n"
		;; "  trace(\"Entering " name "\\n\");\n"
Niels Möller's avatar
Niels Möller committed
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
		(c-block*
		 (c-append
		  "return "
		  (c-call* "MAKE_TRACE"
			  (c-string name)
			  (make-output (append '( (I I)
						   (K K K1)
						   (S S S1 S2)
						   (B B B1 B2)
						   (C C C1 C2)
						   (S* Sp Sp1 Sp2 Sp3)
						   (B* Bp Bp1 Bp2 Bp3)
						   (C* Cp Cp1 Cp2 Cp3))
						globals
						(if params
						    (params->alist params)
						    '()))
				       translated))))
		indent
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
		"#undef A\n"
		"#undef I\n" 
		"#undef K\n"
		"#undef K1\n"
		"#undef S\n"
		"#undef S1\n"
		"#undef S2\n"
		"#undef B\n"
		"#undef B1\n"
		"#undef B2\n"
		"#undef C\n"
		"#undef C1\n"
		"#undef C2\n"
		"#undef Sp\n"
		"#undef Sp1\n"
		"#undef Sp2\n"
		"#undef Sp3\n"
		"#undef Bp\n"
		"#undef Bp1\n"
		"#undef Bp2\n"
		"#undef Bp3\n"
		"#undef Cp\n"
		"#undef Cp1\n"
		"#undef Cp2\n"
Niels Möller's avatar
Niels Möller committed
626
		"#undef Cp3\n"))))
Niels Möller's avatar
Niels Möller committed
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642

(define (process-input exp)
  (let ((type (car exp))
	(body (cdr exp)))
    ;; (werror "process-class: type = ~S\n" type)
    (case type
      ((class) (process-class body))
      ((meta) (process-meta body))
      ((struct) (process-struct body))
      ((expr) (process-expr body))
      (else (list "#error Unknown expression type " type "\n")))))

(define main
  (let ((test (lambda (s) (string-prefix? "/* GABA:" s))))
    (lambda args
      (let ((exp (read-expression test)))
Niels Möller's avatar
Niels Möller committed
643
644
645
	(unless (eof-object? exp)
		(out 0 (process-input exp))
		(main))))))