0b8721b4c6cfafa2e28cba490d9e945fa11e52bf
[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: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       ((sub . _) ((ast->info info) o)) ;; FIXME: expr-stmt
193       (_
194        (format (current-error-port) "SKIP expr->accu=~a\n" o)
195        0)
196       )))
197
198 (define (string->global string)
199   (cons string (append (string->list string) (list #\nul))))
200
201 (define (expr->global o)
202   (pmatch o
203     ((p-expr (string ,string)) (string->global string))
204     (_ #f)))
205
206 (define (dec->hex o)
207   (number->string o 16))
208
209 (define (byte->hex o)
210   (string->number (string-drop o 2) 16))
211
212 (define (asm->hex o)
213   (let ((prefix ".byte "))
214     (if (not (string-prefix? prefix o)) (begin (stderr "SKIP:~a\n" o)'())
215         (let ((s (string-drop o (string-length prefix))))
216           (map byte->hex (string-split s #\space))))))
217
218 (define (ast->info info)
219   (lambda (o)
220     (let ((globals (.globals info))
221           (locals (.locals info))
222           (text (.text info)))
223       (define (add-local name)
224          (acons name (1+ (or (and=> (member 1 (map cdr locals)) length) 0)) locals))
225
226       ;; (stderr "\nS=~a\n" o)
227       ;; (stderr "  text=~a\n" text)
228       ;; (stderr "   info=~a\n" info)
229       ;; (stderr "   globals=~a\n" globals)
230       (pmatch o
231         (((trans-unit . _) . _) ((ast-list->info info) o))
232         ((trans-unit . ,elements) ((ast-list->info info) elements))
233         ((fctn-defn . _) ((function->info info) o))
234         ((comment . _) info)
235         ((cpp-stmt (define (name ,name) (repl ,value)))
236          (stderr "SKIP: #define ~s ~s\n" name value)
237          info)
238
239         ((compd-stmt (block-item-list . ,statements)) ((ast-list->info info) statements))
240         
241         ((expr-stmt (fctn-call (p-expr (ident ,name)) (expr-list . ,expr-list)))
242          (if (equal? name "asm") (let ((arg0 (cadr (cadar expr-list)))) ;; FIXME
243                                    (clone info #:text (append text (list (lambda (f g t d) (asm->hex arg0))))))
244              (let* ((globals (append globals (filter-map expr->global expr-list)))
245                     (args (map (expr->arg globals locals) expr-list)))
246                (clone info #:text
247                       (append text (list (lambda (f g t d)
248                                            (apply i386:call (cons* f g t d
249                                                                    (+ t (function-offset name f)) args)))))
250                       #:globals globals))))
251
252         ((if ,test ,body)
253          (let* ((jump (pmatch test
254                         ((lt ,a ,b) i386:jump-nc)
255                         ((gt ,a ,b) i386:jump-nc)
256                         (_ i386:jump-z)))
257                 (jump-text (lambda (body-length)
258                              (list (lambda (f g t d) (jump body-length)))))
259                 (test-info ((ast->info info) test))
260                 (test+jump-info (clone test-info #:text (append (.text test-info)
261                                                                 (jump-text 0))))
262                 (text-length (length (.text test+jump-info)))
263                 (body-info ((ast->info test+jump-info) body))
264                 (body-text (list-tail (.text body-info) text-length))
265                 (body-length (length (text->list body-text))))
266
267            (clone info #:text
268                   (append (.text test-info)
269                           (jump-text body-length)
270                           body-text)
271                   #:globals (.globals body-info))))
272
273         ((for ,init ,test ,step ,body)
274          (let* ((jump (pmatch test
275                         ((lt ,a ,b) i386:jump-c)
276                         ((gt ,a ,b) i386:jump-c)
277                         (_ i386:jump-nz)))
278                 (jump-text (lambda (body-length)
279                              (list (lambda (f g t d) (jump body-length)))))
280
281                 (info (clone info #:text '()))
282
283                 (info ((ast->info info) init))
284
285                 (init-text (.text info))
286                 (init-locals (.locals info))
287                 (info (clone info #:text '()))
288
289                 (body-info ((ast->info info) body))
290                 (body-text (.text body-info))
291                 (body-length (length (text->list body-text)))
292
293                 (step-info ((ast->info info) `(expr-stmt ,step)))
294                 (step-text (.text step-info))
295                 (step-length (length (text->list step-text)))
296
297                 (test-info ((ast->info info) test))
298                 (test-text (.text test-info))
299                 (test-length (length (text->list test-text))))
300
301            (clone info #:text
302                   (append text
303                           init-text
304                           (list (lambda (f g t d) (i386:jump (+ 2 body-length)))) ;; FIXME: 2
305                           body-text
306                           step-text
307                           test-text
308                           (jump-text (- (+ body-length step-length test-length))))
309                   #:globals (append globals (.globals body-info)) ;; FIXME
310                   #:locals locals)))
311
312         ((while ,test ,body)
313          (let* ((jump (pmatch test
314                         ((lt ,a ,b) i386:jump-c)
315                         ((gt ,a ,b) i386:jump-c)
316                         ;;(_ i386:jump-nz)
317                         (_ i386:jump-byte-nz) ;; FIXME
318                         ))
319                 (jump-text (lambda (body-length)
320                              (list (lambda (f g t d) (jump body-length)))))
321
322                 (info (clone info #:text '()))
323                 (body-info ((ast->info info) body))
324                 (body-text (.text body-info))
325                 (body-length (length (text->list body-text)))
326
327                 (test-info ((ast->info info) test))
328                 (test-text (.text test-info))
329                 (test-length (length (text->list test-text))))
330
331            (clone info #:text
332                   (append text
333                           (list (lambda (f g t d) (i386:jump (+ 2 body-length)))) ;; FIXME: 2
334                           body-text
335                           test-text
336                           (jump-text (- (+ body-length test-length))))
337                   #:globals (.globals body-info))))
338
339         ((labeled-stmt (ident ,label) ,statement)
340          (let ((info (clone info #:text (append text (list label)))))
341            ((ast->info info) statement)))
342
343         ((goto (ident ,label))
344          (let ((offset (length (text->list text))))
345            (clone info #:text
346                   (append text
347                           (list (lambda (f g t d)
348                                   (i386:jump (- (label-offset (.function info) label f) offset))))))))
349
350         ((p-expr (ident ,name))
351          (clone info #:text
352                 (append text
353                         (list (lambda (f g t d)
354                                 (append
355                                  (i386:local->accu (assoc-ref locals name))
356                                  (i386:accu-zero?)))))))
357
358         ((p-expr (fixed ,value))
359          (let ((value (string->number value)))
360           (clone info #:text
361                  (append text
362                          (list (lambda (f g t d)
363                                  (append (i386:value->accu value)
364                                          (i386:accu-zero?))))))))
365
366         ((de-ref (p-expr (ident ,name)))
367          (clone info #:text
368                 (append text
369                         (list (lambda (f g t d)
370                                 (append (i386:local->accu (assoc-ref locals name))
371                                         (i386:byte-mem->accu)))))))
372
373         ((fctn-call . ,call)
374          (let ((info ((ast->info info) `(expr-stmt ,o))))
375            (clone info #:text
376                   (append (.text info)
377                           (list (lambda (f g t d)
378                                   (i386:accu-zero?)))))))
379
380         ;; i++
381         ((expr-stmt (post-inc (p-expr (ident ,name))))
382          (clone info #:text
383                 (append text (list (lambda (f g t d)
384                                      (i386:local-add (assoc-ref locals name) 1))))))
385
386         ;; ++i -- same for now FIXME
387         ((expr-stmt (pre-inc (p-expr (ident ,name))))
388          (clone info #:text
389                 (append text (list (lambda (f g t d)
390                                      (i386:local-add (assoc-ref locals name) 1))))))
391
392         ((not ,expr)
393          (let* ((test-info ((ast->info info) expr)))
394            (clone info #:text
395                   (append (.text test-info)
396                           (list (lambda (f g t d)
397                                   (i386:xor-zf))))
398                   #:globals (.globals test-info))))
399
400         ((and ,a ,b)
401          (let* ((info (clone info #:text '()))
402                 (a-info ((ast->info info) a))
403                 (a-text (.text a-info))
404                 (a-length (length (text->list a-text)))
405
406                 (b-info ((ast->info info) b))
407                 (b-text (.text b-info))
408                 (b-length (length (text->list b-text))))
409
410            (clone info #:text
411                   (append text
412                           a-text
413                           (list (lambda (f g t d) (i386:jump-byte-z (+ b-length
414                                                                        2))))  ;; FIXME: need jump after last test
415                           b-text))))
416
417         ;; FIXME and, gt
418         ((eq (de-ref (p-expr (ident ,a))) (de-ref (p-expr (ident ,b))))
419            (clone info #:text
420                   (append text
421                           (list (lambda (f g t d)
422                                   (append
423                                    (append (i386:local->accu (assoc-ref locals a))
424                                            (i386:byte-mem->base)
425                                            (i386:local->accu (assoc-ref locals b))
426                                            (i386:byte-mem->accu)
427                                            (i386:byte-test-base))))))))
428
429         ((gt (p-expr (ident ,a)) (p-expr (fixed ,b)))
430          ;; (stderr "GT: ~a > ~a\n" a b)
431          (let ((b (string->number b)))
432            (clone info #:text
433                   (append text
434                           (list (lambda (f g t d)
435                                   (append 
436                                    (i386:local->base (assoc-ref locals a))
437                                    (i386:value->accu b)
438                                    (i386:sub-base))))))))
439
440         
441         ((eq (p-expr (ident ,a)) (p-expr (fixed ,b)))
442          ;;(stderr "EQ: ~a > ~a\n" a b)
443          (let ((b (string->number b)))
444            (clone info #:text
445                   (append text
446                           (list (lambda (f g t d)
447                                   (append 
448                                    (i386:local->base (assoc-ref locals a))
449                                    (i386:value->accu b)
450                                    (i386:sub-base)
451                                    (i386:xor-zf))))))))
452
453         
454         ((ne (p-expr (ident ,a)) (p-expr (fixed ,b)))
455          ;;(stderr "NE: ~a > ~a\n" a b)
456          (let ((b (string->number b)))
457            (clone info #:text
458                   (append text
459                           (list (lambda (f g t d)
460                                   (append 
461                                    (i386:local->base (assoc-ref locals a))
462                                    (i386:value->accu b)
463                                    (i386:sub-base))))))))
464         
465         ((lt (p-expr (ident ,a)) (p-expr (fixed ,b)))
466          ;;(stderr "LT: ~a < ~a\n" a b)
467          (let ((b (string->number b)))
468            (clone info #:text
469                   (append text
470                           (list (lambda (f g t d)
471                                   (append 
472                                    (i386:local->base (assoc-ref locals a))
473                                    (i386:value->accu b)
474                                    (i386:base-sub))))))))
475
476         ((sub (de-ref (p-expr (ident ,a))) (de-ref (p-expr (ident ,b))))
477          (clone info #:text
478                 (append text
479                         (list (lambda (f g t d)
480                                 (append (i386:local->accu (assoc-ref locals a))
481                                         (i386:byte-mem->base)
482                                         (i386:local->accu (assoc-ref locals b))
483                                         (i386:byte-mem->accu)
484                                         (i386:byte-sub-base)))))))
485
486         ((array-ref (p-expr (fixed ,value)) (p-expr (ident ,name)))
487          (let ((value (string->number value)))
488            (clone info #:text
489                   (append text (list (lambda (f g t d)
490                                        (append
491                                         ((ident->base locals) name)
492                                         (i386:value->accu value)
493                                         (i386:byte-mem->accu)))))))) ; FIXME: type: char
494         
495         ((array-ref (p-expr (ident ,name)) (p-expr (ident ,index)))
496          (clone info #:text
497                 (append text (list (lambda (f g t d)
498                                      (append
499                                       ((ident->base locals) name)
500                                       ((ident->accu locals) index)
501                                       (i386:byte-mem->accu))))))) ; FIXME: type: char
502         
503         ((return ,expr)
504          (let ((accu ((expr->accu info) expr)))
505            (if (info? accu)
506                (clone accu #:text
507                       (append (.text accu) (list (i386:ret (lambda _ '())))))
508                (clone info #:text
509                       (append text (list (i386:ret ((expr->accu info) expr))))))))
510
511         ;; int i;
512         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name))))
513          (clone info #:locals (add-local name)))
514
515         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (fixed ,value))))))
516          (let ((locals (add-local name)))
517            (let ((value (string->number value)))
518              (clone info #:text
519                     (append text (list (lambda (f g t d)
520                                        (i386:local-assign (assoc-ref locals name) value))))
521                   #:locals locals))))
522
523         ;; int i = argc;
524         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (ident ,local))))))
525          (let ((locals (add-local name)))
526           (clone info #:text
527                  (append text (list (lambda (f g t d)
528                                       (append
529                                        ((ident->accu locals) local)
530                                        ((accu->ident locals) name)))))
531                  #:locals locals)))
532
533         ;; SCM i = argc;
534         ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (ident ,local))))))
535          (let ((locals (add-local name)))
536            (clone info #:text
537                 (append text (list (lambda (f g t d)
538                                      (append
539                                       ((ident->accu locals) local)
540                                       ((accu->ident locals) name)))))
541                 #:locals locals)))
542         
543         ;; int i = f ();
544         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (fctn-call . ,call)))))
545          (let* ((locals (add-local name))
546                 (info (clone info #:locals locals)))
547            (let ((info ((ast->info info) `(expr-stmt (fctn-call ,@call)))))
548              (clone info
549                     #:text
550                     (append (.text info)
551                             (list (lambda (f g t d)
552                                     (i386:ret-local (assoc-ref locals name)))))
553                     #:locals locals))))
554         
555         ;; i = 0;
556         ((expr-stmt (assn-expr (p-expr (ident ,name)) (op _) (p-expr (fixed ,value))))
557          ;;(stderr "RET LOCAL[~a]: ~a\n" name (assoc-ref locals name))
558          (let ((value (string->number value)))
559            (clone info #:text (append text (list (lambda (f g t d) (i386:local-assign (assoc-ref locals name) value)))))))
560
561         ;; i = 0; ...from for init FIXME
562         ((assn-expr (p-expr (ident ,name)) (op _) (p-expr (fixed ,value)))
563          (let ((value (string->number value)))
564            (clone info #:text (append text (list (lambda (f g t d) (i386:local-assign (assoc-ref locals name) value)))))))
565         
566         ((expr-stmt (assn-expr (p-expr (ident ,name)) (op _) (fctn-call . ,call)))
567          (let* ((info ((ast->info info) `(expr-stmt (fctn-call ,@call)))))
568            (clone info #:text (append (.text info) (list (lambda (f g t d) (i386:ret-local (assoc-ref locals name))))))))
569
570         (_
571          (format (current-error-port) "SKIP statement=~s\n" o)
572          info)))))
573
574 (define (info->exe info)
575   (display "dumping elf\n" (current-error-port))
576   (map write-any (make-elf (.functions info) (.globals info))))
577
578 (define (.formals o)
579   (pmatch o
580     ((fctn-defn _ (ftn-declr _ ,formals) _) formals)
581     ((fctn-defn _ (ptr-declr (pointer) (ftn-declr _ ,formals)) _) formals)
582     (_ (format (current-error-port) ".formals: no match: ~a\n" o)
583        barf)))
584
585 (define (formal->text n)
586   (lambda (o i)
587     ;;(i386:formal i n)
588     '()
589     ))
590
591 (define (formals->text o)
592   (pmatch o
593     ((param-list . ,formals)
594      (let ((n (length formals)))
595        (list (lambda (f g t d)
596                (append
597                 (i386:function-preamble)
598                 (append-map (formal->text n) formals (iota n))
599                 (i386:function-locals))))))
600     (_ (format (current-error-port) "formals->text: no match: ~a\n" o)
601        barf)))
602
603 (define (formals->locals o)
604   (pmatch o
605     ((param-list . ,formals)
606      (let ((n (length formals)))
607        ;;(stderr "FORMALS: ~a ==> ~a\n" formals n)
608        (map cons (map .name formals) (iota n -2 -1))))
609     (_ (format (current-error-port) "formals->info: no match: ~a\n" o)
610        barf)))
611
612 (define (function->info info)
613   (lambda (o)
614     ;;(stderr "\n")
615     ;;(stderr "formals=~a\n" (.formals o))
616     (let* ((name (.name o))
617            (text (formals->text (.formals o)))
618            (locals (formals->locals (.formals o))))
619       (format (current-error-port) "compiling ~a\n" name)
620       ;;(stderr "locals=~a\n" locals)
621       (let loop ((statements (.statements o))
622                  (info (clone info #:locals locals #:function name #:text text)))
623         (if (null? statements) (clone info
624                                       #:function #f
625                                       #:functions (append (.functions info) (list (cons (.name o) (.text info)))))
626             (let* ((statement (car statements)))
627               (loop (cdr statements)
628                     ((ast->info info) (car statements)))))))))
629
630 (define (ast-list->info info)
631   (lambda (elements)
632     (let loop ((elements elements) (info info))
633       (if (null? elements) info
634           (loop (cdr elements) ((ast->info info) (car elements)))))))
635
636 (define _start
637   (let* ((argc-argv
638           (string-append ".byte"
639                          " 0x89 0xe8"      ; mov    %ebp,%eax
640                          " 0x83 0xc0 0x08" ; add    $0x8,%eax
641                          " 0x50"           ; push   %eax
642                          " 0x89 0xe8"      ; mov    %ebp,%eax
643                          " 0x83 0xc0 0x04" ; add    $0x4,%eax
644                          " 0x0f 0xb6 0x00" ; movzbl (%eax),%eax
645                          " 0x50"           ; push   %eax
646                          ))
647          (ast (with-input-from-string
648                   
649                   (string-append "int _start () {int i;asm(\"" argc-argv "\");i=main ();exit (i);}")
650                 parse-c99)))
651     ast))
652
653 (define strlen
654   (let* ((ast (with-input-from-string
655                   "
656 int
657 strlen (char const* s)
658 {
659   int i = 0;
660   while (s[i]) i++;
661   return i;
662 }
663 "
664 ;;paredit:"
665                 parse-c99)))
666     ast))
667
668 (define eputs
669   (let* ((ast (with-input-from-string
670                   "
671 int
672 eputs (char const* s)
673 {
674   //write (STDERR, s, strlen (s));
675   //write (2, s, strlen (s));
676   int i = strlen (s);
677   write (2, s, i);
678   return 0;
679 }
680 "
681 ;;paredit:"
682                 parse-c99)))
683     ast))
684
685 (define fputs
686   (let* ((ast (with-input-from-string
687                   "
688 int
689 fputs (char const* s, int fd)
690 {
691  int i = strlen (s);
692   write (fd, s, i);
693   return 0;
694 }
695 "
696 ;;paredit:"
697                 parse-c99)))
698     ast))
699
700 (define puts
701   (let* ((ast (with-input-from-string
702                   "
703 int
704 puts (char const* s)
705 {
706   //write (STDOUT, s, strlen (s));
707   //int i = write (STDOUT, s, strlen (s));
708   int i = strlen (s);
709   write (1, s, i);
710   return 0;
711 }
712 "
713 ;;paredit:"
714                 parse-c99)))
715     ast))
716
717 (define strcmp
718   (let* ((ast (with-input-from-string
719                   "
720 int
721 strcmp (char const* a, char const* b)
722 {
723   while (*a && *b && *a == *b) 
724     {
725       a++;b++;
726     }
727   return *a - *b;
728 }
729 "
730 ;;paredit:"
731                 parse-c99)))
732     ast))
733
734 (define i386:libc
735   (list
736    (cons "exit" (list i386:exit))
737    (cons "write" (list i386:write))))
738
739 (define libc
740   (list
741    strlen
742    eputs
743    fputs
744    puts
745    strcmp))
746
747 (define (compile)
748   (let* ((ast (mescc))
749          (info (make <info> #:functions i386:libc))
750          (info ((ast->info info) libc))
751          (info ((ast->info info) ast))
752          (info ((ast->info info) _start)))
753     (info->exe info)))