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