a25aefca4553970fa3cfb96713ebbf3e51d4388d
[mes.git] / module / language / c99 / compiler.mes
1 ;;; -*-scheme-*-
2
3 ;;; Mes --- Maxwell Equations of Software
4 ;;; Copyright © 2016,2017 Jan Nieuwenhuizen <janneke@gnu.org>
5 ;;;
6 ;;; This file is part of Mes.
7 ;;;
8 ;;; Mes is free software; you can redistribute it and/or modify it
9 ;;; under the terms of the GNU General Public License as published by
10 ;;; the Free Software Foundation; either version 3 of the License, or (at
11 ;;; your option) any later version.
12 ;;;
13 ;;; Mes is distributed in the hope that it will be useful, but
14 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
15 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
16 ;;; GNU General Public License for more details.
17 ;;;
18 ;;; You should have received a copy of the GNU General Public License
19 ;;; along with Mes.  If not, see <http://www.gnu.org/licenses/>.
20
21 ;;; Commentary:
22
23 ;;; compiler.mes produces an i386 binary from the C produced by
24 ;;; Nyacc c99.
25
26 ;;; Code:
27
28 (cond-expand
29  (guile-2
30   (set-port-encoding! (current-output-port) "ISO-8859-1"))
31  (guile)
32  (mes
33   (mes-use-module (nyacc lang c99 parser))
34   (mes-use-module (mes elf-util))
35   (mes-use-module (mes pmatch))
36   (mes-use-module (mes elf))
37   (mes-use-module (mes libc-i386))
38   (mes-use-module (mes optargs))))
39
40 (define (logf port string . rest)
41   (apply format (cons* port string rest))
42   (force-output port)
43   #t)
44
45 (define (stderr string . rest)
46   (apply logf (cons* (current-error-port) string rest)))
47
48 (define (gnuc-xdef? name mode) (if (equal? name "__GNUC__") #f (eq? mode 'code)))
49
50 (define (mescc)
51   (parse-c99
52    #:inc-dirs (string-split (getenv "C_INCLUDE_PATH") #\:)
53    #:cpp-defs '(
54                 ("__GNUC__" . "0")
55                 ("__NYACC__" . "1")
56                 ("VERSION" . "0.4")
57                 ("PREFIX" . "")
58                 )
59    #:xdef? gnuc-xdef?
60    #:mode 'code
61    ))
62
63 (define (write-any x)
64   (write-char (cond ((char? x) x)
65                     ((and (number? x) (< (+ x 256) 0)) (format (current-error-port) "***BROKEN*** x=~a\n" x) (integer->char #xaa))
66                     ((number? x) (integer->char (if (>= x 0) x (+ x 256))))
67                     (else (stderr "write-any: ~a\n" x) barf))))
68
69 (define (ast:function? o)
70   (and (pair? o) (eq? (car o) 'fctn-defn)))
71
72 (define (.name o)
73   (pmatch o
74     ((fctn-defn _ (ftn-declr (ident ,name) _) _) name)
75     ((fctn-defn _ (ptr-declr (pointer) (ftn-declr (ident ,name) _)) _) name)
76     ((param-decl _ (param-declr (ident ,name))) name)
77     ((param-decl _ (param-declr (ptr-declr (pointer) (ident ,name)))) name)
78     ((param-decl _ (param-declr (ptr-declr (pointer) (array-of (ident ,name))))) name)
79     (_
80      (format (current-error-port) "SKIP .name =~a\n" o))))
81
82 (define (.statements o)
83   (pmatch o
84     ((fctn-defn _ (ftn-declr (ident ,name) _) (compd-stmt (block-item-list . ,statements))) statements)
85     ((fctn-defn _ (ptr-declr (pointer) (ftn-declr (ident ,name) _)) (compd-stmt (block-item-list . ,statements))) statements)))
86
87 (define <info> '<info>)
88 (define <functions> '<functions>)
89 (define <globals> '<globals>)
90 (define <locals> '<locals>)
91 (define <function> '<function>)
92 (define <text> '<text>)
93 (define* (make o #:key (functions '()) (globals '()) (locals '()) (function #f) (text '()))
94   (pmatch o
95     (<info> (list <info>
96                   (cons <functions> functions)
97                   (cons <globals> globals)
98                   (cons <locals> locals)
99                   (cons <function> function)
100                   (cons <text> text)))))
101
102 (define (.functions o)
103   (pmatch o
104     ((<info> . ,alist) (assq-ref alist <functions>))))
105
106 (define (.globals o)
107   (pmatch o
108     ((<info> . ,alist) (assq-ref alist <globals>))))
109
110 (define (.locals o)
111   (pmatch o
112     ((<info> . ,alist) (assq-ref alist <locals>))))
113
114 (define (.function o)
115   (pmatch o
116     ((<info> . ,alist) (assq-ref alist <function>))))
117
118 (define (.text o)
119   (pmatch o
120     ((<info> . ,alist) (assq-ref alist <text>))))
121
122 (define (info? o)
123   (and (pair? o) (eq? (car o) <info>)))
124
125 (define (clone o . rest)
126   (cond ((info? o)
127          (let ((functions (.functions o))
128                (globals (.globals o))
129                (locals (.locals o))
130                (function (.function o))
131                (text (.text o)))
132            (let-keywords rest
133                          #f
134                          ((functions functions)
135                           (globals globals)
136                           (locals locals)
137                           (function function)
138                           (text text))
139                          (make <info> #:functions functions #:globals globals #:locals locals #:function function #:text text))))))
140
141 (define (ref-local locals)
142   (lambda (o)
143     ;; (stderr "IDENT REF[~a]: ~a => ~a\n" o (assoc-ref locals o) (i386:ref-local (assoc-ref locals o)))
144     (i386:ref-local (assoc-ref locals o))))
145
146 (define (ref-global globals)
147   (lambda (o)
148     (lambda (f g t d)
149       (i386:ref-global (+ (data-offset o g;;lobals
150                                        ) d)))))
151
152 (define (expr->arg globals locals) ;; FIXME: get Mes curried-definitions
153   (lambda (o)
154     (pmatch o
155       ((p-expr (fixed ,value)) (string->number value))
156       ((p-expr (string ,string)) ((ref-global globals) string))
157       ((p-expr (ident ,name)) ((ref-local locals) name))
158
159       ((array-ref (p-expr (fixed ,value)) (p-expr (ident ,name)))
160        (let ((value (string->number value))
161              (size 4)) ;; FIXME: type: int
162          (lambda (f g t d)
163            (append
164             ((ident->base locals) name)
165             (i386:value->accu (* size value)) ;; FIXME: type: int
166             (i386:base-mem->accu) ;; FIXME: type: int
167             (i386:push-accu) ;; hmm
168             ))))
169
170       (_
171        (format (current-error-port) "SKIP expr->arg=~a\n" o)     
172        0))))
173
174 (define (ident->accu locals)
175   (lambda (o)
176     (i386:local->accu (assoc-ref locals o))))
177
178 (define (accu->ident locals)
179   (lambda (o)
180     (i386:accu->local (assoc-ref locals o))))
181
182 (define (ident->base locals)
183   (lambda (o)
184     (i386:local->base (assoc-ref locals o))))
185
186 (define (expr->accu info)
187   (lambda (o)
188     (pmatch o
189       ((p-expr (fixed ,value)) (string->number value))
190       ((p-expr (ident ,name)) ((ident->accu (.locals info)) name))
191       ((fctn-call . _) ((ast->info info) `(expr-stmt ,o)))
192       ((not (fctn-call . _)) ((ast->info info) o))
193       ((sub . _) ((ast->info info) o)) ;; FIXME: expr-stmt
194       (_
195        (format (current-error-port) "SKIP expr->accu=~a\n" o)
196        0)
197       )))
198
199 (define (string->global string)
200   (cons string (append (string->list string) (list #\nul))))
201
202 (define (expr->global o)
203   (pmatch o
204     ((p-expr (string ,string)) (string->global string))
205     (_ #f)))
206
207 (define (dec->hex o)
208   (number->string o 16))
209
210 (define (byte->hex o)
211   (string->number (string-drop o 2) 16))
212
213 (define (asm->hex o)
214   (let ((prefix ".byte "))
215     (if (not (string-prefix? prefix o)) (begin (stderr "SKIP:~a\n" o)'())
216         (let ((s (string-drop o (string-length prefix))))
217           (map byte->hex (string-split s #\space))))))
218
219 (define (test->jump->info info)
220   (define (jump type)
221     (lambda (o)
222       (let* ((text (.text info))
223              (info (clone info #:text '()))
224              (info ((ast->info info) o))
225              (jump-text (lambda (body-length)
226                           (list (lambda (f g t d) (type body-length))))))
227        (lambda (body-length)
228          (clone info #:text
229                 (append text
230                         (.text info)
231                         (jump-text body-length)))))))
232   (lambda (o)
233     (pmatch o
234       ((lt ,a ,b) ((jump i386:jump-nc) o))
235       ((gt ,a ,b) ((jump i386:jump-nc) o))
236       ((ne ,a ,b) ((jump i386:jump-nz) o))
237       ((eq ,a ,b) ((jump i386:jump-nz) o))
238       ((not _) ((jump i386:jump-z) o))
239       ((and ,a ,b)
240        (let* ((text (.text info))
241               (info (clone info #:text '()))
242
243               (a-jump ((test->jump->info info) a))
244               (a-text (.text (a-jump 0)))
245               (a-length (length (text->list a-text)))
246
247               (b-jump ((test->jump->info info) b))
248               (b-text (.text (b-jump 0)))
249               (b-length (length (text->list b-text))))
250
251          (lambda (body-length)
252            (clone info #:text
253                   (append text
254                           (.text (a-jump (+ b-length body-length)))
255                           (.text (b-jump body-length)))))))
256       ((array-ref . _) ((jump i386:jump-byte-z) o))
257       ((de-ref _) ((jump i386:jump-byte-z) o))
258       (_ ((jump i386:jump-z) o)))))
259
260 (define (ast->info info)
261   (lambda (o)
262     (let ((globals (.globals info))
263           (locals (.locals info))
264           (text (.text info)))
265       (define (add-local name)
266         (let ((locals (acons name (1+ (length (filter positive? (map cdr locals)))) locals)))
267           locals))
268
269       ;; (stderr "\nS=~a\n" o)
270       ;; (stderr "  text=~a\n" text)
271       ;; (stderr "   info=~a\n" info)
272       ;; (stderr "   globals=~a\n" globals)
273       (pmatch o
274         (((trans-unit . _) . _) ((ast-list->info info) o))
275         ((trans-unit . ,elements) ((ast-list->info info) elements))
276         ((fctn-defn . _) ((function->info info) o))
277         ((comment . _) info)
278         ((cpp-stmt (define (name ,name) (repl ,value)))
279          (stderr "SKIP: #define ~s ~s\n" name value)
280          info)
281
282         ;; ;
283         ((expr-stmt) info)
284
285         ((compd-stmt (block-item-list . ,statements)) ((ast-list->info info) statements))
286         
287         ((expr-stmt (fctn-call (p-expr (ident ,name)) (expr-list . ,expr-list)))
288          (if (equal? name "asm") (let ((arg0 (cadr (cadar expr-list)))) ;; FIXME
289                                    (clone info #:text (append text (list (lambda (f g t d) (asm->hex arg0))))))
290              (let* ((globals (append globals (filter-map expr->global expr-list)))
291                     (args (map (expr->arg globals locals) expr-list)))
292                (clone info #:text
293                       (append text (list (lambda (f g t d)
294                                            (apply i386:call (cons* f g t d
295                                                                    (+ t (function-offset name f)) args)))))
296                       #:globals globals))))
297
298         ((if ,test ,body)
299          (let* ((text-length (length text))
300
301                 (test-jump->info ((test->jump->info info) test))
302                 (test+jump-info (test-jump->info 0))
303                 (test-length (length (.text test+jump-info)))
304
305                 (body-info ((ast->info test+jump-info) body))
306                 (text-body-info (.text body-info))
307                 (body-text (list-tail text-body-info test-length))
308                 (body-length (length (text->list body-text)))
309
310                 (text+test-text (.text (test-jump->info body-length)))
311                 (test-text (list-tail text+test-text text-length)))
312
313            (clone info #:text
314                   (append text
315                           test-text
316                           body-text)
317                   #:globals (.globals body-info))))
318
319         ((for ,init ,test ,step ,body)
320          (let* ((jump (pmatch test
321                         ((lt ,a ,b) i386:jump-c)
322                         ((gt ,a ,b) i386:jump-c)
323                         (_ i386:jump-nz)))
324                 (jump-text (lambda (body-length)
325                              (list (lambda (f g t d) (jump body-length)))))
326
327                 (info (clone info #:text '()))
328
329                 (info ((ast->info info) init))
330
331                 (init-text (.text info))
332                 (init-locals (.locals info))
333                 (info (clone info #:text '()))
334
335                 (body-info ((ast->info info) body))
336                 (body-text (.text body-info))
337                 (body-length (length (text->list body-text)))
338
339                 (step-info ((ast->info info) `(expr-stmt ,step)))
340                 (step-text (.text step-info))
341                 (step-length (length (text->list step-text)))
342
343                 (test-info ((ast->info info) test))
344                 (test-text (.text test-info))
345                 (test-length (length (text->list test-text))))
346
347            (clone info #:text
348                   (append text
349                           init-text
350                           (list (lambda (f g t d) (i386:jump (+ 2 body-length)))) ;; FIXME: 2
351                           body-text
352                           step-text
353                           test-text
354                           (jump-text (- (+ body-length step-length test-length))))
355                   #:globals (append globals (.globals body-info)) ;; FIXME
356                   #:locals locals)))
357
358         ((while ,test ,body)
359          (let* ((info (clone info #:text '()))
360                 (body-info ((ast->info info) body))
361                 (body-text (.text body-info))
362                 (body-length (length (text->list body-text)))
363
364                 (test-jump->info ((test->jump->info info) test))
365                 (test+jump-info (test-jump->info 0))
366                 (test-length (length (text->list (.text test+jump-info))))
367
368
369                 (skip-body-text (list (lambda (f g t d) (i386:jump (+ 2 body-length))))) ;; FIXME: 2
370
371                 (jump-text (list (lambda (f g t d) (i386:jump (- (+ body-length test-length))))))
372                 (jump-length (length (text->list jump-text)))
373
374                 (test-text (.text (test-jump->info jump-length))))
375
376            (clone info #:text
377                   (append text
378                           skip-body-text
379                           body-text
380                           test-text
381                           jump-text)
382                   #:globals (.globals body-info))))
383
384         ((labeled-stmt (ident ,label) ,statement)
385          (let ((info (clone info #:text (append text (list label)))))
386            ((ast->info info) statement)))
387
388         ((goto (ident ,label))
389          (let ((offset (length (text->list text))))
390            (clone info #:text
391                   (append text
392                           (list (lambda (f g t d)
393                                   (i386:jump (- (label-offset (.function info) label f) offset))))))))
394
395         ((p-expr (ident ,name))
396          (clone info #:text
397                 (append text
398                         (list (lambda (f g t d)
399                                 (append
400                                  (i386:local->accu (assoc-ref locals name))
401                                  (i386:accu-zero?)))))))
402
403         ((p-expr (fixed ,value))
404          (let ((value (string->number value)))
405           (clone info #:text
406                  (append text
407                          (list (lambda (f g t d)
408                                  (append
409                                   (i386:value->accu value)
410                                   (i386:accu-zero?))))))))
411
412         ((de-ref (p-expr (ident ,name)))
413          (clone info #:text
414                 (append text
415                         (list (lambda (f g t d)
416                                 (append
417                                  (i386:local->accu (assoc-ref locals name))
418                                  (i386:byte-mem->accu)))))))
419
420         ((fctn-call . ,call)
421          (let ((info ((ast->info info) `(expr-stmt ,o))))
422            (clone info #:text
423                   (append (.text info)
424                           (list (lambda (f g t d)
425                                   (i386:accu-zero?)))))))
426
427         ;; FIXME
428         ;;((post-inc ,expr) ((ast->info info) `(expr-stmt ,o)))
429         ((post-inc (p-expr (ident ,name)))
430          (clone info #:text
431                 (append text (list (lambda (f g t d)
432                                      (append
433                                       (i386:local->accu (assoc-ref locals name))
434                                       (i386:local-add (assoc-ref locals name) 1)
435                                       (i386:accu-zero?)))))))
436         ((post-inc ,expr) ((ast->info info) `(expr-stmt ,o)))
437         ((post-dec ,expr) ((ast->info info) `(expr-stmt ,o)))
438         ((pre-inc ,expr) ((ast->info info) `(expr-stmt ,o)))
439         ((pre-dec ,expr) ((ast->info info) `(expr-stmt ,o)))
440
441         ;; i++
442         ((expr-stmt (post-inc (p-expr (ident ,name))))
443          (clone info #:text
444                 (append text (list (lambda (f g t d)
445                                      (i386:local-add (assoc-ref locals name) 1))))))
446
447         ;; ++i
448         ((expr-stmt (pre-inc (p-expr (ident ,name))))
449          (clone info #:text
450                 (append text (list (lambda (f g t d)
451                                      (append
452                                       (i386:local-add (assoc-ref locals name) 1)
453                                       (i386:local->accu (assoc-ref locals name))
454                                       (i386:accu-zero?)))))))
455
456         ;; i--
457         ((expr-stmt (post-dec (p-expr (ident ,name))))
458          (clone info #:text
459                 (append text (list (lambda (f g t d)
460                                      (append
461                                       (i386:local->accu (assoc-ref locals name))
462                                       (i386:local-add (assoc-ref locals name) -1)
463                                       (i386:accu-zero?)))))))
464
465         ;; --i
466         ((expr-stmt (pre-dec (p-expr (ident ,name))))
467          (clone info #:text
468                 (append text (list (lambda (f g t d)
469                                      (append
470                                       (i386:local-add (assoc-ref locals name) -1)
471                                       (i386:local->accu (assoc-ref locals name))
472                                       (i386:accu-zero?)))))))
473
474         ((not ,expr)
475          (let* ((test-info ((ast->info info) expr)))
476            (clone info #:text
477                   (append (.text test-info)
478                           (list (lambda (f g t d)
479                                   (append
480                                    (i386:accu-not)
481                                    (i386:accu-zero?)))))
482                   #:globals (.globals test-info))))
483
484         ((eq (p-expr (ident ,a)) (p-expr (fixed ,b)))
485          (let ((b (string->number b)))
486            (clone info #:text
487                   (append text
488                           (list (lambda (f g t d)
489                                   (append 
490                                    (i386:local->base (assoc-ref locals a))
491                                    (i386:value->accu b)
492                                    (i386:sub-base))))))))
493
494         ((eq (fctn-call . ,call) (p-expr (fixed ,b)))
495          (let ((b (string->number b))
496                (info ((ast->info info) `(expr-stmt (fctn-call ,@call)))))
497            (clone info #:text
498                   (append text
499                           (.text info)
500                           (list (lambda (f g t d)
501                                   (append
502                                    (i386:value->base b)
503                                    (i386:sub-base))))))))
504
505         ((eq (fctn-call . ,call) (p-expr (ident ,b)))
506          (let ((info ((ast->info info) `(expr-stmt (fctn-call ,@call)))))
507            (clone info #:text
508                   (append text
509                           (.text info)
510                           (list (lambda (f g t d)
511                                   (append
512                                    (i386:local->base b)
513                                    (i386:sub-base))))))))
514
515         ((eq (de-ref (p-expr (ident ,a))) (de-ref (p-expr (ident ,b))))
516            (clone info #:text
517                   (append text
518                           (list (lambda (f g t d)
519                                   (append
520                                    (i386:local->accu (assoc-ref locals a))
521                                    (i386:byte-mem->base)
522                                    (i386:local->accu (assoc-ref locals b))
523                                    (i386:byte-mem->accu)
524                                    (i386:byte-test-base)))))))
525
526         ((gt (p-expr (ident ,a)) (p-expr (fixed ,b)))
527          (let ((b (string->number b)))
528            (clone info #:text
529                   (append text
530                           (list (lambda (f g t d)
531                                   (append 
532                                    (i386:local->base (assoc-ref locals a))
533                                    (i386:value->accu b)
534                                    (i386:sub-base))))))))
535
536         ((gt (p-expr (ident ,a)) (neg (p-expr (fixed ,b))))
537          (let ((b (- (string->number b))))
538            (clone info #:text
539                   (append text
540                           (list (lambda (f g t d)
541                                   (append 
542                                    (i386:local->base (assoc-ref locals a))
543                                    (i386:value->accu b)
544                                    (i386:sub-base))))))))        
545
546         
547         ((ne (p-expr (ident ,a)) (p-expr (fixed ,b)))
548          (let ((b (string->number b)))
549            (clone info #:text
550                   (append text
551                           (list (lambda (f g t d)
552                                   (append 
553                                    (i386:local->base (assoc-ref locals a))
554                                    (i386:value->accu b)
555                                    (i386:sub-base)
556                                    (i386:xor-zf))))))))
557         
558         ((ne (fctn-call . ,call) (p-expr (fixed ,b)))
559          (let ((b (string->number b))
560                (info ((ast->info info) `(expr-stmt (fctn-call ,@call)))))
561            (clone info #:text
562                   (append text
563                           (.text info)
564                           (list (lambda (f g t d)
565                                   (append
566                                    (i386:value->base b)
567                                    (i386:sub-base)
568                                    (i386:xor-zf))))))))
569
570         ((ne (fctn-call . ,call) (p-expr (ident ,b)))
571          (let ((info ((ast->info info) `(expr-stmt (fctn-call ,@call)))))
572            (clone info #:text
573                   (append text
574                           (.text info)
575                           (list (lambda (f g t d)
576                                   (append
577                                    (i386:local->base b)
578                                    (i386:sub-base)
579                                    (i386:xor-zf))))))))
580
581         ((ne (de-ref (p-expr (ident ,a))) (de-ref (p-expr (ident ,b))))
582            (clone info #:text
583                   (append text
584                           (list (lambda (f g t d)
585                                   (append
586                                    (i386:local->accu (assoc-ref locals a))
587                                    (i386:byte-mem->base)
588                                    (i386:local->accu (assoc-ref locals b))
589                                    (i386:byte-mem->accu)
590                                    (i386:byte-test-base)
591                                    (i386:xor-zf)))))))
592
593         ((lt (p-expr (ident ,a)) (p-expr (fixed ,b)))
594          (let ((b (string->number b)))
595            (clone info #:text
596                   (append text
597                           (list (lambda (f g t d)
598                                   (append 
599                                    (i386:local->base (assoc-ref locals a))
600                                    (i386:value->accu b)
601                                    (i386:base-sub))))))))
602
603         ((sub (de-ref (p-expr (ident ,a))) (de-ref (p-expr (ident ,b))))
604          (clone info #:text
605                 (append text
606                         (list (lambda (f g t d)
607                                 (append
608                                  (i386:local->accu (assoc-ref locals a))
609                                  (i386:byte-mem->base)
610                                  (i386:local->accu (assoc-ref locals b))
611                                  (i386:byte-mem->accu)
612                                  (i386:byte-sub-base)))))))
613
614         ((array-ref (p-expr (fixed ,value)) (p-expr (ident ,name)))
615          (let ((value (string->number value)))
616            (clone info #:text
617                   (append text (list (lambda (f g t d)
618                                        (append
619                                         ((ident->base locals) name)
620                                         (i386:value->accu value)
621                                         (i386:byte-base-mem->accu)))))))) ; FIXME: type: char
622         
623         ((array-ref (p-expr (ident ,name)) (p-expr (ident ,index)))
624          (clone info #:text
625                 (append text (list (lambda (f g t d)
626                                      (append
627                                       ((ident->base locals) name)
628                                       ((ident->accu locals) index)
629                                       (i386:byte-base-mem->accu))))))) ; FIXME: type: char
630         
631         ((return ,expr)
632          (let ((accu ((expr->accu info) expr)))
633            (if (info? accu)
634                (clone accu #:text
635                       (append (.text accu) (list (i386:ret (lambda _ '())))))
636                (clone info #:text
637                       (append text (list (i386:ret ((expr->accu info) expr))))))))
638
639         ;; int i;
640         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name))))
641          (clone info #:locals (add-local name)))
642
643         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (fixed ,value))))))
644          (let ((locals (add-local name)))
645            (let ((value (string->number value)))
646              (clone info #:text
647                     (append text (list (lambda (f g t d)
648                                        (i386:local-assign (assoc-ref locals name) value))))
649                   #:locals locals))))
650
651         ;; int i = argc;
652         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (ident ,local))))))
653          (let ((locals (add-local name)))
654            (clone info #:text
655                   (append text (list (lambda (f g t d)
656                                        (append
657                                         ((ident->accu locals) local)
658                                         ((accu->ident locals) name)))))
659                  #:locals locals)))
660
661         ;; char *p = "t.c";
662         ;;(decl (decl-spec-list (type-spec (fixed-type "char"))) (init-declr-list (init-declr (ptr-declr (pointer) (ident "p")) (initzer (p-expr (string "t.c\n"))))))
663         ((decl (decl-spec-list (type-spec (fixed-type _))) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (p-expr (string ,value))))))
664          (let ((locals (add-local name))
665                (globals (append globals (list (string->global value)))))
666            (clone info #:text
667                   (append text
668                           (list (lambda (f g t d)
669                                   (append
670                                    (i386:global->accu (+ (data-offset value g) d))
671                                    ((accu->ident locals) name)))))
672                   #:locals locals
673                   #:globals globals)))
674         
675         ;; SCM i = argc;
676         ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (ident ,local))))))
677          (let ((locals (add-local name)))
678            (clone info #:text
679                 (append text (list (lambda (f g t d)
680                                      (append
681                                       ((ident->accu locals) local)
682                                       ((accu->ident locals) name)))))
683                 #:locals locals)))
684         
685         ;; int i = f ();
686         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (fctn-call . ,call)))))
687          (let* ((locals (add-local name))
688                 (info (clone info #:locals locals)))
689            (let ((info ((ast->info info) `(expr-stmt (fctn-call ,@call)))))
690              (clone info
691                     #:text
692                     (append (.text info)
693                             (list (lambda (f g t d)
694                                     (i386:ret-local (assoc-ref locals name)))))
695                     #:locals locals))))
696         
697         ;; i = 0;
698         ((expr-stmt (assn-expr (p-expr (ident ,name)) (op _) (p-expr (fixed ,value))))
699          ;;(stderr "RET LOCAL[~a]: ~a\n" name (assoc-ref locals name))
700          (let ((value (string->number value)))
701            (clone info #:text (append text (list (lambda (f g t d) (i386:local-assign (assoc-ref locals name) value)))))))
702
703         ;; i = 0; ...from for init FIXME
704         ((assn-expr (p-expr (ident ,name)) (op _) (p-expr (fixed ,value)))
705          (let ((value (string->number value)))
706            (clone info #:text (append text (list (lambda (f g t d) (i386:local-assign (assoc-ref locals name) value)))))))
707         
708         ((expr-stmt (assn-expr (p-expr (ident ,name)) (op _) (fctn-call . ,call)))
709          (let* ((info ((ast->info info) `(expr-stmt (fctn-call ,@call)))))
710            (clone info #:text (append (.text info) (list (lambda (f g t d) (i386:ret-local (assoc-ref locals name))))))))
711
712         (_
713          (format (current-error-port) "SKIP statement=~s\n" o)
714          info)))))
715
716 (define (info->exe info)
717   (display "dumping elf\n" (current-error-port))
718   (map write-any (make-elf (.functions info) (.globals info))))
719
720 (define (.formals o)
721   (pmatch o
722     ((fctn-defn _ (ftn-declr _ ,formals) _) formals)
723     ((fctn-defn _ (ptr-declr (pointer) (ftn-declr _ ,formals)) _) formals)
724     (_ (format (current-error-port) ".formals: no match: ~a\n" o)
725        barf)))
726
727 (define (formal->text n)
728   (lambda (o i)
729     ;;(i386:formal i n)
730     '()
731     ))
732
733 (define (formals->text o)
734   (pmatch o
735     ((param-list . ,formals)
736      (let ((n (length formals)))
737        (list (lambda (f g t d)
738                (append
739                 (i386:function-preamble)
740                 (append-map (formal->text n) formals (iota n))
741                 (i386:function-locals))))))
742     (_ (format (current-error-port) "formals->text: no match: ~a\n" o)
743        barf)))
744
745 (define (formals->locals o)
746   (pmatch o
747     ((param-list . ,formals)
748      (let ((n (length formals)))
749        ;;(stderr "FORMALS: ~a ==> ~a\n" formals n)
750        (map cons (map .name formals) (iota n -2 -1))))
751     (_ (format (current-error-port) "formals->info: no match: ~a\n" o)
752        barf)))
753
754 (define (function->info info)
755   (lambda (o)
756     ;;(stderr "\n")
757     ;;(stderr "formals=~a\n" (.formals o))
758     (let* ((name (.name o))
759            (text (formals->text (.formals o)))
760            (locals (formals->locals (.formals o))))
761       (format (current-error-port) "compiling ~a\n" name)
762       ;;(stderr "locals=~a\n" locals)
763       (let loop ((statements (.statements o))
764                  (info (clone info #:locals locals #:function name #:text text)))
765         (if (null? statements) (clone info
766                                       #:function #f
767                                       #:functions (append (.functions info) (list (cons (.name o) (.text info)))))
768             (let* ((statement (car statements)))
769               (loop (cdr statements)
770                     ((ast->info info) (car statements)))))))))
771
772 (define (ast-list->info info)
773   (lambda (elements)
774     (let loop ((elements elements) (info info))
775       (if (null? elements) info
776           (loop (cdr elements) ((ast->info info) (car elements)))))))
777
778 (define _start
779   (let* ((argc-argv
780           (string-append ".byte"
781                          " 0x89 0xe8"      ; mov    %ebp,%eax
782                          " 0x83 0xc0 0x08" ; add    $0x8,%eax
783                          " 0x50"           ; push   %eax
784                          " 0x89 0xe8"      ; mov    %ebp,%eax
785                          " 0x83 0xc0 0x04" ; add    $0x4,%eax
786                          " 0x0f 0xb6 0x00" ; movzbl (%eax),%eax
787                          " 0x50"           ; push   %eax
788                          ))
789          (ast (with-input-from-string
790                   
791                   (string-append "int _start () {int i;asm(\"" argc-argv "\");i=main ();exit (i);}")
792                 parse-c99)))
793     ast))
794
795 (define strlen
796   (let* ((ast (with-input-from-string
797                   "
798 int
799 strlen (char const* s)
800 {
801   int i = 0;
802   while (s[i]) i++;
803   return i;
804 }
805 "
806 ;;paredit:"
807                 parse-c99)))
808     ast))
809
810 (define eputs
811   (let* ((ast (with-input-from-string
812                   "
813 int
814 eputs (char const* s)
815 {
816   //write (STDERR, s, strlen (s));
817   //write (2, s, strlen (s));
818   int i = strlen (s);
819   write (2, s, i);
820   return 0;
821 }
822 "
823 ;;paredit:"
824                 parse-c99)))
825     ast))
826
827 (define fputs
828   (let* ((ast (with-input-from-string
829                   "
830 int
831 fputs (char const* s, int fd)
832 {
833  int i = strlen (s);
834   write (fd, s, i);
835   return 0;
836 }
837 "
838 ;;paredit:"
839                 parse-c99)))
840     ast))
841
842 (define puts
843   (let* ((ast (with-input-from-string
844                   "
845 int
846 puts (char const* s)
847 {
848   //write (STDOUT, s, strlen (s));
849   //int i = write (STDOUT, s, strlen (s));
850   int i = strlen (s);
851   write (1, s, i);
852   return 0;
853 }
854 "
855 ;;paredit:"
856                 parse-c99)))
857     ast))
858
859 (define strcmp
860   (let* ((ast (with-input-from-string
861                   "
862 int
863 strcmp (char const* a, char const* b)
864 {
865   while (*a && *b && *a == *b) 
866     {
867       a++;b++;
868     }
869   return *a - *b;
870 }
871 "
872 ;;paredit:"
873                 parse-c99)))
874     ast))
875
876 (define i386:libc
877   (list
878    (cons "exit" (list i386:exit))
879    (cons "write" (list i386:write))))
880
881 (define libc
882   (list
883    strlen
884    eputs
885    fputs
886    puts
887    strcmp))
888
889 (define (compile)
890   (let* ((ast (mescc))
891          (info (make <info> #:functions i386:libc))
892          (info ((ast->info info) libc))
893          (info ((ast->info info) ast))
894          (info ((ast->info info) _start)))
895     (info->exe info)))