mescc: Have micro-mes print argv.
[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
39 (define (logf port string . rest)
40   (apply format (cons* port string rest))
41   (force-output port)
42   #t)
43
44 (define (stderr string . rest)
45   (apply logf (cons* (current-error-port) string rest)))
46
47 (define (gnuc-xdef? name mode) (if (equal? name "__GNUC__") #f (eq? mode 'code)))
48 ;;(define (gnuc-xdef? name mode) (equal? name "__GNUC__"))
49 ;; (define (gnuc-xdef? name mode)
50 ;;   (cond ((equal? name "__GNUC__") #t)
51 ;;         ((equal? name "asm") #f)))
52
53 (define (mescc)
54   (parse-c99 #:inc-dirs (string-split (getenv "C_INCLUDE_PATH") #\:)
55              #:cpp-defs '(("__GNUC__" . "0") ("__NYACC__" . "1"))
56              #:xdef? gnuc-xdef?
57              #:mode 'code
58              ))
59
60 (define (write-any x)
61   (write-char (if (char? x) x (integer->char (if (>= x 0) x (+ x 256))))))
62
63 (define (ast:function? o)
64   (and (pair? o) (eq? (car o) 'fctn-defn)))
65
66 (define (.name o)
67   (pmatch o
68     ((fctn-defn _ (ftn-declr (ident ,name) _) _) name)
69     ((fctn-defn _ (ptr-declr (pointer) (ftn-declr (ident ,name) _)) _) name)
70     ((param-decl _ (param-declr (ident ,name))) name)
71     ((param-decl _ (param-declr (ptr-declr (pointer) (ident ,name)))) name)
72     ((param-decl _ (param-declr (ptr-declr (pointer) (array-of (ident ,name))))) name)
73     (_
74      (format (current-error-port) "SKIP .name =~a\n" o))))
75
76 (define (.statements o)
77   (pmatch o
78     ((fctn-defn _ (ftn-declr (ident ,name) _) (compd-stmt (block-item-list . ,statements))) statements)
79     ((fctn-defn _ (ptr-declr (pointer) (ftn-declr (ident ,name) _)) (compd-stmt (block-item-list . ,statements))) statements)))
80
81 (define (ident-ref locals)
82   (lambda (o)
83     ;; (stderr "IDENT REF[~a]: ~a => ~a\n" o (assoc-ref locals o) (i386:ref-local (assoc-ref locals o)))
84     (i386:ref-local (assoc-ref locals o))))
85
86 (define (global-ref symbols)
87   (lambda (o)
88     (lambda (s t d)
89       (i386:ref-global (+ (data-offset o symbols) d)))))
90
91 (define (expr->arg symbols locals) ;; FIXME: get Mes curried-definitions
92   (lambda (o)
93     (pmatch o
94       ((p-expr (fixed ,value)) (string->number value))
95       ((p-expr (string ,string)) ((global-ref symbols) string))
96       ((p-expr (ident ,name)) ((ident-ref locals) name))
97
98       ((array-ref (p-expr (fixed ,value)) (p-expr (ident ,name)))
99        (let ((value (string->number value))
100              (size 4)) ;; FIXME: type: int
101          (lambda (s t d)
102            (append
103             ((ident->base locals) name)
104             (i386:value->accu (* size value)) ;; FIXME: type: int
105             (i386:mem->accu) ;; FIXME: type: int
106             (i386:push-accu) ;; hmm
107             ))))
108
109       (_
110        (format (current-error-port) "SKIP expr->arg=~a\n" o)     
111        0))))
112
113 (define (ident->accu locals)
114   (lambda (o)
115     (i386:local->accu (assoc-ref locals o))))
116
117 (define (accu->ident locals)
118   (lambda (o)
119     (i386:accu->local (assoc-ref locals o))))
120
121 (define (ident->base locals)
122   (lambda (o)
123     (i386:local->base (assoc-ref locals o))))
124
125 ;; (define (global-accu symbols)
126 ;;   (lambda (o)
127 ;;     (lambda (s t d)
128 ;;       (i386:accu-global (+ (data-offset o symbols) d)))))
129
130 (define (expr->accu symbols locals)
131   (lambda (o)
132     (pmatch o
133       ((p-expr (fixed ,value)) (string->number value))
134       ((p-expr (ident ,name)) ((ident->accu locals) name))
135       (_
136        (format (current-error-port) "SKIP expr-accu=~a\n" o)
137        0)
138       )))
139
140 (define (expr->symbols o)
141   (pmatch o
142     ((p-expr (string ,string)) (string->symbols string))
143     (_ #f)))
144
145 (define make-text+symbols+locals cons*)
146 (define .text car)
147 (define .symbols cadr)
148 (define .locals cddr)
149
150 (define (dec->hex o)
151   (number->string o 16))
152
153 (define (text->list o)
154   (append-map (lambda (f) (f '() 0 0)) o))
155
156 (define (byte->hex o)
157   (string->number (string-drop o 2) 16))
158
159 (define (asm->hex o)
160   (let ((prefix ".byte "))
161    (if (not (string-prefix? prefix o)) (begin (stderr "SKIP:~a\n" o)'())
162        (let ((s (string-drop o (string-length prefix))))
163          (map byte->hex (string-split s #\space))))))
164
165 (define (statement->text+symbols+locals text+symbols+locals)
166   (lambda (o)
167     ;;(stderr "S=~a\n" o)
168     (let* ((text (.text text+symbols+locals))
169            (symbols (.symbols text+symbols+locals))
170            (locals (.locals text+symbols+locals))
171            (text-list (text->list text))
172            (prefix-list (symbols->text symbols 0 0))
173            (statement-offset (- (+ (length prefix-list) (length text-list)))))
174       ;; (stderr "   tsl=~a\n" text+symbols+locals)
175       ;; (stderr "   locals=~s\n" locals)
176       (pmatch o
177
178         ((expr-stmt (fctn-call (p-expr (ident ,name))
179                                (expr-list (p-expr (string ,string)))))
180          ;;(stderr "S1 string=~a\n" string)
181          (if (equal? name "asm")
182              (make-text+symbols+locals
183               (append
184                text
185                (list (lambda (s t d) (asm->hex string))))
186               symbols
187               locals)
188              
189              (make-text+symbols+locals
190               (append text
191                       (list (lambda (s t d)
192                               (i386:call s t d
193                                          (+ t (function-offset name s)
194                                               statement-offset)
195                                          (+ d (data-offset string s))))))
196               (append symbols (list (string->symbols string)))
197               locals)))
198         
199         ((expr-stmt (fctn-call (p-expr (ident ,name)) (expr-list . ,expr-list)))
200          ;;(stderr "S1 expr-list=~a\n" expr-list)
201          (let* ((symbols (append symbols (filter-map expr->symbols expr-list)))
202                 (args (map (expr->arg symbols locals) expr-list)))
203            (make-text+symbols+locals
204             (append text
205                     (list (lambda (s t d) (apply i386:call (cons* s t d (+ t (function-offset name s) statement-offset) args)))))
206             symbols
207             locals)))
208         
209         ((while ,test ,body)
210          (let* ((t+s+l (make-text+symbols+locals '() symbols locals))
211
212                 (body-t+s+l ((statement->text+symbols+locals t+s+l) body))
213                 (body-text (.text body-t+s+l))
214                 ;;(body-symbols (.symbols body-t+s+l))
215                 (symbols (.symbols body-t+s+l))
216                 (body-locals (.locals body-t+s+l))
217                 (body-length (length (text->list body-text)))
218
219                 (test-t+s+l ((statement->text+symbols+locals t+s+l) test))
220                 (test-text (.text test-t+s+l))
221                 (test-symbols (.symbols test-t+s+l))
222                 (test-locals (.locals test-t+s+l))
223                 (test-length (length (text->list test-text))))
224
225            (make-text+symbols+locals
226             (append text
227                     (list (lambda (s t d) (i386:jump body-length)))
228                     body-text
229                     test-text
230                     (list (lambda (s t d) (i386:test-jump (- (+ body-length test-length))))))
231             symbols
232             locals)))
233
234         ((array-ref (p-expr (fixed ,value)) (p-expr (ident ,name)))
235          (let ((value (string->number value)))
236            (make-text+symbols+locals
237             (append
238              text
239              (list
240               (lambda (s t d)
241                 (append
242                  ((ident->base locals) name)
243                  (i386:value->accu value)
244                  (i386:mem-byte->accu))))) ; FIXME: type: char
245             symbols
246             locals)))
247         
248         ((array-ref (p-expr (ident ,name)) (p-expr (ident ,index)))
249          (make-text+symbols+locals
250           (append
251            text
252            (list
253             (lambda (s t d)
254               (append
255                ((ident->base locals) name)
256                ((ident->accu locals) index)
257                (i386:mem-byte->accu))))) ; FIXME: type: char
258           symbols
259           locals))
260          
261         ((expr-stmt (post-inc (p-expr (ident ,name))))
262          (make-text+symbols+locals
263           (append text
264                   (list (lambda (s t d) (i386:local-add (assoc-ref locals name) 1))))
265           symbols
266           locals))
267
268         ((return ,expr)
269          (make-text+symbols+locals
270           (append text (list (i386:ret ((expr->accu symbols locals) expr))))
271           symbols
272           locals))
273
274         ;; int i;
275         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name))))
276          (let ((locals (acons name (1+ (or (and=> (member 1 (map cdr locals)) length) 0)) locals)))
277            (make-text+symbols+locals text symbols locals)))
278
279         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (fixed ,value))))))
280          (let ((locals (acons name (1+ (or (and=> (member 1 (map cdr locals)) length) 0)) locals))
281                (value (string->number value)))
282            (make-text+symbols+locals
283             (append
284              text
285              (list (lambda (s t d) (i386:local-assign (assoc-ref locals name) value))))
286             symbols
287             locals)))
288
289         ;; int i = argc;
290         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (ident ,local))))))
291          (let ((locals (acons name (1+ (or (and=> (member 1 (map cdr locals)) length) 0)) locals)))
292            (make-text+symbols+locals
293             (append
294              text
295              (list (lambda (s t d)
296                      (append
297                       ((ident->accu locals) local)
298                       ((accu->ident locals) name)))))
299             symbols
300             locals)))
301         
302         ;; SCM i = argc;
303         ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (ident ,local))))))
304          (let ((locals (acons name (1+ (or (and=> (member 1 (map cdr locals)) length) 0)) locals)))
305            (make-text+symbols+locals
306             (append
307              text
308              (list (lambda (s t d)
309                      (append
310                       ((ident->accu locals) local)
311                       ((accu->ident locals) name)))))
312             symbols
313             locals)))
314         
315         ;; int i = f ();
316         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (fctn-call . ,call)))))
317          (let ((locals (acons name (1+ (or (and=> (member 1 (map cdr locals)) length) 0)) locals)))
318            (let* ((t+s+l (make-text+symbols+locals text symbols locals))
319                   (t+s+l ((statement->text+symbols+locals t+s+l)
320                           `(expr-stmt (fctn-call ,@call))))
321                   (text (.text t+s+l))
322                   (symbols (.symbols t+s+l))
323                   (locals (.locals t+s+l)))
324              (make-text+symbols+locals
325               (append
326                text
327                (list (lambda (s t d) (i386:ret-local (assoc-ref locals name)))))
328               symbols
329               locals))))
330         
331         ;; i = 0;
332         ((expr-stmt (assn-expr (p-expr (ident ,name)) (op _) (p-expr (fixed ,value))))
333          ;;(stderr "RET LOCAL[~a]: ~a\n" name (assoc-ref locals name))
334          (let ((value (string->number value)))
335            (make-text+symbols+locals
336             (append text (list (lambda (s t d) (i386:local-assign (assoc-ref locals name) value))))
337             symbols
338             locals)))
339         
340         ((expr-stmt (assn-expr (p-expr (ident ,name)) (op _) (fctn-call . ,call)))
341          (let* ((t+s+l ((statement->text+symbols+locals text+symbols+locals)
342                         `(expr-stmt (fctn-call ,@call))))
343                 (text (.text t+s+l))
344                 (symbols (.symbols t+s+l))
345                 (locals (.locals t+s+l)))
346            (make-text+symbols+locals
347             (append text (list (lambda (s t d) (i386:ret-local (assoc-ref locals name)))))
348             symbols
349             locals)))
350
351         (_
352          (format (current-error-port) "SKIP statement=~a\n" o)
353          text+symbols+locals)))))
354
355 (define (symbols->exe symbols)
356   (display "dumping elf\n" (current-error-port))
357   (map write-any (make-elf symbols)))
358
359 (define (.formals o)
360   (pmatch o
361     ((fctn-defn _ (ftn-declr _ ,formals) _) formals)
362     ((fctn-defn _ (ptr-declr (pointer) (ftn-declr _ ,formals)) _) formals)
363     (_ (format (current-error-port) ".formals: no match: ~a\n" o)
364        barf)))
365
366 (define (formal->text n)
367   (lambda (o i)
368     ;;(i386:formal i n)
369     '()
370     ))
371
372 (define (formals->text o)
373   (pmatch o
374     ((param-list . ,formals)
375      (let ((n (length formals)))
376        (list (lambda (s t d)
377                (append
378                 (i386:function-preamble)
379                 (append-map (formal->text n) formals (iota n))
380                 (i386:function-locals))))))
381     (_ (format (current-error-port) "formals->text: no match: ~a\n" o)
382        barf)))
383
384 (define (formals->locals o)
385   (pmatch o
386     ((param-list . ,formals)
387      (let ((n (length formals)))
388        ;;(stderr "FORMALS: ~a ==> ~a\n" formals n)
389       (map cons (map .name formals) (iota n -2 -1))))
390     (_ (format (current-error-port) "formals->symbols: no match: ~a\n" o)
391        barf)))
392
393 (define (string->symbols string)
394   (make-data string (append (string->list string) (list #\nul))))
395
396 (define (function->symbols symbols)
397   (lambda (o)
398     ;;(stderr "\n")
399     (format (current-error-port) "compiling ~a\n" (.name o))
400     ;;(stderr "formals=~a\n" (.formals o))
401     (let* ((text (formals->text (.formals o)))
402            (locals (formals->locals (.formals o)))
403            (text-offset (length (symbols->text symbols 0 0))))
404       ;;(stderr "locals=~a\n" locals)
405       (let loop ((statements (.statements o))
406                  (text+symbols+locals (make-text+symbols+locals text symbols locals)))
407         (if (null? statements) (append (.symbols text+symbols+locals) (list (make-function (.name o) (.text text+symbols+locals))))
408             (let* ((statement (car statements)))
409               (loop (cdr statements)
410                     ((statement->text+symbols+locals text+symbols+locals) (car statements)))))))))
411
412 (define _start
413   (let* ((argc-argv
414           (string-append ".byte"
415                          " 0x89 0xe8"      ; mov    %ebp,%eax
416                          " 0x83 0xc0 0x08" ; add    $0x8,%eax
417                          " 0x50"           ; push   %eax
418                          " 0x89 0xe8"      ; mov    %ebp,%eax
419                          " 0x83 0xc0 0x04" ; add    $0x4,%eax
420                          " 0x0f 0xb6 0x00" ; movzbl (%eax),%eax
421                          " 0x50"           ; push   %eax
422                          ))
423          (ast (with-input-from-string
424                   
425                   (string-append "int _start () {int i;asm(\"" argc-argv "\");i=main ();exit (i);}")
426                 parse-c99))
427          (functions (filter ast:function? (cdr ast))))
428     ;;(pretty-print ast (current-error-port))
429     (list (find (lambda (x) (equal? (.name x) "_start")) functions))))
430
431 (define strlen
432   (let* ((ast (with-input-from-string
433                   "
434 int
435 strlen (char const* s)
436 {
437   int i = 0;
438   while (s[i]) i++;
439     return i;
440 }
441 "
442                 parse-c99))
443          (functions (filter ast:function? (cdr ast))))
444     ;;(pretty-print ast (current-error-port))
445     (list (find (lambda (x) (equal? (.name x) "strlen")) functions))))
446
447 (define eputs
448   (let* ((ast (with-input-from-string
449                   "
450 int
451 eputs (char const* s)
452 {
453   //write (STDERR, s, strlen (s));
454   //write (2, s, strlen (s));
455   int i = strlen (s);
456   write (2, s, i);
457   return 0;
458 }
459 "
460                 parse-c99))
461          (functions (filter ast:function? (cdr ast))))
462     ;;(pretty-print ast (current-error-port))
463     (list (find (lambda (x) (equal? (.name x) "eputs")) functions))))
464
465 (define fputs
466   (let* ((ast (with-input-from-string
467                   "
468 int
469 fputs (char const* s, int fd)
470 {
471   int i = strlen (s);
472   write (fd, s, i);
473   return 0;
474 }
475 "
476                 parse-c99))
477          (functions (filter ast:function? (cdr ast))))
478     ;;(pretty-print ast (current-error-port))
479     (list (find (lambda (x) (equal? (.name x) "fputs")) functions))))
480
481 (define puts
482   (let* ((ast (with-input-from-string
483                   "
484 int
485 puts (char const* s)
486 {
487   //write (STDOUT, s, strlen (s));
488   //int i = write (STDOUT, s, strlen (s));
489   int i = strlen (s);
490   write (1, s, i);
491   return 0;
492 }
493 "
494                 parse-c99))
495          (functions (filter ast:function? (cdr ast))))
496     ;;(pretty-print ast (current-error-port))
497     (list (find (lambda (x) (equal? (.name x) "puts")) functions))))
498
499 (define i386:libc
500   (list
501    (make-function "exit" (list i386:exit))
502    (make-function "write" (list i386:write))))
503
504 (define libc
505   (append
506    strlen
507    eputs
508    fputs
509    puts))
510
511 (define (compile)
512   (let* ((ast (mescc))
513          (functions (filter ast:function? (cdr ast)))
514          (functions (append libc functions _start)))
515     (let loop ((functions functions) (symbols i386:libc))
516       (if (null? functions) (symbols->exe symbols)
517           (loop (cdr functions) ((function->symbols symbols) (car functions)))))))