d60332b59a3aa0ad108f46b8aea132dd78a7b562
[mes.git] / module / language / c99 / compiler.mes
1 ;;; -*-scheme-*-
2
3 ;;; Mes --- Maxwell Equations of Software
4 ;;; Copyright © 2016 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
30    (set-port-encoding! (current-output-port) "ISO-8859-1"))
31   (mes
32    (mes-use-module (nyacc lang c99 parser))
33    (mes-use-module (mes pmatch))
34    (mes-use-module (mes elf))
35    (mes-use-module (mes libc-i386))))
36
37 (define (mescc)
38   (parse-c99 #:inc-dirs '()))
39
40 (define (write-any x)
41   (write-char (if (char? x) x (integer->char (if (>= x 0) x (+ x 256))))))
42
43 (define (ast:function? o)
44   (and (pair? o) (eq? (car o) 'fctn-defn)))
45
46 (define (.name o)
47   (pmatch o
48     ((fctn-defn _ (ftn-declr (ident ,name) _) _) name)))
49
50 (define (.statements o)
51   (pmatch o
52     ((fctn-defn _ (ftn-declr (ident ,name) _) (compd-stmt (block-item-list . ,statements))) statements)))
53
54 (define (statement->data o)
55   (pmatch o
56     ((expr-stmt (fctn-call (p-expr (ident ,name))
57                            (expr-list (p-expr (string ,string)))))
58      (string->list string))
59     ((for (decl (decl-spec-list (type-spec (fixed-type ,type)))
60                   (init-declr-list (init-declr (ident ,identifier)
61                                                (initzer (p-expr (fixed ,start))))))
62             (lt (p-expr (ident _)) (p-expr (fixed ,test)))
63             ,step ;;(pre-inc (p-expr (ident i)))
64             ,statement)
65      (statement->data statement))
66     (_ '())))
67
68 (define (statement->text data o)
69   (let ((offset (length data)))
70     (pmatch o
71       ((expr-stmt (fctn-call (p-expr (ident ,name))
72                              (expr-list (p-expr (string ,string)))))
73        (list (lambda (data) (i386:puts (+ data offset) (string-length string)))))
74       ((for (decl (decl-spec-list (type-spec (fixed-type ,type)))
75                   (init-declr-list (init-declr (ident ,identifier)
76                                                (initzer (p-expr (fixed ,start))))))
77             (lt (p-expr (ident _)) (p-expr (fixed ,test)))
78             ,step ;;(pre-inc (p-expr (ident i)))
79             ,statement)
80        (display "start:" (current-error-port))
81        (display start (current-error-port))
82        (newline (current-error-port))
83
84        (display "test:" (current-error-port))
85        (display test (current-error-port))
86        (newline (current-error-port))
87
88        ;; (display "step:" (current-error-port))
89        ;; (display step (current-error-port))
90        ;; (newline (current-error-port))
91        ;; 
92        (display "for-statement:" (current-error-port))
93        (display statement (current-error-port))
94        (newline (current-error-port))
95
96        (let ((start (string->number start))
97              (test (string->number test))
98              (step 1)
99              (statement (car (statement->text data statement))))
100          
101          (display "2start:" (current-error-port))
102          (display start (current-error-port))
103          (newline (current-error-port))
104
105          (display "2for-statement:" (current-error-port))
106          (display statement (current-error-port))
107          (newline (current-error-port))
108
109          (list (lambda (d) (i386:for start test step (statement d))))))
110
111       ((return (p-expr (fixed ,value)))
112        (let ((value (string->number value)))
113         (list (lambda (data) (i386:exit value)))))
114       (_ '()))))
115
116 (define (function->text+data o)
117   (let loop ((statements (.statements o)) (text '()) (data '()))
118     (display "text:" (current-error-port))
119     (display text (current-error-port))
120     (newline (current-error-port))
121     (if (null? statements) (values text data)
122         (let* ((statement (car statements)))
123           (display "statement:" (current-error-port))
124           (display statement (current-error-port))
125           (newline (current-error-port))
126           (loop (cdr statements)
127                 (append text (statement->text data statement))
128                 (append data (statement->data statement)))))))
129
130 (define (text+data->exe text data)
131   (display "dumping to a.out:\n" (current-error-port))
132   (map write-any (make-elf (lambda (data)
133                              (append-map (lambda (f) (f data)) text)) data)))
134
135 (define (compile)
136   (let* ((ast (mescc))
137          (functions (filter ast:function? (cdr ast)))
138          (main (find (lambda (x) (equal? (.name x) "main")) functions)))
139     (display "AST" (current-error-port))
140     (pretty-print ast (current-error-port))
141     (format (current-error-port) "functions~a\n" functions)
142     (format (current-error-port) "main~a\n" main)
143     (call-with-values
144         (lambda () (function->text+data main))
145       text+data->exe)))