mescc: Formals, local variables.
[mes.git] / module / language / c99 / compiler.mes
index d60332b59a3aa0ad108f46b8aea132dd78a7b562..193c4f60675e3d40d7b5a908d595676a983cabf5 100644 (file)
@@ -1,7 +1,7 @@
 ;;; -*-scheme-*-
 
 ;;; Mes --- Maxwell Equations of Software
-;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
+;;; Copyright © 2016,2017 Jan Nieuwenhuizen <janneke@gnu.org>
 ;;;
 ;;; This file is part of Mes.
 ;;;
 ;;; Code:
 
 (cond-expand
-  (guile
-   (set-port-encoding! (current-output-port) "ISO-8859-1"))
-  (mes
-   (mes-use-module (nyacc lang c99 parser))
-   (mes-use-module (mes pmatch))
-   (mes-use-module (mes elf))
-   (mes-use-module (mes libc-i386))))
+ (guile-2
+  (set-port-encoding! (current-output-port) "ISO-8859-1"))
+ (guile)
+ (mes
+  (mes-use-module (nyacc lang c99 parser))
+  (mes-use-module (mes elf-util))
+  (mes-use-module (mes pmatch))
+  (mes-use-module (mes elf))
+  (mes-use-module (mes libc-i386))))
+
+(define (logf port string . rest)
+  (apply format (cons* port string rest))
+  (force-output port)
+  #t)
+
+(define (stderr string . rest)
+  (apply logf (cons* (current-error-port) string rest)))
+
+(define (gnuc-xdef? name mode) (if (equal? name "__GNUC__") #f (eq? mode 'code)))
+;;(define (gnuc-xdef? name mode) (equal? name "__GNUC__"))
+;; (define (gnuc-xdef? name mode)
+;;   (cond ((equal? name "__GNUC__") #t)
+;;         ((equal? name "asm") #f)))
 
 (define (mescc)
-  (parse-c99 #:inc-dirs '()))
+  (parse-c99 #:inc-dirs (string-split (getenv "C_INCLUDE_PATH") #\:)
+             #:cpp-defs '(("__GNUC__" . "0") ("__NYACC__" . "1"))
+             #:xdef? gnuc-xdef?
+             #:mode 'code
+             ))
 
 (define (write-any x)
   (write-char (if (char? x) x (integer->char (if (>= x 0) x (+ x 256))))))
 
 (define (.name o)
   (pmatch o
-    ((fctn-defn _ (ftn-declr (ident ,name) _) _) name)))
+    ((fctn-defn _ (ftn-declr (ident ,name) _) _) name)
+    ((fctn-defn _ (ptr-declr (pointer) (ftn-declr (ident ,name) _)) _) name)
+    ((param-decl _ (param-declr (ident ,name))) name)
+    ((param-decl _ (param-declr (ptr-declr (pointer) (ident ,name)))) name)
+    ((param-decl _ (param-declr (ptr-declr (pointer) (array-of (ident ,name))))) name)
+    (_
+     (format (current-error-port) "SKIP .name =~a\n" o))))
 
 (define (.statements o)
   (pmatch o
-    ((fctn-defn _ (ftn-declr (ident ,name) _) (compd-stmt (block-item-list . ,statements))) statements)))
+    ((fctn-defn _ (ftn-declr (ident ,name) _) (compd-stmt (block-item-list . ,statements))) statements)
+    ((fctn-defn _ (ptr-declr (pointer) (ftn-declr (ident ,name) _)) (compd-stmt (block-item-list . ,statements))) statements)))
 
-(define (statement->data o)
-  (pmatch o
-    ((expr-stmt (fctn-call (p-expr (ident ,name))
-                           (expr-list (p-expr (string ,string)))))
-     (string->list string))
-    ((for (decl (decl-spec-list (type-spec (fixed-type ,type)))
-                  (init-declr-list (init-declr (ident ,identifier)
-                                               (initzer (p-expr (fixed ,start))))))
-            (lt (p-expr (ident _)) (p-expr (fixed ,test)))
-            ,step ;;(pre-inc (p-expr (ident i)))
-            ,statement)
-     (statement->data statement))
-    (_ '())))
-
-(define (statement->text data o)
-  (let ((offset (length data)))
+(define (ident-ref locals)
+  (lambda (o)
+    (i386:ref-local (assoc-ref locals o))))
+
+(define (global-ref symbols)
+  (lambda (o)
+    (lambda (s t d)
+      (i386:ref-global (+ (data-offset o symbols) d)))))
+
+(define (expr->arg symbols locals) ;; FIXME: get Mes curried-definitions
+  (lambda (o)
     (pmatch o
-      ((expr-stmt (fctn-call (p-expr (ident ,name))
-                             (expr-list (p-expr (string ,string)))))
-       (list (lambda (data) (i386:puts (+ data offset) (string-length string)))))
-      ((for (decl (decl-spec-list (type-spec (fixed-type ,type)))
-                  (init-declr-list (init-declr (ident ,identifier)
-                                               (initzer (p-expr (fixed ,start))))))
-            (lt (p-expr (ident _)) (p-expr (fixed ,test)))
-            ,step ;;(pre-inc (p-expr (ident i)))
-            ,statement)
-       (display "start:" (current-error-port))
-       (display start (current-error-port))
-       (newline (current-error-port))
-
-       (display "test:" (current-error-port))
-       (display test (current-error-port))
-       (newline (current-error-port))
-
-       ;; (display "step:" (current-error-port))
-       ;; (display step (current-error-port))
-       ;; (newline (current-error-port))
-       ;; 
-       (display "for-statement:" (current-error-port))
-       (display statement (current-error-port))
-       (newline (current-error-port))
-
-       (let ((start (string->number start))
-             (test (string->number test))
-             (step 1)
-             (statement (car (statement->text data statement))))
+      ((p-expr (fixed ,value)) (string->number value))
+      ((p-expr (string ,string)) ((global-ref symbols) string))
+      ((p-expr (ident ,name)) ((ident-ref locals) name))
+      (_
+       (format (current-error-port) "SKIP expr->arg=~a\n" o)     
+       0))))
+
+(define (ident->accu locals)
+  (lambda (o)
+    (i386:local->accu (assoc-ref locals o))))
+
+(define (ident->base locals)
+  (lambda (o)
+    (i386:local->base (assoc-ref locals o))))
+
+;; (define (global-accu symbols)
+;;   (lambda (o)
+;;     (lambda (s t d)
+;;       (i386:accu-global (+ (data-offset o symbols) d)))))
+
+(define (expr->accu symbols locals)
+  (lambda (o)
+    (pmatch o
+      ((p-expr (fixed ,value)) (string->number value))
+      ((p-expr (ident ,name)) ((ident->accu locals) name))
+      (_
+       (format (current-error-port) "SKIP expr-accu=~a\n" o)
+       0)
+      )))
+
+(define (expr->symbols o)
+  (pmatch o
+    ((p-expr (string ,string)) (string->symbols string))
+    (_ #f)))
+
+(define make-text+symbols+locals cons*)
+(define .text car)
+(define .symbols cadr)
+(define .locals cddr)
+
+(define (dec->hex o)
+  (number->string o 16))
+
+(define (text->list o)
+  (append-map (lambda (f) (f '() 0 0)) o))
+
+(define (statement->text+symbols+locals text+symbols+locals)
+  (lambda (o)
+    ;;(stderr "S=~a\n" o)
+    (let* ((text (.text text+symbols+locals))
+           (symbols (.symbols text+symbols+locals))
+           (locals (.locals text+symbols+locals))
+           (text-list (text->list text))
+           (prefix-list (symbols->text symbols 0 0))
+           (statement-offset (- (+ (length prefix-list) (length text-list)))))
+      ;; (stderr "   tsl=~a\n" text+symbols+locals)
+      ;; (stderr "   locals=~s\n" locals)
+      (pmatch o
+        ((expr-stmt (fctn-call (p-expr (ident ,name))
+                               (expr-list (p-expr (string ,string)))))
+         ;;(stderr "S1 string=~a\n" string)
+         (make-text+symbols+locals
+          (append text
+                  (list (lambda (s t d)
+                          (i386:call s t d
+                                     (+ t (function-offset name s)
+                                          statement-offset)
+                                     (+ d (data-offset string s))))))
+          (append symbols (list (string->symbols string)))
+          locals))
+        
+        ((expr-stmt (fctn-call (p-expr (ident ,name)) (expr-list . ,expr-list)))
+         ;;(stderr "S1 expr-list=~a\n" expr-list)
+         (let* ((symbols (append symbols (filter-map expr->symbols expr-list)))
+                (args (map (expr->arg symbols locals) expr-list)))
+           (make-text+symbols+locals
+            (append text
+                    (list (lambda (s t d) (apply i386:call (cons* s t d (+ t (function-offset name s) statement-offset) args)))))
+            symbols
+            locals)))
+        
+        ((while ,test ,body)
+         (let* ((t+s+l (make-text+symbols+locals '() symbols locals))
+
+                (body-t+s+l ((statement->text+symbols+locals t+s+l) body))
+                (body-text (.text body-t+s+l))
+                ;;(body-symbols (.symbols body-t+s+l))
+                (symbols (.symbols body-t+s+l))
+                (body-locals (.locals body-t+s+l))
+                (body-length (length (text->list body-text)))
+
+                (test-t+s+l ((statement->text+symbols+locals t+s+l) test))
+                (test-text (.text test-t+s+l))
+                (test-symbols (.symbols test-t+s+l))
+                (test-locals (.locals test-t+s+l))
+                (test-length (length (text->list test-text))))
+
+           (make-text+symbols+locals
+            (append text
+                    (list (lambda (s t d) (i386:jump body-length)))
+                    body-text
+                    test-text
+                    (list (lambda (s t d) (i386:test-jump (- (+ body-length test-length))))))
+            symbols
+            locals)))
+
+        ((array-ref (p-expr (ident ,name)) (p-expr (ident ,index)))
+         (make-text+symbols+locals
+          (append
+           text
+           (list
+            (lambda (s t d)
+              (append
+               ((ident->base locals) name)
+               ((ident->accu locals) index)
+               (i386:mem-byte->accu)))))
+          symbols
+          locals))
          
-         (display "2start:" (current-error-port))
-         (display start (current-error-port))
-         (newline (current-error-port))
-
-         (display "2for-statement:" (current-error-port))
-         (display statement (current-error-port))
-         (newline (current-error-port))
-
-         (list (lambda (d) (i386:for start test step (statement d))))))
-
-      ((return (p-expr (fixed ,value)))
-       (let ((value (string->number value)))
-        (list (lambda (data) (i386:exit value)))))
-      (_ '()))))
-
-(define (function->text+data o)
-  (let loop ((statements (.statements o)) (text '()) (data '()))
-    (display "text:" (current-error-port))
-    (display text (current-error-port))
-    (newline (current-error-port))
-    (if (null? statements) (values text data)
-        (let* ((statement (car statements)))
-          (display "statement:" (current-error-port))
-          (display statement (current-error-port))
-          (newline (current-error-port))
-          (loop (cdr statements)
-                (append text (statement->text data statement))
-                (append data (statement->data statement)))))))
-
-(define (text+data->exe text data)
-  (display "dumping to a.out:\n" (current-error-port))
-  (map write-any (make-elf (lambda (data)
-                             (append-map (lambda (f) (f data)) text)) data)))
+        ((expr-stmt (post-inc (p-expr (ident ,name))))
+         (make-text+symbols+locals
+          (append text
+                  (list (lambda (s t d) (i386:local-add (assoc-ref locals name) 1))))
+          symbols
+          locals))
+
+        ((return ,expr)
+           (make-text+symbols+locals
+            (append text (list (i386:ret ((expr->accu symbols locals) expr))))
+            symbols
+            locals))
+
+        ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name))))
+         (let ((locals (acons name (1+ (or (and=> (member 1 (map cdr locals)) length) 0)) locals)))
+           (make-text+symbols+locals text symbols locals)))
+
+        ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (fixed ,value))))))
+         (let ((locals (acons name (1+ (or (and=> (member 1 (map cdr locals)) length) 0)) locals))
+               (value (string->number value)))
+           (make-text+symbols+locals
+            (append
+             text
+             (list (lambda (s t d) (i386:local-assign (assoc-ref locals name) value))))
+            symbols
+            locals)))
+
+        ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (fctn-call . ,call)))))
+         (let ((locals (acons name (1+ (or (and=> (member 1 (map cdr locals)) length) 0)) locals)))
+           (let* ((t+s+l (make-text+symbols+locals text symbols locals))
+                  (t+s+l ((statement->text+symbols+locals t+s+l)
+                          `(expr-stmt (fctn-call ,@call))))
+                  (text (.text t+s+l))
+                  (symbols (.symbols t+s+l))
+                  (locals (.locals t+s+l)))
+             (make-text+symbols+locals
+              (append
+               text
+               (list (lambda (s t d) (i386:ret-local (assoc-ref locals name)))))
+              symbols
+              locals))))
+        
+        ((expr-stmt (assn-expr (p-expr (ident ,name)) (op _) (p-expr (fixed ,value))))
+
+         (stderr "RET LOCAL[~a]: ~a\n" name (assoc-ref locals name))
+
+         (let ((value (string->number value)))
+           (make-text+symbols+locals
+            (append text (list (lambda (s t d) (i386:local-assign (assoc-ref locals name) value))))
+            symbols
+            locals)))
+        
+        ((expr-stmt (assn-expr (p-expr (ident ,name)) (op _) (fctn-call . ,call)))
+         (let* ((t+s+l ((statement->text+symbols+locals text+symbols+locals)
+                        `(expr-stmt (fctn-call ,@call))))
+                (text (.text t+s+l))
+                (symbols (.symbols t+s+l))
+                (locals (.locals t+s+l)))
+           (make-text+symbols+locals
+            (append text (list (lambda (s t d) (i386:ret-local (assoc-ref locals name)))))
+            symbols
+            locals)))
+
+       (_
+        (format (current-error-port) "SKIP statement=~a\n" o)
+        text+symbols+locals)))))
+
+(define (symbols->exe symbols)
+  (display "dumping elf\n" (current-error-port))
+  (map write-any (make-elf symbols)))
+
+(define (.formals o)
+  (pmatch o
+    ((fctn-defn _ (ftn-declr _ ,formals) _) formals)
+    ((fctn-defn _ (ptr-declr (pointer) (ftn-declr _ ,formals)) _) formals)
+    (_ (format (current-error-port) ".formals: no match: ~a\n" o)
+       barf)))
+
+(define (formal->text n)
+  (lambda (o i)
+    ;;(i386:formal i n)
+    '()
+    ))
+
+(define (formals->text o)
+  (pmatch o
+    ((param-list . ,formals)
+     (let ((n (length formals)))
+       (list (lambda (s t d)
+               (append
+                (i386:function-preamble)
+                (append-map (formal->text n) formals (iota n))
+                (i386:function-locals))))))
+    (_ (format (current-error-port) "formals->text: no match: ~a\n" o)
+       barf)))
+
+(define (formals->locals o)
+  (pmatch o
+    ((param-list . ,formals)
+     (let ((n (length formals)))
+      (map cons (map .name formals) (iota n (1- (- n))))))
+    (_ (format (current-error-port) "formals->symbols: no match: ~a\n" o)
+       barf)))
+
+(define (string->symbols string)
+  (make-data string (append (string->list string) (list #\nul))))
+
+(define (function->symbols symbols)
+  (lambda (o)
+    (format (current-error-port) "compiling ~a\n" (.name o))
+    ;;(stderr "formals=~a\n" (.formals o))
+    (let* ((text (formals->text (.formals o)))
+           (locals (formals->locals (.formals o)))
+           (text-offset (length (symbols->text symbols 0 0))))
+      (let loop ((statements (.statements o))
+                 (text+symbols+locals (make-text+symbols+locals text symbols locals)))
+        (if (null? statements) (append (.symbols text+symbols+locals) (list (make-function (.name o) (.text text+symbols+locals))))
+            (let* ((statement (car statements)))
+              (loop (cdr statements)
+                    ((statement->text+symbols+locals text+symbols+locals) (car statements)))))))))
+
+(define _start
+  (let* ((ast (with-input-from-string
+                  "int _start () {int i;i=main (0,0);exit (i);}"
+                parse-c99))
+         (functions (filter ast:function? (cdr ast))))
+    ;;(pretty-print ast (current-error-port))
+    (list (find (lambda (x) (equal? (.name x) "_start")) functions))))
+
+(define strlen
+  (let* ((ast (with-input-from-string
+                  "
+int
+strlen (char const* s)
+{
+  int i = 0;
+  while (s[i]) i++;
+    return i;
+}
+"
+                parse-c99))
+         (functions (filter ast:function? (cdr ast))))
+    ;;(pretty-print ast (current-error-port))
+    (list (find (lambda (x) (equal? (.name x) "strlen")) functions))))
+
+(define eputs
+  (let* ((ast (with-input-from-string
+                  "
+int
+eputs (char const* s)
+{
+  //write (STDERR, s, strlen (s));
+  //write (2, s, strlen (s));
+  int i = strlen (s);
+  write (2, s, i);
+  return 0;
+}
+"
+                parse-c99))
+         (functions (filter ast:function? (cdr ast))))
+    ;;(pretty-print ast (current-error-port))
+    (list (find (lambda (x) (equal? (.name x) "eputs")) functions))))
+
+(define fputs
+  (let* ((ast (with-input-from-string
+                  "
+int
+fputs (char const* s, int fd)
+{
+  int i = strlen (s);
+  write (fd, s, i);
+  return 0;
+}
+"
+                parse-c99))
+         (functions (filter ast:function? (cdr ast))))
+    ;;(pretty-print ast (current-error-port))
+    (list (find (lambda (x) (equal? (.name x) "fputs")) functions))))
+
+(define puts
+  (let* ((ast (with-input-from-string
+                  "
+int
+puts (char const* s)
+{
+  //write (STDERR, s, strlen (s));
+  //int i = write (STDERR, s, strlen (s));
+  int i = strlen (s);
+  write (1, s, i);
+  return 0;
+}
+"
+                parse-c99))
+         (functions (filter ast:function? (cdr ast))))
+    ;;(pretty-print ast (current-error-port))
+    (list (find (lambda (x) (equal? (.name x) "puts")) functions))))
+
+(define i386:libc
+  (list
+   (make-function "exit" (list i386:exit))
+   (make-function "write" (list i386:write))))
+
+(define libc
+  (append
+   strlen
+   eputs
+   fputs
+   puts))
 
 (define (compile)
   (let* ((ast (mescc))
          (functions (filter ast:function? (cdr ast)))
-         (main (find (lambda (x) (equal? (.name x) "main")) functions)))
-    (display "AST" (current-error-port))
-    (pretty-print ast (current-error-port))
-    (format (current-error-port) "functions~a\n" functions)
-    (format (current-error-port) "main~a\n" main)
-    (call-with-values
-        (lambda () (function->text+data main))
-      text+data->exe)))
+         (functions (append libc functions _start)))
+    (let loop ((functions functions) (symbols i386:libc))
+      (if (null? functions) (symbols->exe symbols)
+          (loop (cdr functions) ((function->symbols symbols) (car functions)))))))