« back to all changes in this revision
Viewing changes to libol-0.3.17/utils/make_class
- browse files at revision 6
- compare with another revision
- download diff
- download tarball
- view history from revision 6
- Committer: Bazaar Package Importer
- Author(s): SZALAY Attila
- Date: 2005-11-27 22:12:57 UTC
- mfrom: (1.1.4 upstream)
- Revision ID: james.westby@ubuntu.com-20051127221257-yc1y4x3cf6ow1seo
Tags: 1.6.9-1
* New upstream version.
* Changed accepted Console log level to 1-8. (Closes: #318757)
* Fixed misspelled KERNEL_RINGBUF_SIZE. (Closes: #324813)
* Fixed a copy & paste bug in a manpage. (Closes: #312112)
* Changed accepted Console log level to 1-8. (Closes: #318757)
* Fixed misspelled KERNEL_RINGBUF_SIZE. (Closes: #324813)
* Fixed a copy & paste bug in a manpage. (Closes: #312112)
- files added:
- contrib/rhel-packaging
- debian/CVS
- debian/patches/CVS
- libol-0.3.17
- libol-0.3.17/src
- libol-0.3.17/utils
- files removed:
- libol-0.3.16.tar.gz
- files modified:
- ChangeLog
added
removed
libol-0.3.17/utils/make_class
1
#! /usr/bin/scsh \
2
-e main -s
3
!#
4
5
;; Reads a C source file on stdin. Comments of the form
6
;;
7
;; /*
8
;; CLASS:
9
;; expression
10
;; */
11
;;
12
;; are treated specially, and C code for the class is written to
13
;; stdout. Typically, the code is saved to a file and included by the
14
;; C source file in question.
15
16
;; FIXME: Perhaps the files should somehow be fed through the
17
;; preprocessor first?
18
19
;; FIXME: Turn this into a scheme48 module
20
21
(define-syntax let-and
22
(syntax-rules ()
23
((let-and (expr) clause clauses ...)
24
(and expr (let-and clause clauses ...)))
25
((let-and (name expr) clause clauses ...)
26
(let ((name expr))
27
(and name (let-and clause clauses ...))))
28
((let-and expr) expr)))
29
30
(define (atom? o) (not (list? o)))
31
(define (lambda? o) (and (pair? o) (eq? 'lambda (car o))))
32
33
(define (make-lambda formal body) `(lambda ,formal ,body))
34
(define lambda-formal cadr)
35
(define lambda-body caddr)
36
37
(define make-appliction list)
38
(define application-op car)
39
(define application-arg cadr)
40
(define application-args cdr)
41
42
(define (normalize-application op args)
43
(if (null? args) op
44
(normalize-application (make-appliction op (car args)) (cdr args))))
45
46
;; Transform (a b c)-> ((a b) c) and
47
;; (lambda (a b) ...) -> (lambda a (lambda b ...)
48
(define (make-preprocess specials)
49
50
(define (preprocess expr)
51
(if (atom? expr) expr
52
(let ((op (car expr)))
53
(cond ((and (atom? op)
54
(assq op specials))
55
=> (lambda (pair) ((cdr pair) (cdr expr) preprocess)))
56
(else
57
(normalize-application (preprocess op)
58
(map preprocess (cdr expr))))))))
59
preprocess)
60
61
(define preprocess-applications (make-preprocess '()))
62
63
(define (do-lambda args preprocess)
64
(let loop ((formals (reverse (car args)))
65
(body (preprocess (cadr args))))
66
(if (null? formals) body
67
(loop (cdr formals)
68
(make-lambda (car formals) body)))))
69
70
(define (do-let* args preprocess)
71
(let loop ((definitions (reverse (car args)))
72
(body (preprocess (cadr args))))
73
(if (null? definitions) body
74
(loop (cdr definitions)
75
(make-appliction
76
(make-lambda (caar definitions)
77
body)
78
(preprocess (cadar definitions)))))))
79
80
(define (do-let args preprocess)
81
(let ((definitions (car args))
82
(body (cadr args)))
83
(normalize-application
84
(do-lambda (list (map car definitions) body) preprocess)
85
(map cadr definitions))))
86
87
(define preprocess (make-preprocess
88
`((lambda . ,do-lambda)
89
(let . ,do-let)
90
(let* . ,do-let*))))
91
92
(define (free-variable? v expr)
93
(cond ((atom? expr) (eq? v expr))
94
((lambda? expr)
95
(and (not (eq? v (lambda-formal expr)))
96
(free-variable? v (lambda-body expr))))
97
(else
98
(or (free-variable? v (application-op expr))
99
(free-variable? v (application-arg expr))))))
100
101
(define (match pattern expr)
102
(if (atom? pattern)
103
(if (eq? '* pattern) (list expr)
104
(and (eq? pattern expr) '()))
105
(let-and ((pair? expr))
106
(op-matches (match (application-op pattern)
107
(application-op expr)))
108
(arg-matches (match (application-arg pattern)
109
(application-arg expr)))
110
(append op-matches arg-matches))))
111
112
(define (rule pattern f)
113
(cons (preprocess-applications pattern) f))
114
115
(define (make-K e) (make-combine 'K e))
116
(define (make-S p q) (make-combine 'S p q))
117
;; (define (make-B p) (make-combine 'B p))
118
;; (define (make-C p q) (make-combine 'C p q))
119
;; (define (make-S* p q) (make-combine 'S* p q))
120
;; (define (make-B* p q) (make-combine 'B* p q))
121
;; (define (make-C* p q) (make-combine 'C* p q))
122
123
;; Some mor patterns that can ba useful for optimization. From "A
124
;; combinator-based compiler for a functional language" by Hudak &
125
;; Kranz.
126
127
;; S K => K I
128
;; S (K I) => I
129
;; S (K (K x)) => K (K x)
130
;; S (K x) I => x
131
;; S (K x) (K y) => K (x y)
132
;; S f g x = f x (g x)
133
;; K x y => x
134
;; I x => x
135
;; Y (K x) => x
136
137
(define optimizations
138
(list (rule '(S (K *) (K *)) (lambda (p q) (make-K (make-appliction p q))))
139
(rule '(S (K *) I) (lambda (p) p))
140
;; (rule '(B K I) (lambda () 'K))
141
(rule '(S (K *) (B * *)) (lambda (p q r) (make-combine 'B* p q r)))
142
(rule '(S (K *) *) (lambda (p q) (make-combine 'B p q)))
143
(rule '(S (B * *) (K *)) (lambda (p q r) (make-combine 'C* p q r)))
144
;; (rule '(C (B * *) *) (lambda (p q r) (make-combine 'C* p q r)))
145
(rule '(S * (K *)) (lambda (p q) (make-combine 'C p q)))
146
(rule '(S (B * * ) r) (lambda (p q r) (make-combine 'S* p q r)))))
147
148
(define (optimize expr)
149
;; (werror "optimize ~S\n" expr)
150
(let loop ((rules optimizations))
151
;; (if (not (null? rules)) (werror "trying pattern ~S\n" (caar rules)) )
152
(cond ((null? rules) expr)
153
((match (caar rules) expr)
154
=> (lambda (parts) (apply (cdar rules) parts)))
155
(else (loop (cdr rules))))))
156
157
(define (optimize-application op args)
158
(if (null? args) op
159
(optimize-application (optimize (make-appliction op (car args)))
160
(cdr args))))
161
162
(define (make-combine op . args)
163
(optimize-application op args))
164
165
(define (translate-expression expr)
166
(cond ((atom? expr) expr)
167
((lambda? expr)
168
(translate-lambda (lambda-formal expr)
169
(translate-expression (lambda-body expr))))
170
(else
171
(make-appliction (translate-expression (application-op expr))
172
(translate-expression (application-arg expr))))))
173
174
(define (translate-lambda v expr)
175
(cond ((atom? expr)
176
(if (eq? v expr) 'I (make-K expr)))
177
((lambda? expr)
178
(error "translate-lambda: Unexpected lambda" expr))
179
(else
180
(make-S (translate-lambda v (application-op expr))
181
(translate-lambda v (application-arg expr))))))
182
183
(define (make-flat-application op arg)
184
(if (atom? op) `(,op ,arg)
185
`(,@op ,arg)))
186
187
(define (flatten-application expr)
188
(if (or (atom? expr) (lambda? expr)) expr
189
(make-flat-application (flatten-application (application-op expr))
190
(flatten-application (application-arg expr)))))
191
192
(define (translate expr)
193
(flatten-application (translate-expression (preprocess expr))))
194
195
;;; Test cases
196
;; (translate '(lambda (port connection)
197
;; (start-io (listen port connection)
198
;; (open-direct-tcpip connection))))
199
;; ===> (C (B* S (B start-io) listen) open-direct-tcpip)
200
;;
201
;; (translate '(lambda (f) ((lambda (x) (f (lambda (z) ((x x) z))))
202
;; (lambda (x) (f (lambda (z) ((x x) z)))) )))
203
;; ===> (S (C B (S I I)) (C B (S I I)))
204
;;
205
;; (translate '(lambda (r) (lambda (x) (if (= x 0) 1 (* x (r (- x 1)))))))
206
;; ===> (B* (S (C* if (C = 0) 1)) (S *) (C B (C - 1)))
207
208
209
(define (werror f . args)
210
(display (apply format #f f args) 2))
211
212
(define (string-prefix? prefix s)
213
(let ((l (string-length prefix)))
214
(and (<= l (string-length s))
215
(string=? prefix (substring s 0 l)))))
216
217
(define (read-expression p)
218
(let ((line (read-line)))
219
; (werror "read line: '~s'\n" (if (eof-object? line) "<EOF>" line))
220
(cond ((eof-object? line) line)
221
((p line) (read))
222
(else (read-expression p)))))
223
224
(define (get key alist select)
225
(cond ((assq key alist) => select)
226
(else #f)))
227
228
(define (append-deep o)
229
; (werror "append-deep: ~S\n" o)
230
(cond ((string? o) o)
231
((symbol? o) (symbol->string o))
232
((number? o) (number->string o))
233
(else
234
(apply string-append (map append-deep o)))))
235
236
(define (identity x) x)
237
238
(define (filter p list)
239
(cond ((null? list) list)
240
((p (car list)) (cons (car list)
241
(filter p (cdr list))))
242
(else (filter p (cdr list)))))
243
244
(define (implode list separator)
245
(cond ((null? list) '())
246
((null? (cdr list)) list)
247
(else `(,(car list) ,separator ,@(implode (cdr list) separator)))))
248
249
(define (atom? x) (or (symbol? x) (string? x)))
250
251
;; Variables are describes as lists (name . type)
252
;; Known types (and corresponding C declarations) are
253
;;
254
;; (string) struct ol_string *name
255
;; (object class) struct class *name
256
;; (bignum) mpz_t name
257
;; (simple c-type) c-type
258
;; (special c-type mark-fn free-fn)
259
;; (special-struct c-type mark-fn free-fn)
260
;;
261
;; (struct tag)
262
;;
263
;; (array type size) type name[size]
264
;; Variable size array (must be last) */
265
;; (var-array type size-field) type name[1]
266
;;
267
;; (pointer type) type *name
268
;; (space type) Like pointer, but should be freed
269
;;
270
;; (function type . arg-types) type name(arg-types)
271
;;
272
;; NOTE: For function types, the arguments are represented simply as
273
;; strings or lists containing C declarations; they do not use the
274
;; type syntax.
275
;;
276
;; (method type args)
277
;; is transformed into (pointer (function type self-arg args)) before
278
;; processing,
279
280
(define (type->category type)
281
(if (atom? type)
282
(type->category `(simple ,type))
283
(let ((tag (car type)))
284
(case tag
285
((string object static-object simple special special-struct
286
indirect-special space bignum struct) tag)
287
((array var-array pointer) (type->category (cadr type)))
288
289
(else (error "make_class: type->category: Invalid type" type))))))
290
291
(define (type->declaration type expr)
292
(if (atom? type)
293
(type->declaration `(simple ,type) expr)
294
(case (car type)
295
((string) (list "struct ol_string *" expr))
296
((object) (list "struct " (cadr type) " *" expr))
297
((static-object) (list "struct " (cadr type) " " expr))
298
((struct) (list "struct " (cadr type) " " expr))
299
((bignum) (list "mpz_t " expr))
300
((simple special special-struct indirect-special) (list (cadr type) " " expr))
301
((pointer space) (type->declaration (cadr type)
302
(list "(*(" expr "))")))
303
((array) (type->declaration (cadr type)
304
(list "((" expr ")[" (caddr type) "])")))
305
((var-array) (type->declaration (cadr type)
306
(list "((" expr ")[1])")))
307
((function) (type->declaration (cadr type)
308
(list expr
309
"(" (implode (cddr type) ", ")
310
")")))
311
(else (error "make_class: type->declaration: Invalid type" type)))))
312
313
(define (type->mark type expr)
314
(if (atom? type)
315
(type->mark `(simple ,type) expr)
316
(case (car type)
317
((string simple function space bignum) #f)
318
((object) (list "mark((struct ol_object *) " expr ");\n"))
319
((static-object) (list "mark((struct ol_object *) &" expr ");\n"))
320
((struct) (list (cadr type) "_mark(&" expr ", mark);\n"))
321
((pointer) (if (null? (cddr type))
322
(type->mark (cadr type) (list "*(" expr ")"))
323
324
;; The optional argument should be the name of
325
;; an instance variable holding the length of
326
;; the area pointed to
327
(let ((mark-k (type->mark (cadr type)
328
(list "(" expr ")[k]"))))
329
(and mark-k
330
(list "{\n unsigned k;\n"
331
" for (k=0; k<i->" (caddr type)
332
"; k++)\n"
333
" " mark-k
334
"}\n")))))
335
336
((special) (let ((mark-fn (caddr type)))
337
(and mark-fn (list mark-fn "(" expr ", mark);\n"))))
338
((indirect-special) (let ((mark-fn (caddr type)))
339
(and mark-fn (list mark-fn "(&(" expr
340
"), mark);\n"))))
341
((special-struct) (let ((mark-fn (caddr type)))
342
(and mark-fn (list mark-fn "(&(" expr "), mark);\n"))))
343
344
;; FIXME: Doesn't handle nested arrays
345
((array)
346
(let ((mark-k (type->mark (cadr type) (list "(" expr ")[k]"))))
347
(and mark-k
348
(list "{\n unsigned k;\n"
349
" for (k=0; k<" (caddr type) "; k++)\n"
350
" " mark-k
351
"}\n"))))
352
((var-array)
353
(let ((mark-k (type->mark (cadr type) (list "(" expr ")[k]"))))
354
(and mark-k
355
(list "{\n unsigned k;\n"
356
" for (k=0; k<i->" (caddr type) "; k++)\n"
357
" " mark-k
358
"}\n"))))
359
360
(else (error "make_class: type->mark: Invalid type" type)))))
361
362
(define (type->free type expr)
363
(define (free/f f)
364
(and f (list f "(" expr ");\n")))
365
366
(if (atom? type)
367
(type->free `(simple ,type) expr)
368
(case (car type)
369
((object simple function pointer) #f)
370
((static-object) (list "CLASS(" (cadr type) ").free_instance((struct ol_object *) &" expr ");\n"))
371
((struct) (list (cadr type) "_free(&" expr ");\n"))
372
((string) (free/f "ol_string_free"))
373
((bignum) (free/f "mpz_clear"))
374
((space) (free/f "ol_space_free"))
375
((special) (free/f (cadddr type)))
376
((special-struct) (let ((free-fn (cadddr type)))
377
(and free-fn
378
(list free-fn "(&(" expr "));\n"))))
379
((indirect-special) (let ((free-fn (cadddr type)))
380
(and free-fn
381
(list free-fn "(&(" expr "));\n"))))
382
383
384
((array)
385
(let ((free-k (type->free (cadr type) (list "(" expr ")[k]"))))
386
(and free-k
387
(list "{\n unsigned k;\n"
388
" for (k=0; k<" (caddr type) "; k++)\n"
389
" " free-k
390
"}\n"))))
391
((var-array)
392
(let ((free-k (type->free (cadr type) (list "(" expr ")[k]"))))
393
(and free-k
394
(list "{\n unsigned k;\n"
395
" for (k=0; k<i->" (caddr type) "; k++)\n"
396
" " free-k
397
"}\n"))))
398
399
(else (error "make_class: type->free: Invalid type" type)))))
400
401
#!
402
(define (type->init type expr)
403
(if (atom? type)
404
(type->init `(simple ,type) expr)
405
(case (car type)
406
((object string space pointer) (list expr "= NULL;\n"))
407
((bignum) (list "mpz_init(" expr ");\n"))
408
((array)
409
(let ((init-k (type->init (cadr type) (list "(" expr ")[k]"))))
410
(and init-k
411
(list "{\n unsigned k;\n"
412
" for (k=0; k<" (caddr type) "; k++)\n"
413
" " init-k
414
"}\n"))))
415
416
(else (error "make_class: type->init: Invalid type" type)))))
417
!#
418
419
(define var-name car)
420
(define var-type cdr)
421
422
(define (fix-method name var)
423
(let ((type (var-type var))
424
(variable (var-name var)))
425
(if (atom? type)
426
var
427
(case (car type)
428
((method)
429
`(,variable pointer (function ,(cadr type)
430
("struct " ,name " *self")
431
,@(cddr type))))
432
((indirect-method)
433
`(,variable pointer (function ,(cadr type)
434
("struct " ,name " **self")
435
,@(cddr type))))
436
(else var)))))
437
438
(define (do-instance-struct name super vars)
439
; (werror "do-instance-struct\n")
440
(list "struct " name
441
"\n{\n"
442
" struct " (or super "ol_object") " super;\n"
443
(map (lambda (var)
444
(list " " (type->declaration (var-type var)
445
(var-name var)) ";\n"))
446
vars)
447
"};\n"))
448
449
(define (do-struct name super vars)
450
; (werror "do-struct\n")
451
(list "struct " name
452
"\n{\n"
453
(map (lambda (var)
454
(list " " (type->declaration (var-type var)
455
(var-name var)) ";\n"))
456
vars)
457
"};\n"))
458
459
(define (do-mark-function name vars)
460
; (werror "do-mark-function\n")
461
(let ((markers (filter identity
462
(map (lambda (var)
463
(type->mark (var-type var)
464
(list "i->" (var-name var))))
465
vars))))
466
; (werror "gazonk\n")
467
(and (not (null? markers))
468
(list "static void do_"
469
name "_mark(struct ol_object *o, \n"
470
"void (*mark)(struct ol_object *o))\n"
471
"{\n"
472
" struct " name " *i = (struct " name " *) o;\n"
473
(map (lambda (x) (list " " x))
474
markers)
475
"}\n\n"))))
476
477
(define (do-free-function name vars)
478
; (werror "do-free-function\n")
479
(let ((freers (filter identity
480
(map (lambda (var)
481
(type->free (var-type var)
482
(list "i->" (var-name var))))
483
484
vars))))
485
; (werror "gazonk\n")
486
487
(and (not (null? freers))
488
(list "static void do_"
489
name "_free(struct ol_object *o)\n"
490
"{\n"
491
" struct " name " *i = (struct " name " *) o;\n"
492
(map (lambda (x) (list " " x))
493
freers)
494
"}\n\n"))))
495
496
(define (declare-struct-mark-function name)
497
(list "void " name "_mark(struct " name " *i, \n"
498
" void (*mark)(struct ol_object *o))"))
499
500
(define (do-struct-mark-function name vars)
501
; (werror "do-struct-mark-function\n")
502
(let ((markers (filter identity
503
(map (lambda (var)
504
(type->mark (var-type var)
505
(list "i->" (var-name var))))
506
vars))))
507
; (werror "gazonk\n")
508
(list (declare-struct-mark-function name)
509
"\n{\n"
510
; To avoid warnings for unused parameters
511
" (void) mark; (void) i;\n"
512
(map (lambda (x) (list " " x))
513
markers)
514
"}\n\n")))
515
516
(define (declare-struct-free-function name)
517
(list "void " name "_free(struct " name " *i)"))
518
519
(define (do-struct-free-function name vars)
520
; (werror "do-struct-free-function\n")
521
(let ((freers (filter identity
522
(map (lambda (var)
523
(type->free (var-type var)
524
(list "i->" (var-name var))))
525
526
vars))))
527
; (werror "gazonk\n")
528
529
(list (declare-struct-free-function name)
530
"\n{\n"
531
; To avoid warnings for unused parameters
532
" (void) i;\n"
533
(map (lambda (x) (list " " x))
534
freers)
535
"}\n\n")))
536
537
(define (do-class name super mark-function free-function meta methods)
538
(define initializer
539
(list "{ STATIC_HEADER,\n "
540
(if super
541
; FIXME: A cast (struct ol_class *) or something
542
; equivalent is needed if the super class is not a
543
; struct ol_class *. For now, fixed with macros
544
; expanding to the right component of extended class
545
; structures.
546
(list "&" super "_class")
547
"0")
548
", \"" name "\", sizeof(struct " name "),\n "
549
(if mark-function (list "do_" name "_mark") "NULL") ",\n "
550
(if free-function (list "do_" name "_free") "NULL") "\n"
551
"}"))
552
; (werror "do-class\n")
553
(if meta
554
(list "struct " meta "_meta " name "_class_extended =\n"
555
"{ " initializer
556
(if methods
557
(map (lambda (m) (list ",\n " m)) methods)
558
"")
559
"};\n"
560
"#define " name "_class (" name "_class_extended.super)\n")
561
(list "struct ol_class " name "_class =\n"
562
initializer ";\n")))
563
564
(define (process-class attributes)
565
(let ((name (get 'name attributes cadr))
566
(super (get 'super attributes cadr))
567
(raw-vars (get 'vars attributes cdr))
568
(meta (get 'meta attributes cadr))
569
(methods (get 'methods attributes cdr)))
570
(werror "Processing class ~S\n" name)
571
; (werror "foo\n")
572
(let ((vars (map (lambda (var) (fix-method name var))
573
raw-vars)))
574
(let ((mark-function (do-mark-function name vars))
575
(free-function (do-free-function name vars)))
576
; (werror "baar\n")
577
(list "#ifndef CLASS_DEFINE\n"
578
(do-instance-struct name super vars)
579
(if meta
580
(list "extern struct " meta "_meta "
581
name "_class_extended;\n")
582
(list "extern struct ol_class " name "_class;\n"))
583
"#endif /* !CLASS_DEFINE */\n\n"
584
"#ifndef CLASS_DECLARE\n"
585
(or mark-function "")
586
(or free-function "")
587
(do-class name super mark-function free-function
588
meta methods)
589
"#endif /* !CLASS_DECLARE */\n\n")))))
590
591
(define (process-meta attributes)
592
(let ((name (get 'name attributes cadr))
593
(methods (get 'methods attributes cdr)))
594
(werror "Processing meta ~S\n" name)
595
(list "#ifndef CLASS_DEFINE\n"
596
"struct " name "_meta\n"
597
"{\n"
598
" struct ol_class super;\n"
599
(map (lambda (m) (list " " m ";\n"))
600
methods)
601
"};\n"
602
"#endif /* !CLASS_DEFINE */\n\n")))
603
604
(define (process-struct attributes)
605
(let ((name (get 'name attributes cadr))
606
(super (get 'super attributes cadr))
607
(raw-vars (get 'vars attributes cdr))
608
(meta (get 'meta attributes cadr))
609
(methods (get 'methods attributes cdr)))
610
(werror "Processing struct ~S\n" name)
611
; (werror "foo\n")
612
;; FIXME: Is this really needed?
613
(let ((vars (map (lambda (var) (fix-method name var))
614
raw-vars)))
615
; (werror "baar\n")
616
(list "#ifndef CLASS_DEFINE\n"
617
(do-struct name super vars)
618
"extern " (declare-struct-mark-function name) ";\n"
619
"extern " (declare-struct-free-function name) ";\n"
620
"#endif /* !CLASS_DEFINE */\n\n"
621
"#ifndef CLASS_DECLARE\n"
622
(do-struct-mark-function name vars)
623
(do-struct-free-function name vars)
624
"#endif /* !CLASS_DECLARE */\n\n"))))
625
626
;;;; Expression compiler
627
628
;; Can't use load; it writes messages to stdout.
629
;;(load 'compiler)
630
631
;; Constants is an alist of (name value call_1 call_2 ... call_n)
632
;; where value is a C expression representing the value. call_i is
633
;; present, it is a function that can be called to apply the value to
634
;; i arguments directly.
635
(define (make-output constants)
636
;; OP and ARGS are C expressons
637
(define (apply-generic op args)
638
;; (werror "(apply-generic ~S)\n" (cons op args))
639
(if (null? args) op
640
(apply-generic (list "A(" op ", " (car args) ")")
641
(cdr args))))
642
;; INFO is the (value [n]) associated with a constant,
643
;; and ARGS is a list of C expressions
644
(define (apply-constant info args)
645
;; (werror "apply-constant : ~S\n" info)
646
;; (werror " args : ~S\n" args)
647
(let ((calls (cdr info)))
648
(if (null? calls)
649
(apply-generic (car info) args)
650
(let ((n (min (length calls) (length args))))
651
;; (werror "n: ~S\n" n)
652
(apply-generic (list (nth info n)
653
"(" (implode (list-prefix args n) ", ") ")")
654
(list-tail args n))))))
655
(define (lookup-global v)
656
(cond ((assq v constants) => cdr)
657
(else (error "make_class: undefined global" v))))
658
659
(define (output-expression expr)
660
;; (werror "output-expression ~S\n" expr)
661
(if (atom? expr)
662
(car (lookup-global expr))
663
(let ((op (application-op expr))
664
(args (map output-expression (application-args expr))))
665
(if (atom? op)
666
(apply-constant (lookup-global op) args)
667
(apply-generic op args)))))
668
output-expression)
669
670
(define (process-expr attributes)
671
(define (declare-params params)
672
(implode (map (lambda (var)
673
(type->declaration (var-type var)
674
(var-name var)))
675
params)
676
", "))
677
(define (params->alist params)
678
(map (lambda (var)
679
(let ((name (var-name var)))
680
(list name (list "((struct ol_object *) " name ")" ))))
681
params))
682
683
;; (werror "foo\n")
684
(let ((name (get 'name attributes cadr))
685
(globals (or (get 'globals attributes cdr) '()))
686
(params (get 'params attributes cdr))
687
(expr (get 'expr attributes cadr)))
688
(werror "Processing expression ~S\n" name)
689
(let ((translated (translate expr)))
690
(werror "Compiled to ~S\n" translated)
691
(list "static struct ol_object *\n" name "("
692
(if params (declare-params params) "void")
693
")\n{\n"
694
(format #f " /* ~S */\n" translated)
695
"#define A CLASS_APPLY\n"
696
"#define I CLASS_VALUE_I\n"
697
"#define K CLASS_VALUE_K\n"
698
"#define K1 CLASS_APPLY_K_1\n"
699
"#define S CLASS_VALUE_S\n"
700
"#define S1 CLASS_APPLY_S_1\n"
701
"#define S2 CLASS_APPLY_S_2\n"
702
"#define B CLASS_VALUE_B\n"
703
"#define B1 CLASS_APPLY_B_1\n"
704
"#define B2 CLASS_APPLY_B_2\n"
705
"#define C CLASS_VALUE_C\n"
706
"#define C1 CLASS_APPLY_C_1\n"
707
"#define C2 CLASS_APPLY_C_2\n"
708
"#define Sp CLASS_VALUE_Sp\n"
709
"#define Sp1 CLASS_APPLY_Sp_1\n"
710
"#define Sp2 CLASS_APPLY_Sp_2\n"
711
"#define Sp3 CLASS_APPLY_Sp_3\n"
712
"#define Bp CLASS_VALUE_Bp\n"
713
"#define Bp1 CLASS_APPLY_Bp_1\n"
714
"#define Bp2 CLASS_APPLY_Bp_2\n"
715
"#define Bp3 CLASS_APPLY_Bp_3\n"
716
"#define Cp CLASS_VALUE_Cp\n"
717
"#define Cp1 CLASS_APPLY_Cp_1\n"
718
"#define Cp2 CLASS_APPLY_Cp_2\n"
719
"#define Cp3 CLASS_APPLY_Cp_3\n"
720
" return\n "
721
((make-output (append '( (I I)
722
(K K K1)
723
(S S S1 S2)
724
(B B B1 B2)
725
(C C C1 C2)
726
(S* Sp Sp1 Sp2 Sp3)
727
(B* Bp Bp1 Bp2 Bp3)
728
(C* Cp Cp1 Cp2 Cp3))
729
globals
730
(if params
731
(params->alist params)
732
'())))
733
translated)
734
";\n"
735
"#undef A\n"
736
"#undef I\n"
737
"#undef K\n"
738
"#undef K1\n"
739
"#undef S\n"
740
"#undef S1\n"
741
"#undef S2\n"
742
"#undef B\n"
743
"#undef B1\n"
744
"#undef B2\n"
745
"#undef C\n"
746
"#undef C1\n"
747
"#undef C2\n"
748
"#undef Sp\n"
749
"#undef Sp1\n"
750
"#undef Sp2\n"
751
"#undef Sp3\n"
752
"#undef Bp\n"
753
"#undef Bp1\n"
754
"#undef Bp2\n"
755
"#undef Bp3\n"
756
"#undef Cp\n"
757
"#undef Cp1\n"
758
"#undef Cp2\n"
759
"#undef Cp3\n"
760
"}\n"))))
761
762
(define (process-input exp)
763
(let ((type (car exp))
764
(body (cdr exp)))
765
;; (werror "process-class: type = ~S\n" type)
766
(case type
767
((class) (process-class body))
768
((meta) (process-meta body))
769
((struct) (process-struct body))
770
((expr) (process-expr body))
771
(else (list "#error Unknown expression type " type "\n")))))
772
773
(define main
774
(let ((test (lambda (s) (string-prefix? "/* CLASS:" s))))
775
(lambda args
776
(let ((exp (read-expression test)))
777
(if (not (eof-object? exp))
778
(begin
779
(display (append-deep (process-input exp)))
780
(main))
781
0)))))
782
783
; (main)
784
Loggerhead is a web-based interface for Breezy
Version: 2.0.1