mescc: Support globals.
[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                     ((procedure? x)
68                      (stderr "write-any: proc: ~a\n" x)
69                      (stderr "  ==> ~a\n" (map dec->hex (x '() '() 0 0)))
70                      barf)
71                     (else (stderr "write-any: ~a\n" x) barf))))
72
73 (define (ast:function? o)
74   (and (pair? o) (eq? (car o) 'fctn-defn)))
75
76 (define (.name o)
77   (pmatch o
78     ((fctn-defn _ (ftn-declr (ident ,name) _) _) name)
79     ((fctn-defn _ (ptr-declr (pointer) (ftn-declr (ident ,name) _)) _) name)
80     ((param-decl _ (param-declr (ident ,name))) name)
81     ((param-decl _ (param-declr (ptr-declr (pointer) (ident ,name)))) name)
82     ((param-decl _ (param-declr (ptr-declr (pointer) (array-of (ident ,name))))) name)
83     (_
84      (format (current-error-port) "SKIP .name =~a\n" o))))
85
86 (define (.statements o)
87   (pmatch o
88     ((fctn-defn _ (ftn-declr (ident ,name) _) (compd-stmt (block-item-list . ,statements))) statements)
89     ((fctn-defn _ (ptr-declr (pointer) (ftn-declr (ident ,name) _)) (compd-stmt (block-item-list . ,statements))) statements)))
90
91 (define <info> '<info>)
92 (define <functions> '<functions>)
93 (define <globals> '<globals>)
94 (define <locals> '<locals>)
95 (define <function> '<function>)
96 (define <text> '<text>)
97 (define* (make o #:key (functions '()) (globals '()) (locals '()) (function #f) (text '()))
98   (pmatch o
99     (<info> (list <info>
100                   (cons <functions> functions)
101                   (cons <globals> globals)
102                   (cons <locals> locals)
103                   (cons <function> function)
104                   (cons <text> text)))))
105
106 (define (.functions o)
107   (pmatch o
108     ((<info> . ,alist) (assq-ref alist <functions>))))
109
110 (define (.globals o)
111   (pmatch o
112     ((<info> . ,alist) (assq-ref alist <globals>))))
113
114 (define (.locals o)
115   (pmatch o
116     ((<info> . ,alist) (assq-ref alist <locals>))))
117
118 (define (.function o)
119   (pmatch o
120     ((<info> . ,alist) (assq-ref alist <function>))))
121
122 (define (.text o)
123   (pmatch o
124     ((<info> . ,alist) (assq-ref alist <text>))))
125
126 (define (info? o)
127   (and (pair? o) (eq? (car o) <info>)))
128
129 (define (clone o . rest)
130   (cond ((info? o)
131          (let ((functions (.functions o))
132                (globals (.globals o))
133                (locals (.locals o))
134                (function (.function o))
135                (text (.text o)))
136            (let-keywords rest
137                          #f
138                          ((functions functions)
139                           (globals globals)
140                           (locals locals)
141                           (function function)
142                           (text text))
143                          (make <info> #:functions functions #:globals globals #:locals locals #:function function #:text text))))))
144
145 (define (push-global-ref globals)
146   (lambda (o)
147     (lambda (f g t d)
148       (i386:push-global-ref (+ (data-offset o g) d)))))
149
150 (define (push-global globals)
151   (lambda (o)
152     (lambda (f g t d)
153       (i386:push-global (+ (data-offset o g) d)))))
154
155 (define (push-ident globals locals)
156   (lambda (o)
157     (let ((local (assoc-ref locals o)))
158       (if local (i386:push-local local)
159           ((push-global globals) o)))))
160
161 (define (push-ident-ref globals locals)
162   (lambda (o)
163     (let ((local (assoc-ref locals o)))
164       (if local (i386:push-local-ref local)
165           ((push-global-ref globals) o)))))
166
167 (define (expr->arg info) ;; FIXME: get Mes curried-definitions
168   (lambda (o)
169     (pmatch o
170       ((p-expr (fixed ,value)) (cstring->number value))
171       ((p-expr (string ,string)) ((push-global-ref (.globals info)) string))
172       ((p-expr (ident ,name))
173        ((push-ident (.globals info) (.locals info)) name))
174
175       ((array-refo (p-expr (fixed ,value)) (p-expr (ident ,name)))
176        (let ((value (cstring->number value))
177              (size 4)) ;; FIXME: type: int
178          (lambda (f g t d)
179            (append
180             ((ident->base (.locals info)) name)
181             (i386:value->accu (* size value)) ;; FIXME: type: int
182             (i386:base-mem->accu) ;; FIXME: type: int
183             (i386:push-accu) ;; hmm
184             ))))
185       ((ref-to (p-expr (ident ,name)))
186        (lambda (f g t d)
187          ((push-ident-ref (.globals info) (.locals info)) name)))
188       ((cast (type-name (decl-spec-list (type-spec (fixed-type _)))
189                         (abs-declr (pointer)))
190              ,cast)
191        ((expr->arg info) cast))
192       (_
193        (format (current-error-port) "SKIP expr->arg=~a\n" o)     
194        0))))
195
196 (define (ident->accu info)
197   (lambda (o)
198     (let ((local (assoc-ref (.locals info) o)))
199       (if local
200           (list (lambda (f g t d)
201                   (i386:local->accu local)))
202           (list (lambda (f g t d)
203                   (i386:global->accu (+ (data-offset o g) d))))))))
204
205 (define (accu->ident info)
206   (lambda (o)
207     (let ((local (assoc-ref (.locals info) o)))
208       (if local
209           (list (lambda (f g t d)
210                   (i386:accu->local local)))
211           (list (lambda (f g t d)
212                   (i386:accu->global (+ (data-offset o g) d))))))))
213
214 (define (value->ident info)
215   (lambda (o value)
216     (let ((local (assoc-ref (.locals info) o)))
217       (if local
218           (list (lambda (f g t d)
219                   (i386:value->local local value)))
220           (list (lambda (f g t d)
221                   (i386:value->global (+ (data-offset o g) d) value)))))))
222
223 (define (ident-address->accu info)
224   (lambda (o)
225     (let ((local (assoc-ref (.locals info) o)))
226       (if local
227           (list (lambda (f g t d)
228                   (i386:local-address->accu local)))
229           (list (lambda (f g t d)
230                   (i386:global->accu (+ (data-offset o g) d))))))))
231
232 (define (ident->base info)
233   (lambda (o)
234     (let ((local (assoc-ref (.locals info) o)))
235       (if local
236           (list (lambda (f g t d)
237                   (i386:local->base local)))
238           (list (lambda (f g t d)
239                   (i386:global->base (+ (data-offset o g) d))))))))
240
241 (define (expr->accu info)
242   (lambda (o)
243     (pmatch o
244       ((p-expr (fixed ,value)) (cstring->number value))
245       ((p-expr (ident ,name)) (car ((ident->accu info) name)))
246       ((fctn-call . _) ((ast->info info) `(expr-stmt ,o)))
247       ((not (fctn-call . _)) ((ast->info info) o))
248       ((sub . _) ((ast->info info) o)) ;; FIXME: expr-stmt
249       ((neg (p-expr (fixed ,value))) (- (cstring->number value)))
250       (_
251        (format (current-error-port) "SKIP expr->accu=~a\n" o)
252        0)
253       )))
254
255 (define (string->global string)
256   (cons string (append (string->list string) (list #\nul))))
257
258 (define (ident->global name value)
259   (cons name (int->bv32 value)))
260
261 (define (expr->global o)
262   (pmatch o
263     ((p-expr (string ,string)) (string->global string))
264     (_ #f)))
265
266 (define (dec->hex o)
267   (number->string o 16))
268
269 (define (byte->hex o)
270   (string->number (string-drop o 2) 16))
271
272 (define (asm->hex o)
273   (let ((prefix ".byte "))
274     (if (not (string-prefix? prefix o)) (begin (stderr "SKIP:~a\n" o)'())
275         (let ((s (string-drop o (string-length prefix))))
276           (map byte->hex (string-split s #\space))))))
277
278 (define (test->jump->info info)
279   (define (jump type)
280     (lambda (o)
281       (let* ((text (.text info))
282              (info (clone info #:text '()))
283              (info ((ast->info info) o))
284              (jump-text (lambda (body-length)
285                           (list (lambda (f g t d) (type body-length))))))
286        (lambda (body-length)
287          (clone info #:text
288                 (append text
289                         (.text info)
290                         (jump-text body-length)))))))
291   (lambda (o)
292     (pmatch o
293       ((lt ,a ,b) ((jump i386:jump-nc) o))
294       ((gt ,a ,b) ((jump i386:jump-nc) o))
295       ((ne ,a ,b) ((jump i386:jump-nz) o))
296       ((eq ,a ,b) ((jump i386:jump-nz) o))
297       ((not _) ((jump i386:jump-z) o))
298       ((and ,a ,b)
299        (let* ((text (.text info))
300               (info (clone info #:text '()))
301
302               (a-jump ((test->jump->info info) a))
303               (a-text (.text (a-jump 0)))
304               (a-length (length (text->list a-text)))
305
306               (b-jump ((test->jump->info info) b))
307               (b-text (.text (b-jump 0)))
308               (b-length (length (text->list b-text))))
309
310          (lambda (body-length)
311            (clone info #:text
312                   (append text
313                           (.text (a-jump (+ b-length body-length)))
314                           (.text (b-jump body-length)))))))
315       ((array-ref . _) ((jump i386:jump-byte-z) o))
316       ((de-ref _) ((jump i386:jump-byte-z) o))
317       (_ ((jump i386:jump-z) o)))))
318
319 (define (cstring->number s)
320   (if (string-prefix? "0" s) (string->number s 8)
321       (string->number s)))
322
323 (define (ast->info info)
324   (lambda (o)
325     (let ((globals (.globals info))
326           (locals (.locals info))
327           (text (.text info)))
328       (define (add-local name)
329         (let ((locals (acons name (1+ (length (filter positive? (map cdr locals)))) locals)))
330           locals))
331
332       ;;(stderr "\nS=~a\n" o)
333       ;; (stderr "  text=~a\n" text)
334       ;; (stderr "   info=~a\n" info)
335       ;; (stderr "   globals=~a\n" globals)
336       (pmatch o
337         (((trans-unit . _) . _) ((ast-list->info info) o))
338         ((trans-unit . ,elements) ((ast-list->info info) elements))
339         ((fctn-defn . _) ((function->info info) o))
340         ((comment . _) info)
341         ((cpp-stmt (define (name ,name) (repl ,value)))
342          (stderr "SKIP: #define ~s ~s\n" name value)
343          info)
344
345         ;; ;
346         ((expr-stmt) info)
347
348         ((compd-stmt (block-item-list . ,statements)) ((ast-list->info info) statements))
349         
350         ((expr-stmt (fctn-call (p-expr (ident ,name)) (expr-list . ,expr-list)))
351          (if (equal? name "asm") (let ((arg0 (cadr (cadar expr-list)))) ;; FIXME
352                                    (clone info #:text (append text (list (lambda (f g t d) (asm->hex arg0))))))
353              (let* ((globals (append globals (filter-map expr->global expr-list)))
354                     (info (clone info #:globals globals))
355                     (args (map (expr->arg info) expr-list)))
356                (clone info #:text
357                       (append text (list (lambda (f g t d)
358                                            (apply i386:call (cons* f g t d
359                                                                    (+ t (function-offset name f)) args)))))
360                       #:globals globals))))
361
362         ((if ,test ,body)
363          (let* ((text-length (length text))
364
365                 (test-jump->info ((test->jump->info info) test))
366                 (test+jump-info (test-jump->info 0))
367                 (test-length (length (.text test+jump-info)))
368
369                 (body-info ((ast->info test+jump-info) body))
370                 (text-body-info (.text body-info))
371                 (body-text (list-tail text-body-info test-length))
372                 (body-length (length (text->list body-text)))
373
374                 (text+test-text (.text (test-jump->info body-length)))
375                 (test-text (list-tail text+test-text text-length)))
376
377            (clone info #:text
378                   (append text
379                           test-text
380                           body-text)
381                   #:globals (.globals body-info))))
382
383         ((for ,init ,test ,step ,body)
384          (let* ((jump (pmatch test
385                         ((lt ,a ,b) i386:jump-c)
386                         ((gt ,a ,b) i386:jump-c)
387                         (_ i386:jump-nz)))
388                 (jump-text (lambda (body-length)
389                              (list (lambda (f g t d) (jump body-length)))))
390
391                 (info (clone info #:text '()))
392
393                 (info ((ast->info info) init))
394
395                 (init-text (.text info))
396                 (init-locals (.locals info))
397                 (info (clone info #:text '()))
398
399                 (body-info ((ast->info info) body))
400                 (body-text (.text body-info))
401                 (body-length (length (text->list body-text)))
402
403                 (step-info ((ast->info info) `(expr-stmt ,step)))
404                 (step-text (.text step-info))
405                 (step-length (length (text->list step-text)))
406
407                 (test-info ((ast->info info) test))
408                 (test-text (.text test-info))
409                 (test-length (length (text->list test-text))))
410
411            (clone info #:text
412                   (append text
413                           init-text
414                           (list (lambda (f g t d) (i386:jump (+ 2 body-length)))) ;; FIXME: 2
415                           body-text
416                           step-text
417                           test-text
418                           (jump-text (- (+ body-length step-length test-length))))
419                   #:globals (append globals (.globals body-info)) ;; FIXME
420                   #:locals locals)))
421
422         ((while ,test ,body)
423          (let* ((info (clone info #:text '()))
424                 (body-info ((ast->info info) body))
425                 (body-text (.text body-info))
426                 (body-length (length (text->list body-text)))
427
428                 (test-jump->info ((test->jump->info info) test))
429                 (test+jump-info (test-jump->info 0))
430                 (test-length (length (text->list (.text test+jump-info))))
431
432
433                 (skip-body-text (list (lambda (f g t d) (i386:jump (+ 2 body-length))))) ;; FIXME: 2
434
435                 (jump-text (list (lambda (f g t d) (i386:jump (- (+ body-length test-length))))))
436                 (jump-length (length (text->list jump-text)))
437
438                 (test-text (.text (test-jump->info jump-length))))
439
440            (clone info #:text
441                   (append text
442                           skip-body-text
443                           body-text
444                           test-text
445                           jump-text)
446                   #:globals (.globals body-info))))
447
448         ((labeled-stmt (ident ,label) ,statement)
449          (let ((info (clone info #:text (append text (list label)))))
450            ((ast->info info) statement)))
451
452         ((goto (ident ,label))
453          (let ((offset (length (text->list text))))
454            (clone info #:text
455                   (append text
456                           (list (lambda (f g t d)
457                                   (i386:jump (- (label-offset (.function info) label f) offset))))))))
458
459         ((p-expr (ident ,name))
460          (clone info #:text
461                 (append text
462                         (list (lambda (f g t d)
463                                 (append
464                                  (i386:local->accu (assoc-ref locals name))
465                                  (i386:accu-zero?)))))))
466
467         ((p-expr (fixed ,value))
468          (let ((value (cstring->number value)))
469           (clone info #:text
470                  (append text
471                          (list (lambda (f g t d)
472                                  (append
473                                   (i386:value->accu value)
474                                   (i386:accu-zero?))))))))
475
476         ((de-ref (p-expr (ident ,name)))
477          (clone info #:text
478                 (append text
479                         (list (lambda (f g t d)
480                                 (append
481                                  (i386:local->accu (assoc-ref locals name))
482                                  (i386:byte-mem->accu)))))))
483
484         ((fctn-call . ,call)
485          (let ((info ((ast->info info) `(expr-stmt ,o))))
486            (clone info #:text
487                   (append (.text info)
488                           (list (lambda (f g t d)
489                                   (i386:accu-zero?)))))))
490
491         ;; FIXME
492         ;;((post-inc ,expr) ((ast->info info) `(expr-stmt ,o)))
493         ((post-inc (p-expr (ident ,name)))
494          (clone info #:text
495                 (append text (list (lambda (f g t d)
496                                      (append
497                                       (i386:local->accu (assoc-ref locals name))
498                                       (i386:local-add (assoc-ref locals name) 1)
499                                       (i386:accu-zero?)))))))
500         ((post-inc ,expr) ((ast->info info) `(expr-stmt ,o)))
501         ((post-dec ,expr) ((ast->info info) `(expr-stmt ,o)))
502         ((pre-inc ,expr) ((ast->info info) `(expr-stmt ,o)))
503         ((pre-dec ,expr) ((ast->info info) `(expr-stmt ,o)))
504
505         ;; i++
506         ((expr-stmt (post-inc (p-expr (ident ,name))))
507          (clone info #:text
508                 (append text (list (lambda (f g t d)
509                                      (i386:local-add (assoc-ref locals name) 1))))))
510
511         ;; ++i
512         ((expr-stmt (pre-inc (p-expr (ident ,name))))
513          (clone info #:text
514                 (append text (list (lambda (f g t d)
515                                      (append
516                                       (i386:local-add (assoc-ref locals name) 1)
517                                       (i386:local->accu (assoc-ref locals name))
518                                       (i386:accu-zero?)))))))
519
520         ;; i--
521         ((expr-stmt (post-dec (p-expr (ident ,name))))
522          (clone info #:text
523                 (append text (list (lambda (f g t d)
524                                      (append
525                                       (i386:local->accu (assoc-ref locals name))
526                                       (i386:local-add (assoc-ref locals name) -1)
527                                       (i386:accu-zero?)))))))
528
529         ;; --i
530         ((expr-stmt (pre-dec (p-expr (ident ,name))))
531          (clone info #:text
532                 (append text (list (lambda (f g t d)
533                                      (append
534                                       (i386:local-add (assoc-ref locals name) -1)
535                                       (i386:local->accu (assoc-ref locals name))
536                                       (i386:accu-zero?)))))))
537
538         ((not ,expr)
539          (let* ((test-info ((ast->info info) expr)))
540            (clone info #:text
541                   (append (.text test-info)
542                           (list (lambda (f g t d)
543                                   (append
544                                    (i386:accu-not)
545                                    (i386:accu-zero?)))))
546                   #:globals (.globals test-info))))
547
548         ((eq (p-expr (ident ,a)) (p-expr (fixed ,b)))
549          (let ((b (cstring->number b)))
550            (clone info #:text
551                   (append text
552                           ((ident->base info) a)
553                           (list (lambda (f g t d)
554                                   (append
555                                    (i386:value->accu b)
556                                    (i386:sub-base))))))))
557
558         ((eq (p-expr (ident ,a)) (p-expr (char ,b)))
559          (let ((b (char->integer (car (string->list b)))))
560            (clone info #:text
561                   (append text
562                           ((ident->base info) a)
563                           (list (lambda (f g t d)
564                                   (append
565                                    (i386:value->accu b)
566                                    (i386:sub-base))))))))
567
568         ((eq (p-expr (ident ,a)) (neg (p-expr (fixed ,b))))
569          (let ((b (- (cstring->number b))))
570            (clone info #:text
571                   (append text
572                           ((ident->base info) a)
573                           (list (lambda (f g t d)
574                                   (append 
575                                    (i386:value->accu b)
576                                    (i386:sub-base))))))))
577
578         ((eq (fctn-call . ,call) (p-expr (fixed ,b)))
579          (let ((b (cstring->number b))
580                (info ((ast->info info) `(expr-stmt (fctn-call ,@call)))))
581            (clone info #:text
582                   (append text
583                           (.text info)
584                           (list (lambda (f g t d)
585                                   (append
586                                    (i386:value->base b)
587                                    (i386:sub-base))))))))
588
589         ((eq (fctn-call . ,call) (p-expr (char ,b)))
590          (let ((b (char->integer (car (string->list b))))
591                (info ((ast->info info) `(expr-stmt (fctn-call ,@call)))))
592            (clone info #:text
593                   (append text
594                           (.text info)
595                           (list (lambda (f g t d)
596                                   (append
597                                    (i386:value->base b)
598                                    (i386:sub-base))))))))
599
600         ((cast (type-name (decl-spec-list (type-spec (void)))) _)
601          info)
602
603         ((eq (fctn-call . ,call) (p-expr (ident ,b)))
604          (let ((info ((ast->info info) `(expr-stmt (fctn-call ,@call)))))
605            (clone info #:text
606                   (append text
607                           (.text info)
608                           ((ident->base info) b)
609                           (list (lambda (f g t d)
610                                   (append
611                                    (i386:sub-base))))))))
612
613         ((eq (de-ref (p-expr (ident ,a))) (de-ref (p-expr (ident ,b))))
614            (clone info #:text
615                   (append text
616                           (list (lambda (f g t d)
617                                   (append
618                                    (i386:local->accu (assoc-ref locals a))
619                                    (i386:byte-mem->base)
620                                    (i386:local->accu (assoc-ref locals b))
621                                    (i386:byte-mem->accu)
622                                    (i386:byte-test-base)))))))
623
624         ((gt (p-expr (ident ,a)) (p-expr (fixed ,b)))
625          (let ((b (cstring->number b)))
626            (clone info #:text
627                   (append text
628                           ((ident->base info) a)
629                           (list (lambda (f g t d)
630                                   (append 
631                                    (i386:value->accu b)
632                                    (i386:sub-base))))))))
633
634         ((gt (p-expr (ident ,a)) (neg (p-expr (fixed ,b))))
635          (let ((b (- (cstring->number b))))
636            (clone info #:text
637                   (append text
638                           ((ident->base info) a)
639                           (list (lambda (f g t d)
640                                   (append 
641                                    (i386:value->accu b)
642                                    (i386:sub-base))))))))        
643
644         
645         ((ne (p-expr (ident ,a)) (p-expr (fixed ,b)))
646          (let ((b (cstring->number b)))
647            (clone info #:text
648                   (append text
649                           ((ident->base info) a)
650                           (list (lambda (f g t d)
651                                   (append 
652                                    (i386:value->accu b)
653                                    (i386:sub-base)
654                                    (i386:xor-zf))))))))
655         
656         ((ne (p-expr (ident ,a)) (neg (p-expr (fixed ,b))))
657          (let ((b (- (cstring->number b))))
658            (clone info #:text
659                   (append text
660                           ((ident->base info) a)
661                           (list (lambda (f g t d)
662                                   (append
663                                    (i386:value->accu b)
664                                    (i386:sub-base)
665                                    (i386:xor-zf))))))))
666
667         ((ne (fctn-call . ,call) (p-expr (fixed ,b)))
668          (let ((b (cstring->number b))
669                (info ((ast->info info) `(expr-stmt (fctn-call ,@call)))))
670            (clone info #:text
671                   (append text
672                           (.text info)
673                           (list (lambda (f g t d)
674                                   (append
675                                    (i386:value->base b)
676                                    (i386:sub-base)
677                                    (i386:xor-zf))))))))
678
679         ((ne (fctn-call . ,call) (p-expr (ident ,b)))
680          (let ((info ((ast->info info) `(expr-stmt (fctn-call ,@call)))))
681            (clone info #:text
682                   (append text
683                           (.text info)
684                           ((ident->base info) b)
685                           (list (lambda (f g t d)
686                                   (append
687                                    (i386:sub-base)
688                                    (i386:xor-zf))))))))
689
690         ((ne (de-ref (p-expr (ident ,a))) (de-ref (p-expr (ident ,b))))
691            (clone info #:text
692                   (append text
693                           (list (lambda (f g t d)
694                                   (append
695                                    (i386:local->accu (assoc-ref locals a))
696                                    (i386:byte-mem->base)
697                                    (i386:local->accu (assoc-ref locals b))
698                                    (i386:byte-mem->accu)
699                                    (i386:byte-test-base)
700                                    (i386:xor-zf)))))))
701
702         ((lt (p-expr (ident ,a)) (p-expr (fixed ,b)))
703          (let ((b (cstring->number b)))
704            (clone info #:text
705                   (append text
706                           ((ident->base info) a)
707                           (list (lambda (f g t d)
708                                   (append 
709                                    (i386:value->accu b)
710                                    (i386:base-sub))))))))
711
712         ((sub (de-ref (p-expr (ident ,a))) (de-ref (p-expr (ident ,b))))
713          (clone info #:text
714                 (append text
715                         (list (lambda (f g t d)
716                                 (append
717                                  (i386:local->accu (assoc-ref locals a))
718                                  (i386:byte-mem->base)
719                                  (i386:local->accu (assoc-ref locals b))
720                                  (i386:byte-mem->accu)
721                                  (i386:byte-sub-base)))))))
722
723         ((array-ref (p-expr (fixed ,value)) (p-expr (ident ,name)))
724          (let ((value (cstring->number value)))
725            (clone info #:text
726                   (append text
727                           ((ident->base info) name)
728                           (list (lambda (f g t d)
729                                        (append
730                                         (i386:value->accu value)
731                                         (i386:byte-base-mem->accu)))))))) ; FIXME: type: char
732         
733         ((array-ref (p-expr (ident ,name)) (p-expr (ident ,index)))
734          (clone info #:text
735                 (append text
736                         ((ident->base info) name)
737                         ((ident->accu info) index)
738                         (list (lambda (f g t d)
739                                 (i386:byte-base-mem->accu)))))) ; FIXME: type: char
740         
741         ((return ,expr)
742          (let ((accu ((expr->accu info) expr)))
743            (if (info? accu)
744                (clone accu #:text
745                       (append (.text accu) (list (i386:ret (lambda _ '())))))
746                (clone info #:text
747                       (append text (list (i386:ret accu)))))))
748
749         ;; int i;
750         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name))))
751          (clone info #:locals (add-local name)))
752
753         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (fixed ,value))))))
754          (let* ((locals (add-local name))
755                 (info (clone info #:locals locals)))
756            (let ((value (cstring->number value)))
757              (clone info #:text
758                     (append text ((value->ident info) name value))))))
759
760         ;; int i = argc;
761         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (ident ,local))))))
762          (let* ((locals (add-local name))
763                 (info (clone info #:locals locals)))
764            (clone info #:text
765                   (append text
766                           ((ident->accu info) local)
767                           ((accu->ident info) name)))))
768
769         ;; char *p = "t.c";
770         ;;(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"))))))
771         ((decl (decl-spec-list (type-spec (fixed-type _))) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (p-expr (string ,value))))))
772          (let* ((locals (add-local name))
773                 (globals (append globals (list (string->global value))))
774                 (info (clone info #:locals locals #:globals globals)))
775            (clone info #:text
776                   (append text
777                           (list (lambda (f g t d)
778                                   (append
779                                    (i386:global->accu (+ (data-offset value g) d)))))
780                           ((accu->ident info) name)))))
781         
782         ;; SCM g_stack = 0;
783         ((decl (decl-spec-list (type-spec (typename _))) (init-declr-list (init-declr (ident _) (initzer (p-expr (fixed _))))) (comment _))
784          ((ast->info info) (list-head o (- (length o) 1))))
785
786         ((decl (decl-spec-list (type-spec (typename _))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (fixed ,value))))))
787          (if (.function info)
788              (let* ((locals (add-local name))
789                     (globals (append globals (list (string->global value))))
790                     (info (clone info #:locals locals #:globals globals)))
791                (clone info #:text
792                       (append text
793                               (list (lambda (f g t d)
794                                       (append
795                                        (i386:global->accu (+ (data-offset value g) d)))))
796                               ((accu->ident info) name))))
797              (let* ((value (length (globals->data globals)))
798                     (globals (append globals (list (ident->global name value)))))
799                (clone info #:globals globals))))
800
801         ;; SCM i = argc;
802         ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (ident ,local))))))
803          (let* ((locals (add-local name))
804                (info (clone info #:locals locals)))
805            (clone info #:text
806                   (append text
807                           ((ident->accu info) local)
808                           ((accu->ident info) name)))))
809         
810         ;; int i = f ();
811         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (fctn-call . ,call)))))
812          (let* ((locals (add-local name))
813                 (info (clone info #:locals locals)))
814            (let ((info ((ast->info info) `(expr-stmt (fctn-call ,@call)))))
815              (clone info
816                     #:text
817                     (append (.text info)
818                             ((accu->ident info) name))
819                     #:locals locals))))
820         
821         ;; SCM x = car (e);
822         ((decl (decl-spec-list (type-spec (typename _))) (init-declr-list (init-declr (ident ,name) (initzer (fctn-call . ,call)))))
823          (let* ((locals (add-local name))
824                 (info (clone info #:locals locals)))
825            (let ((info ((ast->info info) `(expr-stmt (fctn-call ,@call)))))
826              (clone info
827                     #:text
828                     (append (.text info)
829                             ((accu->ident info) name))))))
830
831         ;; i = 0;
832         ((expr-stmt (assn-expr (p-expr (ident ,name)) (op _) (p-expr (fixed ,value))))
833          ;;(stderr "RET LOCAL[~a]: ~a\n" name (assoc-ref locals name))
834          (let ((value (cstring->number value)))
835            (clone info #:text (append text ((value->ident info) name value)))))
836
837         ;; i = 0; ...from for init FIXME
838         ((assn-expr (p-expr (ident ,name)) (op _) (p-expr (fixed ,value)))
839          (let ((value (cstring->number value)))
840            (clone info #:text (append text ((value->ident info) name value)))))
841
842         ((expr-stmt (assn-expr (p-expr (ident ,name)) (op _) (fctn-call . ,call)))
843          (let* ((info ((ast->info info) `(expr-stmt (fctn-call ,@call)))))
844            (clone info #:text (append (.text info) ((accu->ident info) name)))))
845
846         (_
847          (format (current-error-port) "SKIP statement=~s\n" o)
848          info)))))
849
850 (define (info->exe info)
851   (display "dumping elf\n" (current-error-port))
852   (map write-any (make-elf (.functions info) (.globals info))))
853
854 (define (.formals o)
855   (pmatch o
856     ((fctn-defn _ (ftn-declr _ ,formals) _) formals)
857     ((fctn-defn _ (ptr-declr (pointer) (ftn-declr _ ,formals)) _) formals)
858     (_ (format (current-error-port) ".formals: no match: ~a\n" o)
859        barf)))
860
861 (define (formal->text n)
862   (lambda (o i)
863     ;;(i386:formal i n)
864     '()
865     ))
866
867 (define (formals->text o)
868   (pmatch o
869     ((param-list . ,formals)
870      (let ((n (length formals)))
871        (list (lambda (f g t d)
872                (append
873                 (i386:function-preamble)
874                 (append-map (formal->text n) formals (iota n))
875                 (i386:function-locals))))))
876     (_ (format (current-error-port) "formals->text: no match: ~a\n" o)
877        barf)))
878
879 (define (formals->locals o)
880   (pmatch o
881     ((param-list . ,formals)
882      (let ((n (length formals)))
883        ;;(stderr "FORMALS: ~a ==> ~a\n" formals n)
884        (map cons (map .name formals) (iota n -2 -1))))
885     (_ (format (current-error-port) "formals->info: no match: ~a\n" o)
886        barf)))
887
888 (define (function->info info)
889   (lambda (o)
890     ;;(stderr "\n")
891     ;;(stderr "formals=~a\n" (.formals o))
892     (let* ((name (.name o))
893            (text (formals->text (.formals o)))
894            (locals (formals->locals (.formals o))))
895       (format (current-error-port) "compiling ~a\n" name)
896       ;;(stderr "locals=~a\n" locals)
897       (let loop ((statements (.statements o))
898                  (info (clone info #:locals locals #:function name #:text text)))
899         (if (null? statements) (clone info
900                                       #:function #f
901                                       #:functions (append (.functions info) (list (cons (.name o) (.text info)))))
902             (let* ((statement (car statements)))
903               (loop (cdr statements)
904                     ((ast->info info) (car statements)))))))))
905
906 (define (ast-list->info info)
907   (lambda (elements)
908     (let loop ((elements elements) (info info))
909       (if (null? elements) info
910           (loop (cdr elements) ((ast->info info) (car elements)))))))
911
912 (define _start
913   (let* ((argc-argv
914           (string-append ".byte"
915                          " 0x89 0xe8"      ; mov    %ebp,%eax
916                          " 0x83 0xc0 0x08" ; add    $0x8,%eax
917                          " 0x50"           ; push   %eax
918                          " 0x89 0xe8"      ; mov    %ebp,%eax
919                          " 0x83 0xc0 0x04" ; add    $0x4,%eax
920                          " 0x0f 0xb6 0x00" ; movzbl (%eax),%eax
921                          " 0x50"           ; push   %eax
922                          ))
923          (ast (with-input-from-string
924                   
925                   (string-append "int _start () {int i;asm(\"" argc-argv "\");i=main ();exit (i);}")
926                 parse-c99)))
927     ast))
928
929 (define strlen
930   (let* ((ast (with-input-from-string
931                   "
932 int
933 strlen (char const* s)
934 {
935   int i = 0;
936   while (s[i]) i++;
937   return i;
938 }
939 "
940 ;;paredit:"
941                 parse-c99)))
942     ast))
943
944 (define eputs
945   (let* ((ast (with-input-from-string
946                   "
947 int
948 eputs (char const* s)
949 {
950   //write (STDERR, s, strlen (s));
951   //write (2, s, strlen (s));
952   int i = strlen (s);
953   write (2, s, i);
954   return 0;
955 }
956 "
957 ;;paredit:"
958                 parse-c99)))
959     ast))
960
961 (define fputs
962   (let* ((ast (with-input-from-string
963                   "
964 int
965 fputs (char const* s, int fd)
966 {
967  int i = strlen (s);
968   write (fd, s, i);
969   return 0;
970 }
971 "
972 ;;paredit:"
973                 parse-c99)))
974     ast))
975
976 (define puts
977   (let* ((ast (with-input-from-string
978                   "
979 int
980 puts (char const* s)
981 {
982   //write (STDOUT, s, strlen (s));
983   //int i = write (STDOUT, s, strlen (s));
984   int i = strlen (s);
985   write (1, s, i);
986   return 0;
987 }
988 "
989 ;;paredit:"
990                 parse-c99)))
991     ast))
992
993 (define strcmp
994   (let* ((ast (with-input-from-string
995                   "
996 int
997 strcmp (char const* a, char const* b)
998 {
999   while (*a && *b && *a == *b) 
1000     {
1001       a++;b++;
1002     }
1003   return *a - *b;
1004 }
1005 "
1006 ;;paredit:"
1007                 parse-c99)))
1008     ast))
1009
1010 (define i386:libc
1011   (list
1012    (cons "exit" (list i386:exit))
1013    (cons "write" (list i386:write))))
1014
1015 (define libc
1016   (list
1017    strlen
1018    eputs
1019    fputs
1020    puts
1021    strcmp))
1022
1023 (define (compile)
1024   (let* ((ast (mescc))
1025          (info (make <info> #:functions i386:libc))
1026          (info ((ast->info info) libc))
1027          (info ((ast->info info) ast))
1028          (info ((ast->info info) _start)))
1029     (info->exe info)))