5458356c7074a83c72c0f4e9279e0d35826ffb7d
[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-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 (gnuc-xdef? name mode) (if (equal? name "__GNUC__") #f (env? mode 'code)))
40 ;;(define (gnuc-xdef? name mode) (equal? name "__GNUC__"))
41 (define (gnuc-xdef? name mode)
42   (cond ((equal? name "__GNUC__") #t)
43         ((equal? name "asm") #f)))
44
45 (define (mescc)
46   (parse-c99 #:inc-dirs (string-split (getenv "C_INCLUDE_PATH") #\:)
47              #:cpp-defs '(("__GNUC__" . "0"))
48              #:xdef? gnuc-xdef?))
49
50 (define (write-any x)
51   (write-char (if (char? x) x (integer->char (if (>= x 0) x (+ x 256))))))
52
53 (define (ast:function? o)
54   (and (pair? o) (eq? (car o) 'fctn-defn)))
55
56 (define (.name o)
57   (pmatch o
58     ((fctn-defn _ (ftn-declr (ident ,name) _) _) name)))
59
60 (define (.statements o)
61   (pmatch o
62     ((fctn-defn _ (ftn-declr (ident ,name) _) (compd-stmt (block-item-list . ,statements))) statements)))
63
64 (define (expr->arg symbols) ;; FIXME: get Mes curried-definitions
65   (lambda (o)
66     (pmatch o
67       ((p-expr (fixed ,value)) (string->number value))
68       ((p-expr (string ,string)) (data-offset symbols string))
69       (_
70        (format (current-error-port) "SKIPPING expr=~a\n" o)     
71        0))))
72
73 (define (expr->symbols o)
74   (pmatch o
75     ((p-expr (string ,string)) (string->symbols string))
76     (_ #f)))
77
78 (define make-text+symbols cons)
79 (define .text car)
80 (define .symbols cdr)
81
82 (define (dec->hex o)
83   (number->string o 16))
84
85 (define (statement->text+symbols text+symbols)
86   (lambda (o)
87     (let* ((text (.text text+symbols))
88            (symbols (.symbols text+symbols))
89            (text-list (append-map (lambda (f) (f '() 0 0)) text))
90            (prefix-list (symbols->text symbols 0 0))
91            (statement-offset (- (+ (length prefix-list) (length text-list)))))
92       (pmatch o
93         ((expr-stmt (fctn-call (p-expr (ident ,name))
94                                (expr-list (p-expr (string ,string)))))
95          (make-text+symbols
96           (append text
97                   (list (lambda (s t d)
98                           (i386:call (+ t
99                                                       (function-offset name s)
100                                                       statement-offset)
101                                                    (+ d (data-offset string s))))))
102           (append symbols (list (string->symbols string)))));; FIXME: ->symbolSXX
103         
104         ((expr-stmt (fctn-call (p-expr (ident ,name)) (expr-list . ,expr-list)))
105          (let ((args (map (expr->arg symbols) expr-list)))
106            (make-text+symbols
107             (append text
108                     (list (lambda (s t d) (apply i386:call (cons (+ t (function-offset name s) statement-offset) args)))))
109             (append symbols (filter-map expr->symbols expr-list)))))
110         
111         ((return (p-expr (fixed ,value)))
112          (let ((value (string->number value)))
113            (make-text+symbols (append text (list (lambda _ (i386:ret)))) symbols)))
114
115        (_
116         (format (current-error-port) "SKIPPING S=~a\n" o)
117         text+symbols)))))
118
119 (define (symbols->exe symbols)
120   (display "dumping elf\n" (current-error-port))
121   (map write-any (make-elf symbols)))
122
123 (define (.formals o)
124   (pmatch o
125     ((fctn-defn _ (ftn-declr _ ,formals) _) formals)
126     (_ (format (current-error-port) ".formals: no match: ~a\n" o)
127        barf)))
128
129 (define (formal->text o)
130   '(#x58))  ;; pop %eax
131
132 (define (formals->text o)
133   (pmatch o
134     ((param-list . ,formals)
135      (list (lambda (s t d)
136              (append
137               '(#x5f) ;; pop %edi
138               (append-map formal->text formals)
139               '(#x57) ;; push %edi
140               ))))
141     (_ (format (current-error-port) "formals->text+data: no match: ~a\n" o)
142        barf)))
143
144 (define (string->symbols string)
145   (make-data string (string->list string)))
146
147 (define (function->symbols symbols)
148   (lambda (o)
149     (format (current-error-port) "compiling ~a\n" (.name o))
150     (let* ((text (formals->text (.formals o)))
151            (text-offset (length (symbols->text symbols 0 0))))
152       (let loop ((statements (.statements o))
153                  (text+symbols (make-text+symbols text symbols)))
154         (if (null? statements) (append (.symbols text+symbols) (list (make-function (.name o) (.text text+symbols))))
155             (let* ((statement (car statements)))
156               (loop (cdr statements)
157                     ((statement->text+symbols text+symbols) (car statements)))))))))
158
159 (define _start
160   (let* ((ast (with-input-from-string
161                   "int _start () {main(0,0);exit (0);}"
162                 parse-c99))
163          (functions (filter ast:function? (cdr ast))))
164     (list (find (lambda (x) (equal? (.name x) "_start")) functions))))
165
166 (define libc
167   (list
168    (make-function "eputs" (list i386:eputs))
169    (make-function "exit" (list i386:exit))
170    (make-function "puts" (list i386:puts))))
171
172 (define (compile)
173   (let* ((ast (mescc))
174          (functions (filter ast:function? (cdr ast)))
175          (functions (append functions _start)))
176     (let loop ((functions functions) (symbols libc))
177       (if (null? functions) (symbols->exe symbols)
178           (loop (cdr functions) ((function->symbols symbols) (car functions)))))))