62963605eee1e56e595e726ead87577b868f1616
[mes.git] / module / language / c99 / compiler.mes
1 ;;; -*-scheme-*-
2
3 ;;; Mes --- Maxwell Equations of Software
4 ;;; Copyright © 2016,2017 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 (eq? 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") ("__NYACC__" . "1"))
48              #:xdef? gnuc-xdef?
49              #:mode 'code
50              ))
51
52 (define (write-any x)
53   (write-char (if (char? x) x (integer->char (if (>= x 0) x (+ x 256))))))
54
55 (define (ast:function? o)
56   (and (pair? o) (eq? (car o) 'fctn-defn)))
57
58 (define (.name o)
59   (pmatch o
60     ((fctn-defn _ (ftn-declr (ident ,name) _) _) name)
61     ((fctn-defn _ (ptr-declr (pointer) (ftn-declr (ident ,name) _)) _) name)))
62
63 (define (.statements o)
64   (pmatch o
65     ((fctn-defn _ (ftn-declr (ident ,name) _) (compd-stmt (block-item-list . ,statements))) statements)
66     ((fctn-defn _ (ptr-declr (pointer) (ftn-declr (ident ,name) _)) (compd-stmt (block-item-list . ,statements))) statements)))
67
68 (define (expr->arg symbols) ;; FIXME: get Mes curried-definitions
69   (lambda (o)
70     (pmatch o
71       ((p-expr (fixed ,value)) (string->number value))
72       ((p-expr (string ,string)) (data-offset symbols string))
73       (_
74        (format (current-error-port) "SKIPPING expr=~a\n" o)     
75        0))))
76
77 (define (expr->symbols o)
78   (pmatch o
79     ((p-expr (string ,string)) (string->symbols string))
80     (_ #f)))
81
82 (define make-text+symbols cons)
83 (define .text car)
84 (define .symbols cdr)
85
86 (define (dec->hex o)
87   (number->string o 16))
88
89 (define (statement->text+symbols text+symbols)
90   (lambda (o)
91     (let* ((text (.text text+symbols))
92            (symbols (.symbols text+symbols))
93            (text-list (append-map (lambda (f) (f '() 0 0)) text))
94            (prefix-list (symbols->text symbols 0 0))
95            (statement-offset (- (+ (length prefix-list) (length text-list)))))
96       (pmatch o
97         ((expr-stmt (fctn-call (p-expr (ident ,name))
98                                (expr-list (p-expr (string ,string)))))
99          (make-text+symbols
100           (append text
101                   (list (lambda (s t d)
102                           (i386:call (+ t
103                                                       (function-offset name s)
104                                                       statement-offset)
105                                                    (+ d (data-offset string s))))))
106           (append symbols (list (string->symbols string)))));; FIXME: ->symbolSXX
107         
108         ((expr-stmt (fctn-call (p-expr (ident ,name)) (expr-list . ,expr-list)))
109          (let ((args (map (expr->arg symbols) expr-list)))
110            (make-text+symbols
111             (append text
112                     (list (lambda (s t d) (apply i386:call (cons (+ t (function-offset name s) statement-offset) args)))))
113             (append symbols (filter-map expr->symbols expr-list)))))
114         
115         ((return (p-expr (fixed ,value)))
116          (let ((value (string->number value)))
117            (make-text+symbols (append text (list (lambda _ (i386:ret value)))) symbols)))
118
119        (_
120         (format (current-error-port) "SKIPPING S=~a\n" o)
121         text+symbols)))))
122
123 (define (symbols->exe symbols)
124   (display "dumping elf\n" (current-error-port))
125   (map write-any (make-elf symbols)))
126
127 (define (.formals o)
128   (pmatch o
129     ((fctn-defn _ (ftn-declr _ ,formals) _) formals)
130     ((fctn-defn _ (ptr-declr (pointer) (ftn-declr _ ,formals)) _) formals)
131     (_ (format (current-error-port) ".formals: no match: ~a\n" o)
132        barf)))
133
134 (define (formal->text n)
135   (lambda (o i)
136     (case i
137       ((0) (list #x8b #x5d (* n 4)))          ; mov    $00(%ebp),%ebx
138       ((1) (list #x8b #x4d (* (- n 1) 4)))    ; mov    $00(%ebp),%ecx
139       ((2) (list #x8b #x55 (* (- n 2) 4)))    ; mov    $00(%ebp),%edx
140       ((3) (list #x8b #x45 (* (- n 3) 4)))))) ; mov    $00(%ebp),%eax FIXME
141
142 (define (formals->text o)
143   (pmatch o
144     ((param-list . ,formals)
145      (let ((n (length formals)))
146        (list (lambda (s t d)
147               (append
148                '(#x55                   ; push   %ebp
149                  #x89 #xe5)             ; mov    %esp,%ebp
150                (append-map (formal->text n) formals (iota n))
151                '(#x83 #xec #x10)        ; sub    $0x10,%esp -- 4 local vars
152                )))))
153     (_ (format (current-error-port) "formals->text+data: no match: ~a\n" o)
154        barf)))
155
156 (define (string->symbols string)
157   (make-data string (string->list string)))
158
159 (define (function->symbols symbols)
160   (lambda (o)
161     (format (current-error-port) "compiling ~a\n" (.name o))
162     (let* ((text (formals->text (.formals o)))
163            (text-offset (length (symbols->text symbols 0 0))))
164       (let loop ((statements (.statements o))
165                  (text+symbols (make-text+symbols text symbols)))
166         (if (null? statements) (append (.symbols text+symbols) (list (make-function (.name o) (.text text+symbols))))
167             (let* ((statement (car statements)))
168               (loop (cdr statements)
169                     ((statement->text+symbols text+symbols) (car statements)))))))))
170
171 (define _start
172   (let* ((ast (with-input-from-string
173                   "int _start () {main(0,0);exit (0);}"
174                 parse-c99))
175          (functions (filter ast:function? (cdr ast))))
176     (list (find (lambda (x) (equal? (.name x) "_start")) functions))))
177
178 (define libc
179   (list
180    (make-function "eputs" (list i386:eputs))
181    (make-function "exit" (list i386:exit))
182    (make-function "puts" (list i386:puts))))
183
184 (define (compile)
185   (let* ((ast (mescc))
186          (functions (filter ast:function? (cdr ast)))
187          (functions (append functions _start)))
188     (let loop ((functions functions) (symbols libc))
189       (if (null? functions) (symbols->exe symbols)
190           (loop (cdr functions) ((function->symbols symbols) (car functions)))))))