mescc.scm: first a.out produced from main.c.
[mes.git] / mescc.scm
1 (cond-expand
2   (guile
3    ;;(use-modules ((system base lalr)))
4    )
5   (mes
6    ))
7
8 (define c-parser
9   (lalr-parser
10
11    (lbrace rbrace lparen rparen lbracket rbracket semicolon colon dot comma
12            =
13            Identifier NumericLiteral StringLiteral
14            break case continue goto label
15            return switch
16            if else
17            (left: or && ! * / + -)
18            (left: bool double float enum void int struct)
19            (nonassoc: == !=)
20            )
21    
22    (program
23     (translation-unit *eoi*) : `(root ,@$1))
24
25    (translation-unit
26     (external-declaration) : `(,$1)
27     (translation-unit external-declaration) : `(,@$1 ,@$2))
28
29    (external-declaration
30     (function-definition) : $1
31     (declaration) : $1
32     (error semicolon) : (begin (syntax-error "external declaration" @1 $1) '()))
33
34    (function-definition
35     (declarator compound-statement) : `(function ,$1 (signature int (formals)) ,$2)
36     (declaration-specifiers declarator compound-statement) : `(function ,$2 (signature ,$1 (formals)) ,$3)
37     (declaration-specifiers declarator declaration-list compound-statement) : `(function ,$2 (signature ,$1 ,$3) ,$4))
38
39    (declaration
40     (declaration-specifiers semicolon) : `(,$1)
41     ;;(declaration-specifiers init-declarator-list semicolon): `(,$1 ,$2)
42     )
43
44    (declaration-list
45     (declaration) : `(formals $1)
46     (declaration-list declaration) : `(,@$1 ,@(cdr $2)))
47
48    (declaration-specifiers
49     ;;(storage-class-specifier) : `(,$1)
50     (type-specifier) : `(,$1)
51     ;;(type-qualifier) : `($1)
52     ;;(storage-class-specifier declaration-specifiers) : (cons $1 $2)
53     ;;(type-specifier declaration-specifiers) : (cons $1 $2)
54     ;;(type-qualifier declaration-specifiers) : (cons $1 $2)
55     )
56
57    ;; (storage_class_specifier
58    ;;  (auto)
59    ;;  (extern)
60    ;;  (register)
61    ;;  (static)
62    ;;  (typedef))
63    
64    (type-specifier
65     ;; (char) : $1
66     ;; (double) : $1
67     ;; (void) : $1
68     ;; (float)
69     (int) : 'int
70     ;; (long)
71     ;; (short)
72     ;; (unsigned)
73     ;; (struct-or-enum-specifier)
74     ;; (enum-specifier)
75     ;; (type-name)
76     )
77
78    ;; (type-qualifier
79    ;;  (const)
80    ;;  (volatile))
81
82    ;; struct_or_union_specifier:
83    ;;              struct_or_union_ident lbrace struct_declaration_list rbrace
84    ;;           |  struct_or_union_ident
85    ;;           ;
86
87    ;; struct_or_union_ident: struct_or_union
88    ;;           | struct_or_union Identifier
89    ;;           ;
90
91    ;; struct_or_union:   STRUCT                         { ; }
92    ;;           |  UNION                                { ; }
93    ;;           ;
94    
95    ;; struct_declaration_list: struct_declaration
96    ;;           |  struct_declaration_list struct_declaration
97    ;;           ;
98
99    ;; init_declarator_list:     init_declarator %prec comma
100    ;;           |  init_declarator_list comma init_declarator
101    ;;           ;
102
103    ;; init_declarator:  declarator
104    ;;           | declarator EQ initializer
105    ;;           | error { yyerror("init declarator error"); }
106    ;;           ;
107
108    ;; struct_declaration: specifier_qualifier_list struct_declarator_list semicolon
109    ;;           ;
110
111    ;; specifier_qualifier_list: type_specifier
112    ;;           |  type_qualifier
113    ;;           |  type_specifier specifier_qualifier_list
114    ;;           | type_qualifier specifier_qualifier_list
115    ;;           ;
116
117    ;; struct_declarator_list: struct_declarator
118    ;;           |  struct_declarator_list comma struct_declarator
119    ;;           ;
120
121    ;; struct_declarator: declarator
122    ;;           |  COLON constant_expression            { ; }
123    ;;           |  declarator COLON constant_expression
124    ;;           ;
125
126    ;; enum_specifier:      ENUM Identifier lbrace enumerator_list rbrace        { ; }
127    ;;           |  ENUM lbrace enumerator_list rbrace           { ; }
128    ;;           |  ENUM Identifier                              { ; }
129    ;;           ;
130
131    ;; enumerator_list:   enumerator
132    ;;           |  enumerator_list comma enumerator
133    ;;           ;
134
135    ;; enumerator:                  Identifier
136    ;;           |  Identifier EQ constant_expression
137    ;;           ;
138
139    (declarator
140     (direct-declarator) : $1
141     ;;(pointer direct-declarator)
142     )
143
144    (direct-declarator
145     (Identifier) : $1
146     ;; (lparen declarator rparen)
147     ;; (direct-declarator lbracket rbracket)
148     ;; (direct-declarator lbracket constant-expression rbracket)
149     ;; (lbracket constant-expression rbracket)
150     ;; (direct-declarator lparen parameter-type-list rparen)
151     (direct-declarator lparen rparen) : $1
152     ;; (direct-declarator lparen identifier-list rparen)
153     )
154
155    ;; pointer:     STAR                                 { ; }
156    ;;           |  STAR pointer                         { ; }
157    ;;           |  STAR type_qualifier_list             { ; }
158    ;;           |  STAR type_qualifier_list pointer     { ; }
159    ;;           ;
160
161    ;; type_qualifier_list: type_qualifier
162    ;;           |  type_qualifier_list type_qualifier
163    ;;           ;
164
165    ;; parameter_type_list: parameter_list
166    ;;           | parameter_list comma ELLIPSIS
167    ;;           ;
168
169    ;; parameter_list:      parameter_declaration
170    ;;           |  parameter_list comma parameter_declaration
171    ;;           ;
172
173    ;; parameter_declaration:
174    ;;              declaration_specifiers declarator
175    ;;           |  declaration_specifiers
176    ;;           |  declaration_specifiers abstract_declarator
177    ;;           ;
178
179    ;; identifier_list:        Identifier
180    ;;           |  identifier_list comma Identifier
181    ;;           |  error { yyerror("identifier list error"); }
182    ;;           ;
183
184    ;; initializer:       assignment_expression %prec comma
185    ;;           |  lbrace initializer_list rbrace               { ; }
186    ;;           |  lbrace initializer_list comma rbrace         { ; }
187    ;;           ;
188
189    ;; initializer_list:         initializer %prec comma
190    ;;           |  initializer_list comma initializer
191    ;;           ;
192
193    ;; type_name:           specifier_qualifier_list
194    ;;           |  specifier_qualifier_list abstract_declarator
195    ;;           ;
196
197    ;; abstract_declarator:      pointer
198    ;;           |  direct_abstract_declarator
199    ;;           |  pointer direct_abstract_declarator
200    ;;           ;
201
202    ;; direct_abstract_declarator:
203    ;;              lparen abstract_declarator rparen            { ; }
204    ;;           |  lbrace rbrace                                { ; }
205    ;;           |  direct_abstract_declarator lbrace rbrace
206    ;;           |  lbrace constant_expression rbrace            { ; }
207    ;;           |  direct_abstract_declarator lbrace constant_expression rbrace
208    ;;           |  lparen rparen                                { ; }
209    ;;           |  direct_abstract_declarator lparen rparen
210    ;;           |  lparen parameter_list rparen                 { ; }
211    ;;           |  direct_abstract_declarator lparen parameter_list rparen
212    ;;           ;
213
214    
215    (statement
216     ;;(labeled-statement) 
217     (expression-statement) : $1
218     (compound-statement) : $1
219     ;;(selection-statement)
220     ;;(iteration-statement)
221     (jump-statement) : $1
222     (semicolon) : '()
223     (error semicolon) : (begin (syntax-error "statement error" @1 $1) '())
224     (error rbrace) : (begin (syntax-error "statement error" @1 $1) '()))
225                 
226
227    ;; labeled_statement:
228    ;;              Identifier COLON statement
229    ;;           |  CASE x COLON statement               { ; }
230    ;;           |  DEFAULT COLON statement              { ; }
231    ;;           ;
232
233    (expression-statement
234     (x semicolon) : $1)
235
236    (compound-statement
237     (lbrace rbrace) : '(compound)
238     (lbrace declaration-list rbrace) : `(compound ,@$2)
239     (lbrace statement-list rbrace) :  `(compound ,@$2)
240     (lbrace declaration-list statement-list rbrace) : `(compound ,@$2 ,$3))
241
242    (statement-list
243     (statement) : `(,$1)
244     (statement-list statement) : `(,@$1 ,$2))
245    
246    ;; selection_statement:
247    ;;              IF lparen x rparen statement                 { ; }
248    ;;           |  IF lparen x rparen statement ELSE statement  { ; }
249    ;;           |  SWITCH lparen x rparen statement             { ; }
250    ;;           ;
251
252    ;; iteration_statement:
253    ;;              WHILE lparen x rparen statement              { ; }
254    ;;           |  DO statement WHILE lparen x rparen semicolon { ; }
255    ;;           |  FOR lparen forcntrl rparen statement         { ; }
256    ;;           ;
257
258    ;; forcntrl:         semicolon semicolon                                     { ; }
259    ;;           | semicolon semicolon x                         { ; }
260    ;;           | semicolon x semicolon                         { ; }
261    ;;           | semicolon x semicolon x                               { ; }
262    ;;           | x semicolon semicolon
263    ;;           | x semicolon semicolon x
264    ;;           | x semicolon x semicolon
265    ;;           | x semicolon x semicolon x
266    ;;           ;
267
268    (jump-statement
269     (goto Identifier semicolon) : `(goto ,$1)
270     (continue semicolon) : '(continue)
271     (break semicolon) : '(break)
272     (return semicolon) : '(return)
273     (return x semicolon) : `(return ,$2))
274
275    (x
276     (assignment-expression) : $1
277     (x comma assignment-expression) : `($1 ,@$2))
278                 
279    (assignment-expression
280      ;;(conditional-expression)
281     ;;(primary-expression) : $1
282     (postfix-expression) : $1
283     (unary-expression assignment-operator assignment-expression) : `(,$2 ,$1 ,$3))
284
285    (assignment-operator
286     (=) : $1)
287    ;;              EQ                                   { ; }
288    ;;           |  PLUSEQ                               { ; }
289    ;;           |  MINUSEQ                              { ; }
290    ;;           |  MUEQ                                 { ; }
291    ;;           |  DIVEQ                                { ; }
292    ;;           |  MODEQ                                { ; }
293    ;;           |  SLEQ                         { ; }
294    ;;           |  SREQ                         { ; }
295    ;;           |  ANEQ                         { ; }
296    ;;           |  OREQ                         { ; }
297    ;;           |  XOREQ                                { ; }
298    ;;           ;
299
300    ;; conditional_expression: logical_or_expression
301    ;;           |  logical_or_expression IF_THEN x COLON conditional_expression
302    ;;           ;
303
304    ;; constant_expression: conditional_expression
305    ;;           ;
306
307    ;; logical_or_expression: logical_and_expression
308    ;;           |  logical_or_expression OROR logical_and_expression
309    ;;           ;
310
311    ;; logical_and_expression: inclusive_or_expression
312    ;;           |  logical_and_expression ANDAND inclusive_or_expression
313    ;;           ;
314
315    ;; inclusive_or_expression: exclusive_or_expression
316    ;;           |  inclusive_or_expression OR exclusive_or_expression
317    ;;           ;
318
319    ;; exclusive_or_expression: and_expression
320    ;;           |  exclusive_or_expression XOR and_expression
321    ;;           ;
322
323    ;; and_expression: equality_expression
324    ;;           |  and_expression AND equality_expression
325    ;;           ;
326
327    ;; equality_expression: relational_expression
328    ;;           |  equality_expression EQEQ relational_expression
329    ;;           |  equality_expression NOTEQ relational_expression
330    ;;           ;
331
332    ;; relational_expression: shift_expression
333    ;;           |  relational_expression LT shift_expression
334    ;;           |  relational_expression LE shift_expression
335    ;;           |  relational_expression GT shift_expression
336    ;;           |  relational_expression GE shift_expression
337    ;;           ;
338
339    ;; shift_expression: additive_expression
340    ;;           |  shift_expression LTLT additive_expression
341    ;;           |  shift_expression GTGT additive_expression
342    ;;           ;
343
344    ;; additive_expression: multiplicative_expression
345    ;;           |  additive_expression PLUS multiplicative_expression
346    ;;           |  additive_expression MINUS multiplicative_expression
347    ;;           ;
348
349    ;; multiplicative_expression: cast_expression
350    ;;           |  multiplicative_expression STAR cast_expression
351    ;;           |  multiplicative_expression DIV cast_expression
352    ;;           |  multiplicative_expression MOD cast_expression
353    ;;           ;
354
355    ;; cast_expression:   unary_expression
356    ;;           |  lparen type_name rparen cast_expression      { ; }
357    ;;           ;
358
359    (unary-expression
360     (postfix-expression) : $1
361     )
362    ;; unary_expression:  postfix_expression
363    ;;           |  INCOP unary_expression               { ; }
364    ;;           |  DECOP unary_expression               { ; }
365    ;;           |  SIZEOF unary_expression              { ; }
366    ;;           |  SIZEOF lparen type_name rparen %prec SIZEOF  { ; }
367    ;;           |  STAR cast_expression                 { ; }
368    ;;           |  AND cast_expression                  { ; }
369    ;;           |  MINUS cast_expression                { ; }
370    ;;           |  PLUS cast_expression                 { ; }
371    ;;           |  NEG cast_expression                  { ; }
372    ;;           |  NOT cast_expression                  { ; }
373    ;;           ;
374
375    (postfix-expression
376     (primary-expression) : $1
377     (postfix-expression lparen rparen) : `(call ,$1 (arguments))
378     (postfix-expression lparen argument-expression-list rparen) : `(call ,$1 ,$3))
379
380    ;; postfix_expression: primary_expression
381    ;;           |  postfix_expression lbracket x rbracket
382    ;;           |  postfix_expression lparen rparen
383    ;;           |  postfix_expression lparen argument_expression_list rparen
384    ;;           |  postfix_expression FOLLOW Identifier
385    ;;           |  postfix_expression DOT Identifier
386    ;;           |  postfix_expression INCOP
387    ;;           |  postfix_expression DECOP
388    ;;           ;
389
390    (primary-expression
391     (Identifier): $1
392     (NumericLiteral) : $1
393     (StringLiteral) : $1
394     )
395    ;; primary_expression: Identifier
396    ;; INT_LITERAL
397    ;; CHAR_LITERAL
398    ;; FLOAT_LITERAL
399    ;; STRING_LITERAL
400    ;; lparen x rparen
401    ;;           
402
403    (argument-expression-list
404     (assignment-expression) : `(arguments ,$1)
405     (argument-expression-list comma assignment-expression): `(,@$1 ,@(cdr $2)))))
406
407 (define (i386:puts data)
408   `(
409      #xba #x0e #x00 #x00 #x00       ;; mov    $0xe,%edx
410           #xb9 ,@(int->bv32 data)        ;; mov    $data,%ecx
411           #xbb #x01 #x00 #x00 #x00       ;; mov    $0x1,%ebx
412           #xb8 #x04 #x00 #x00 #x00       ;; mov    $0x4,%eax
413           #xcd #x80                      ;; int    $0x80
414           ))
415
416 (define (i386:exit code)
417   `(
418     #xbb ,@(int->bv32 code)        ;; mov    $code,%ebx
419          #xb8 #x01 #x00 #x00 #x00       ;; mov    $0x1,%eax
420          #xcd #x80                      ;; int    $0x80
421          ))
422
423 (define (i386:puts data length)
424   `(
425      #xba ,@(int->bv32 length)           ;; mov    $length,%edx
426           #xb9 ,@(int->bv32 data)        ;; mov    $data,%ecx
427           #xbb #x01 #x00 #x00 #x00       ;; mov    $0x1,%ebx
428           #xb8 #x04 #x00 #x00 #x00       ;; mov    $0x4,%eax
429           #xcd #x80                      ;; int    $0x80
430           ))
431
432 (define mescc
433   (let ((errorp
434          (lambda args
435            (for-each display args)
436              (newline))))
437     (lambda ()
438       (c-parser (c-lexer errorp) errorp))))
439
440 (define (write-any x) (write-char (if (char? x) x (integer->char x))))
441
442 (define (ast:function? o)
443   (and (pair? o) (eq? (car o) 'function)))
444
445 (define (.name o)
446   (cadr o))
447
448 ;; (define (.statement o)
449 ;;   (match o
450 ;;     (('function name signature statement) statement)
451 ;;     (_ #f)))
452
453 ;; (define (statement->data o)
454 ;;   (match o
455 ;;     (('call 'puts ('arguments string)) (string->list string))
456 ;;     (_ '())))
457
458 ;; (define (statement->text o)
459 ;;   (match o
460 ;;     (('call 'puts ('arguments string)) (list (lambda (data) (i386:puts data (string-length string)))))
461 ;;     (('return code) (list (lambda (data) (i386:exit code))))
462 ;;     (_ '())))
463
464 (define (.statement o)
465   (and (pair? o)
466        (eq? (car o) 'function)
467        (cadddr o)))
468
469 (define (statement->data o)
470   (or (and (pair? o)
471            (eq? (car o) 'call)
472            (string->list (cadr (caddr o))))
473       '()))
474
475 (define (statement->text o)
476   (cond
477    ((and (pair? o) (eq? (car o) 'call))
478     (let ((string (cadr (caddr o))))
479       (list (lambda (data) (i386:puts data (string-length string))))))
480    ((and (pair? o) (eq? (car o) 'return))
481     (list (lambda (data) (i386:exit (cadr o)))))
482    (else '())))
483
484 (let* ((ast (mescc))
485        (functions (filter ast:function? (cdr ast)))
486        (main (find (lambda (x) (eq? (.name x) 'main)) functions))
487        (statements (cdr (.statement main))))
488   (display "program: " (current-error-port))
489   (display ast (current-error-port))
490   (newline (current-error-port))
491   (let loop ((statements statements) (text '()) (data '()))
492     (display "text:" (current-error-port))
493     (display text (current-error-port))
494     (newline (current-error-port))
495     (if (null? statements)
496         (map write-any (make-elf (lambda (data)
497                                    (append-map (lambda (f) (f data)) text)) data))
498         (let* ((statement (car statements)))
499           (display "statement:" (current-error-port))
500           (display statement (current-error-port))
501           (newline (current-error-port))
502           (loop (cdr statements)
503                 (append text (statement->text statement))
504                 (append data (statement->data statement)))))))