2cd88d7ce2f882ee6831ec99affd3d34ab201653
[mes.git] / module / language / c / compiler.mes
1 ;;; -*-scheme-*-
2
3 ;;; Mes --- Maxwell Equations of Software
4 ;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
5 ;;;
6 ;;; compiler.mes: 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 ;;; c-parser.
25
26 ;;; Code:
27
28 (define mescc
29   (let ((errorp
30          (lambda args
31            (for-each display args)
32              (newline))))
33     (lambda ()
34       (c-parser (c-lexer errorp) errorp))))
35
36 (define (write-any x) (write-char (if (char? x) x (integer->char (if (>= x 0) x (+ x 256))))))
37
38 (define (ast:function? o)
39   (and (pair? o) (eq? (car o) 'function)))
40
41 (define (.name o)
42   (cadr o))
43
44 ;; (define (.statement o)
45 ;;   (match o
46 ;;     (('function name signature statement) statement)
47 ;;     (_ #f)))
48
49 ;; (define (statement->data o)
50 ;;   (match o
51 ;;     (('call 'puts ('arguments string)) (string->list string))
52 ;;     (_ '())))
53
54 ;; (define (statement->text o)
55 ;;   (match o
56 ;;     (('call 'puts ('arguments string)) (list (lambda (data) (i386:puts data (string-length string)))))
57 ;;     (('return code) (list (lambda (data) (i386:exit code))))
58 ;;     (_ '())))
59
60 (define (.statement o)
61   (and (pair? o)
62        (eq? (car o) 'function)
63        (cadddr o)))
64
65 (define (statement->data o)
66   (or (and (pair? o)
67            (eq? (car o) 'call)
68            (string->list (cadr (caddr o))))
69       (and (pair? o) (eq? (car o) 'for)
70            (let ((statement (cadr (cdddr o))))
71              (statement->data statement)))
72       '()))
73
74 (define (statement->text data o)
75   (cond
76    ((and (pair? o) (eq? (car o) 'call))
77     (let ((string (cadr (caddr o)))
78           (offset (length data)))
79       (list (lambda (data) (i386:puts (+ data offset) (string-length string))))))
80    ((and (pair? o) (eq? (car o) 'for))
81     (let ((start (cadr o))
82           (test (caddr o))
83           (step (cadddr o))
84           (statement (cadr (cdddr o))))
85       (display "start:" (current-error-port))
86       (display start (current-error-port))
87       (newline (current-error-port))
88
89       (display "test:" (current-error-port))
90       (display test (current-error-port))
91       (newline (current-error-port))
92
93       (display "step:" (current-error-port))
94       (display step (current-error-port))
95       (newline (current-error-port))
96
97       (display "for-statement:" (current-error-port))
98       (display statement (current-error-port))
99       (newline (current-error-port))
100
101       (let ((start (cadr (cdadr start)))
102             (test (cadr (cdadr test)))
103             ;;(step (cadr (cdadr step)))
104             (step 1)
105             (statement (car (statement->text data statement)))
106             )
107         (display "2start:" (current-error-port))
108         (display start (current-error-port))
109         (newline (current-error-port))
110
111       (display "2for-statement:" (current-error-port))
112       (display statement (current-error-port))
113       (newline (current-error-port))
114
115         (list (lambda (d) (i386:for start test step (statement d)))))))
116    ((and (pair? o) (eq? (car o) 'return))
117     (list (lambda (data) (i386:exit (cadr o)))))
118    (else '())))
119
120 (define (compile)
121   (let* ((ast (mescc))
122          (functions (filter ast:function? (cdr ast)))
123          (main (find (lambda (x) (eq? (.name x) 'main)) functions))
124          (statements (cdr (.statement main))))
125     (display "program: " (current-error-port))
126     (display ast (current-error-port))
127     (newline (current-error-port))
128     (let loop ((statements statements) (text '()) (data '()))
129       (display "text:" (current-error-port))
130       (display text (current-error-port))
131       (newline (current-error-port))
132       (if (null? statements)
133           (begin
134             (display "dumping to a.out:\n" (current-error-port))
135             (map write-any (make-elf (lambda (data)
136                                        (append-map (lambda (f) (f data)) text)) data)))
137           (let* ((statement (car statements)))
138             (display "statement:" (current-error-port))
139             (display statement (current-error-port))
140             (newline (current-error-port))
141             (loop (cdr statements)
142                   (append text (statement->text data statement))
143                   (append data (statement->data statement))))))))
144