mescc: Formals, local variables.
[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        (format (current-error-port) "SKIP expr->arg=~a\n" o)     
98        0))))
99
100 (define (ident->accu locals)
101   (lambda (o)
102     (i386:local->accu (assoc-ref locals o))))
103
104 (define (ident->base locals)
105   (lambda (o)
106     (i386:local->base (assoc-ref locals o))))
107
108 ;; (define (global-accu symbols)
109 ;;   (lambda (o)
110 ;;     (lambda (s t d)
111 ;;       (i386:accu-global (+ (data-offset o symbols) d)))))
112
113 (define (expr->accu symbols locals)
114   (lambda (o)
115     (pmatch o
116       ((p-expr (fixed ,value)) (string->number value))
117       ((p-expr (ident ,name)) ((ident->accu locals) name))
118       (_
119        (format (current-error-port) "SKIP expr-accu=~a\n" o)
120        0)
121       )))
122
123 (define (expr->symbols o)
124   (pmatch o
125     ((p-expr (string ,string)) (string->symbols string))
126     (_ #f)))
127
128 (define make-text+symbols+locals cons*)
129 (define .text car)
130 (define .symbols cadr)
131 (define .locals cddr)
132
133 (define (dec->hex o)
134   (number->string o 16))
135
136 (define (text->list o)
137   (append-map (lambda (f) (f '() 0 0)) o))
138
139 (define (statement->text+symbols+locals text+symbols+locals)
140   (lambda (o)
141     ;;(stderr "S=~a\n" o)
142     (let* ((text (.text text+symbols+locals))
143            (symbols (.symbols text+symbols+locals))
144            (locals (.locals text+symbols+locals))
145            (text-list (text->list text))
146            (prefix-list (symbols->text symbols 0 0))
147            (statement-offset (- (+ (length prefix-list) (length text-list)))))
148       ;; (stderr "   tsl=~a\n" text+symbols+locals)
149       ;; (stderr "   locals=~s\n" locals)
150       (pmatch o
151         ((expr-stmt (fctn-call (p-expr (ident ,name))
152                                (expr-list (p-expr (string ,string)))))
153          ;;(stderr "S1 string=~a\n" string)
154          (make-text+symbols+locals
155           (append text
156                   (list (lambda (s t d)
157                           (i386:call s t d
158                                      (+ t (function-offset name s)
159                                           statement-offset)
160                                      (+ d (data-offset string s))))))
161           (append symbols (list (string->symbols string)))
162           locals))
163         
164         ((expr-stmt (fctn-call (p-expr (ident ,name)) (expr-list . ,expr-list)))
165          ;;(stderr "S1 expr-list=~a\n" expr-list)
166          (let* ((symbols (append symbols (filter-map expr->symbols expr-list)))
167                 (args (map (expr->arg symbols locals) expr-list)))
168            (make-text+symbols+locals
169             (append text
170                     (list (lambda (s t d) (apply i386:call (cons* s t d (+ t (function-offset name s) statement-offset) args)))))
171             symbols
172             locals)))
173         
174         ((while ,test ,body)
175          (let* ((t+s+l (make-text+symbols+locals '() symbols locals))
176
177                 (body-t+s+l ((statement->text+symbols+locals t+s+l) body))
178                 (body-text (.text body-t+s+l))
179                 ;;(body-symbols (.symbols body-t+s+l))
180                 (symbols (.symbols body-t+s+l))
181                 (body-locals (.locals body-t+s+l))
182                 (body-length (length (text->list body-text)))
183
184                 (test-t+s+l ((statement->text+symbols+locals t+s+l) test))
185                 (test-text (.text test-t+s+l))
186                 (test-symbols (.symbols test-t+s+l))
187                 (test-locals (.locals test-t+s+l))
188                 (test-length (length (text->list test-text))))
189
190            (make-text+symbols+locals
191             (append text
192                     (list (lambda (s t d) (i386:jump body-length)))
193                     body-text
194                     test-text
195                     (list (lambda (s t d) (i386:test-jump (- (+ body-length test-length))))))
196             symbols
197             locals)))
198
199         ((array-ref (p-expr (ident ,name)) (p-expr (ident ,index)))
200          (make-text+symbols+locals
201           (append
202            text
203            (list
204             (lambda (s t d)
205               (append
206                ((ident->base locals) name)
207                ((ident->accu locals) index)
208                (i386:mem-byte->accu)))))
209           symbols
210           locals))
211          
212         ((expr-stmt (post-inc (p-expr (ident ,name))))
213          (make-text+symbols+locals
214           (append text
215                   (list (lambda (s t d) (i386:local-add (assoc-ref locals name) 1))))
216           symbols
217           locals))
218
219         ((return ,expr)
220            (make-text+symbols+locals
221             (append text (list (i386:ret ((expr->accu symbols locals) expr))))
222             symbols
223             locals))
224
225         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name))))
226          (let ((locals (acons name (1+ (or (and=> (member 1 (map cdr locals)) length) 0)) locals)))
227            (make-text+symbols+locals text symbols locals)))
228
229         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (fixed ,value))))))
230          (let ((locals (acons name (1+ (or (and=> (member 1 (map cdr locals)) length) 0)) locals))
231                (value (string->number value)))
232            (make-text+symbols+locals
233             (append
234              text
235              (list (lambda (s t d) (i386:local-assign (assoc-ref locals name) value))))
236             symbols
237             locals)))
238
239         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (fctn-call . ,call)))))
240          (let ((locals (acons name (1+ (or (and=> (member 1 (map cdr locals)) length) 0)) locals)))
241            (let* ((t+s+l (make-text+symbols+locals text symbols locals))
242                   (t+s+l ((statement->text+symbols+locals t+s+l)
243                           `(expr-stmt (fctn-call ,@call))))
244                   (text (.text t+s+l))
245                   (symbols (.symbols t+s+l))
246                   (locals (.locals t+s+l)))
247              (make-text+symbols+locals
248               (append
249                text
250                (list (lambda (s t d) (i386:ret-local (assoc-ref locals name)))))
251               symbols
252               locals))))
253         
254         ((expr-stmt (assn-expr (p-expr (ident ,name)) (op _) (p-expr (fixed ,value))))
255
256          (stderr "RET LOCAL[~a]: ~a\n" name (assoc-ref locals name))
257
258          (let ((value (string->number value)))
259            (make-text+symbols+locals
260             (append text (list (lambda (s t d) (i386:local-assign (assoc-ref locals name) value))))
261             symbols
262             locals)))
263         
264         ((expr-stmt (assn-expr (p-expr (ident ,name)) (op _) (fctn-call . ,call)))
265          (let* ((t+s+l ((statement->text+symbols+locals text+symbols+locals)
266                         `(expr-stmt (fctn-call ,@call))))
267                 (text (.text t+s+l))
268                 (symbols (.symbols t+s+l))
269                 (locals (.locals t+s+l)))
270            (make-text+symbols+locals
271             (append text (list (lambda (s t d) (i386:ret-local (assoc-ref locals name)))))
272             symbols
273             locals)))
274
275        (_
276         (format (current-error-port) "SKIP statement=~a\n" o)
277         text+symbols+locals)))))
278
279 (define (symbols->exe symbols)
280   (display "dumping elf\n" (current-error-port))
281   (map write-any (make-elf symbols)))
282
283 (define (.formals o)
284   (pmatch o
285     ((fctn-defn _ (ftn-declr _ ,formals) _) formals)
286     ((fctn-defn _ (ptr-declr (pointer) (ftn-declr _ ,formals)) _) formals)
287     (_ (format (current-error-port) ".formals: no match: ~a\n" o)
288        barf)))
289
290 (define (formal->text n)
291   (lambda (o i)
292     ;;(i386:formal i n)
293     '()
294     ))
295
296 (define (formals->text o)
297   (pmatch o
298     ((param-list . ,formals)
299      (let ((n (length formals)))
300        (list (lambda (s t d)
301                (append
302                 (i386:function-preamble)
303                 (append-map (formal->text n) formals (iota n))
304                 (i386:function-locals))))))
305     (_ (format (current-error-port) "formals->text: no match: ~a\n" o)
306        barf)))
307
308 (define (formals->locals o)
309   (pmatch o
310     ((param-list . ,formals)
311      (let ((n (length formals)))
312       (map cons (map .name formals) (iota n (1- (- n))))))
313     (_ (format (current-error-port) "formals->symbols: no match: ~a\n" o)
314        barf)))
315
316 (define (string->symbols string)
317   (make-data string (append (string->list string) (list #\nul))))
318
319 (define (function->symbols symbols)
320   (lambda (o)
321     (format (current-error-port) "compiling ~a\n" (.name o))
322     ;;(stderr "formals=~a\n" (.formals o))
323     (let* ((text (formals->text (.formals o)))
324            (locals (formals->locals (.formals o)))
325            (text-offset (length (symbols->text symbols 0 0))))
326       (let loop ((statements (.statements o))
327                  (text+symbols+locals (make-text+symbols+locals text symbols locals)))
328         (if (null? statements) (append (.symbols text+symbols+locals) (list (make-function (.name o) (.text text+symbols+locals))))
329             (let* ((statement (car statements)))
330               (loop (cdr statements)
331                     ((statement->text+symbols+locals text+symbols+locals) (car statements)))))))))
332
333 (define _start
334   (let* ((ast (with-input-from-string
335                   "int _start () {int i;i=main (0,0);exit (i);}"
336                 parse-c99))
337          (functions (filter ast:function? (cdr ast))))
338     ;;(pretty-print ast (current-error-port))
339     (list (find (lambda (x) (equal? (.name x) "_start")) functions))))
340
341 (define strlen
342   (let* ((ast (with-input-from-string
343                   "
344 int
345 strlen (char const* s)
346 {
347   int i = 0;
348   while (s[i]) i++;
349     return i;
350 }
351 "
352                 parse-c99))
353          (functions (filter ast:function? (cdr ast))))
354     ;;(pretty-print ast (current-error-port))
355     (list (find (lambda (x) (equal? (.name x) "strlen")) functions))))
356
357 (define eputs
358   (let* ((ast (with-input-from-string
359                   "
360 int
361 eputs (char const* s)
362 {
363   //write (STDERR, s, strlen (s));
364   //write (2, s, strlen (s));
365   int i = strlen (s);
366   write (2, s, i);
367   return 0;
368 }
369 "
370                 parse-c99))
371          (functions (filter ast:function? (cdr ast))))
372     ;;(pretty-print ast (current-error-port))
373     (list (find (lambda (x) (equal? (.name x) "eputs")) functions))))
374
375 (define fputs
376   (let* ((ast (with-input-from-string
377                   "
378 int
379 fputs (char const* s, int fd)
380 {
381   int i = strlen (s);
382   write (fd, s, i);
383   return 0;
384 }
385 "
386                 parse-c99))
387          (functions (filter ast:function? (cdr ast))))
388     ;;(pretty-print ast (current-error-port))
389     (list (find (lambda (x) (equal? (.name x) "fputs")) functions))))
390
391 (define puts
392   (let* ((ast (with-input-from-string
393                   "
394 int
395 puts (char const* s)
396 {
397   //write (STDERR, s, strlen (s));
398   //int i = write (STDERR, s, strlen (s));
399   int i = strlen (s);
400   write (1, s, i);
401   return 0;
402 }
403 "
404                 parse-c99))
405          (functions (filter ast:function? (cdr ast))))
406     ;;(pretty-print ast (current-error-port))
407     (list (find (lambda (x) (equal? (.name x) "puts")) functions))))
408
409 (define i386:libc
410   (list
411    (make-function "exit" (list i386:exit))
412    (make-function "write" (list i386:write))))
413
414 (define libc
415   (append
416    strlen
417    eputs
418    fputs
419    puts))
420
421 (define (compile)
422   (let* ((ast (mescc))
423          (functions (filter ast:function? (cdr ast)))
424          (functions (append libc functions _start)))
425     (let loop ((functions functions) (symbols i386:libc))
426       (if (null? functions) (symbols->exe symbols)
427           (loop (cdr functions) ((function->symbols symbols) (car functions)))))))