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