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