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