use a scheme procedures+eval to manage and transform AST

Removes records for a more-managable scheme-syntax approach. Modules+overriding allows for the IR itself to be represented and evaluated as scheme code during each transformation.

12 files changed, 325 insertions, 15 deletions

diff --git a/src/gscc b/src/gscc
index 3a5c2ba..d00b116 100755
--- a/src/gscc
+++ b/src/gscc
@@ -6,11 +6,11 @@
 (use-modules (ice-9 getopt-long)
              (ice-9 popen)
              (ice-9 pretty-print)
-             (modules lexer lexer)
-             (modules parser parser)
-             (modules generator generator)
-             (modules tuple-generator tuple-generator)
-             (modules emitter emitter))
+             (modules lexer driver)
+             (modules parser driver)
+             (modules tacky driver)
+             (modules generator driver)
+             (modules emitter driver))
 
 
 (define version "v0.1.1")
@@ -40,22 +40,25 @@ Options:
                         (read-tokens))))
     (close-input-port port)
     (when parse?
-      (let ((c-ast (p-program tokens)))
+      (let ((c-ast (tokens->ast tokens)))
+        (pretty-print c-ast)
         (when tack?
-          (let ((tacky-ast (t-program c-ast)))
+          (let ((tacky-ast (ast->tacky c-ast)))
+            (pretty-print tacky-ast)
             (when generate?
-              (let ((assembly-ast (g-program tacky-ast)))
-                (display tacky-ast)
+              (let ((assembly-ast (tacky->assembly tacky-ast)))
+                (pretty-print assembly-ast)
                 (when write?
-                  (let ((program (e-program assembly-ast))
+                  (let ((program (assembly->string assembly-ast))
                         (a-file (string-append dest ".s")))
                     (when (file-exists? a-file)
                       (delete-file a-file))
-                    (let ((port (open-output-file a-file)))
-                      (display program port)
-                      (close-port port))
-                    (when (postprocess a-file dest)
-                      (display (string-concatenate `("Postprocess reported success (wrote " ,dest ").\n"))))))))))))))
+                    ;; (let ((port (open-output-file a-file)))
+                    ;;   (display program port)
+                    ;;   (close-port port))
+                    ;; (when (postprocess a-file dest)
+                    ;;   (display (string-concatenate `("Postprocess reported success (wrote " ,dest ").\n"))))
+                    ))))))))))
 
 (define (preprocess file)
   "Returns an input port containing FILE processed with gcc."
diff --git a/src/modules/ast/ir.scm b/src/modules/ast/ir.scm
new file mode 100644
index 0000000..3b373e5
--- /dev/null
+++ b/src/modules/ast/ir.scm
@@ -0,0 +1,50 @@
+(define-module (modules ast ir)
+  #:export (prog
+            srout
+            neg
+            not
+            mov
+            stack
+            reg
+            imm
+            tmp
+            ret))
+
+;;; Commentary:
+;;;
+;;; Nodes which exist to do nothing when evaluated.
+;;;
+;;; Code:
+
+(define (ir-node type . args)
+  (cons type args))
+
+(define (prog func)
+  (ir-node 'prog func))
+
+(define (srout label instrs)
+  (ir-node 'srout label instrs))
+
+(define (neg dst)
+  (ir-node 'neg dst))
+
+(define (not dst)
+  (ir-node 'not dst))
+
+(define (mov dst src)
+  (ir-node 'mov dst src))
+
+(define (stack val)
+  (ir-node 'stack val))
+
+(define (reg val)
+  (ir-node 'reg val))
+
+(define (imm val)
+  (ir-node 'imm val))
+
+(define (tmp num)
+  (ir-node 'tmp num))
+
+(define (ret)
+  (ir-node 'ret))
diff --git a/src/modules/generator/allocate.scm b/src/modules/generator/allocate.scm
new file mode 100644
index 0000000..193cadb
--- /dev/null
+++ b/src/modules/generator/allocate.scm
@@ -0,0 +1,16 @@
+(define-module (modules generator allocate)
+  #:use-module (modules utils assign-stack)
+  #:export (expansion->allocate))
+
+
+(define (expansion->allocate ast)
+  (define (allocate n)
+    (cond
+     ((null? n) n)
+     ((eq? (car n) 'tmp)
+      (list 'stack (make-location (cadr n))))
+     ((list? (car n))
+      (cons (allocate (car n)) (allocate (cdr n))))
+     (#t
+      (cons (car n) (allocate (cdr n))))))
+  (allocate ast))
diff --git a/src/modules/generator/assembly.scm b/src/modules/generator/assembly.scm
new file mode 100644
index 0000000..50e158e
--- /dev/null
+++ b/src/modules/generator/assembly.scm
@@ -0,0 +1,18 @@
+(define-module (modules generator assembly)
+  #:use-module (modules ast ir)
+  #:use-module (modules utils assign-stack)
+  #:use-module (modules utils merge-instructions)
+  #:export (instrs
+            mov))
+
+
+(define (instrs lst)
+  (cons 'list (cons (list 'alloc (abs (get-frame-size)))
+                    (merge-instr lst))))
+
+(define (mov dst src)
+  (if (and (eq? 'stack (car dst))
+           (eq? 'stack (car src)))
+      (append (list (list 'mov (reg "r10") src))
+              (list (list 'mov dst (reg "r10"))))
+      (list 'mov dst src)))
diff --git a/src/modules/generator/driver.scm b/src/modules/generator/driver.scm
new file mode 100644
index 0000000..dc95268
--- /dev/null
+++ b/src/modules/generator/driver.scm
@@ -0,0 +1,9 @@
+(define-module (modules generator driver)
+  #:use-module (modules generator allocate)
+  #:export (tacky->assembly))
+
+
+(define (tacky->assembly n)
+  (eval (expansion->allocate
+         (eval n (resolve-module '(modules generator expansion))))
+        (resolve-module '(modules generator assembly))))
diff --git a/src/modules/generator/expansion.scm b/src/modules/generator/expansion.scm
new file mode 100644
index 0000000..3beb6db
--- /dev/null
+++ b/src/modules/generator/expansion.scm
@@ -0,0 +1,23 @@
+(define-module (modules generator expansion)
+  #:use-module (modules ast ir)
+  #:use-module (modules utils merge-instructions)
+  #:export (instrs
+            not
+            neg
+            ret))
+
+
+(define (instrs lst)
+  #f
+  (list 'instrs (cons 'list (merge-instr lst))))
+
+(define (not dst src) (unary 'not dst src))
+(define (neg dst src) (unary 'neg dst src))
+
+(define (ret src)
+  (list (list 'mov (list 'reg "eax") src)
+        (list 'ret)))
+
+(define (unary op dst src)
+  (list (list 'mov dst src)
+        (list op dst)))
diff --git a/src/modules/lexer/driver.scm b/src/modules/lexer/driver.scm
new file mode 100644
index 0000000..e1a4f6e
--- /dev/null
+++ b/src/modules/lexer/driver.scm
@@ -0,0 +1,86 @@
+(define-module (modules lexer driver)
+  #:export (read-tokens))
+
+(define (read-tokens)
+  "Returns a stream of tokens from the
+current input port."
+  (define (read-tokens-loop tokens-so-far)
+    (let ((token (read-token)))
+      (if token
+          (read-tokens-loop (cons token tokens-so-far))
+          (reverse tokens-so-far))))
+  (read-tokens-loop '()))
+
+(define (read-token)
+  (let ((chr (read-char)))
+    (cond
+     ((eof-object? chr) #f)
+     ((char-whitespace? chr)
+      (read-token))
+
+      ((eqv? chr #\()
+       'left-paren)
+      ((eqv? chr #\))
+       'right-paren)
+      ((eqv? chr #\{)
+       'open-brace)
+      ((eqv? chr #\})
+       'close-brace)
+      ((eqv? chr #\;)
+       'semi-colon)
+      ((eqv? chr #\~)
+       'not)
+
+      ((eqv? chr #\+)
+       (if (take-double? chr)
+           '++
+           '+))
+
+      ((eqv? chr #\-)
+       (if (take-double? chr)
+           '--
+           'neg))
+
+      ((char-numeric? chr)
+       (read-constant chr))
+
+      ((char-alphabetic? chr)
+       (lookup-keyword (read-identifier chr)))
+
+      (#t (error "illegal lexical syntax")))))
+
+(define (read-constant chr)
+  (define (read-constant-helper chrs-so-far)
+    (let ((chr (peek-char)))
+      (cond ((and (not (eof-object? chr)) (char-numeric? chr))
+             (read-constant-helper (cons (read-char) chrs-so-far)))
+            ((and (not (eof-object? chr)) (char-alphabetic? chr))
+             (error "identifier starting with digit"))
+            (#t (reverse chrs-so-far)))))
+  (string->number (list->string (read-constant-helper (list chr)))))
+
+(define (read-identifier chr)
+  (define (read-identifier-helper chrs-so-far)
+    (let ((chr (peek-char)))
+      (cond ((and (not (eof-object? chr))
+              (or (char-alphabetic? chr)
+                  (char-numeric? chr)
+                  (eqv? chr #\_)))
+             (read-identifier-helper (cons (read-char) chrs-so-far)))
+            (#t (reverse chrs-so-far)))))
+  (list->string (read-identifier-helper (list chr))))
+
+(define (take-double? chr)
+  (if (eqv? chr (peek-char))
+      (read-char)
+      #f))
+
+(define (lookup-keyword id)
+  "Given identifier ID, converts it to a keyword
+if one is known."
+  (let ((found (assoc
+                id
+                '(("int" . int)
+                  ("void" . void)
+                  ("return" . return)))))
+    (if found (cdr found) id)))
diff --git a/src/modules/parser/driver.scm b/src/modules/parser/driver.scm
new file mode 100644
index 0000000..8fd42a4
--- /dev/null
+++ b/src/modules/parser/driver.scm
@@ -0,0 +1,35 @@
+(define-module (modules parser driver)
+  #:use-module (ice-9 match)
+  #:export (tokens->ast))
+
+
+(define (die)
+  (error "syntax error"))
+
+(define (tokens->ast tokens)
+  (match tokens
+    ((func ...)
+     (list 'prog (function func)))
+    (_ (die))))
+
+(define (function tokens)
+  (match tokens
+    (('int (? string? id) 'left-paren 'void 'right-paren 'open-brace stmt ... 'close-brace)
+     (list 'func id (statement stmt)))
+    (_ (die))))
+
+(define (statement tokens)
+  (match tokens
+    (('return expr ... 'semi-colon)
+     (list 'stmt (expression expr)))
+    (_ (die))))
+
+(define (expression tokens)
+  (match tokens
+    (((? integer? int))
+     int)
+    (((or 'neg 'not) expr ...)
+     (list 'expr (car tokens) (expression expr)))
+    (('left-paren expr ... 'right-paren)
+     (expression expr))
+    (_ (die))))
diff --git a/src/modules/tacky/driver.scm b/src/modules/tacky/driver.scm
new file mode 100644
index 0000000..c642059
--- /dev/null
+++ b/src/modules/tacky/driver.scm
@@ -0,0 +1,6 @@
+(define-module (modules tacky driver)
+  #:export (ast->tacky))
+
+
+(define (ast->tacky n)
+  (eval n (resolve-module '(modules tacky traverse))))
diff --git a/src/modules/tacky/traverse.scm b/src/modules/tacky/traverse.scm
new file mode 100644
index 0000000..24c4054
--- /dev/null
+++ b/src/modules/tacky/traverse.scm
@@ -0,0 +1,42 @@
+(define-module (modules tacky traverse)
+  #:use-module (modules ast ir)
+  #:export (prog
+            func
+            stmt
+            unary
+            const))
+
+
+(define (prog srout)
+  (list 'prog srout))
+
+(define (func name instrs)
+  (list 'srout name instrs))
+
+(define (stmt val)
+  (list 'instrs
+        (cons 'list (append (cdr val)
+                            (list (list 'ret (car val)))))))
+
+(define (expr op val)
+  (cond
+   ((integer? val) (make-instruction op (imm val) '()))
+   (#t (make-instruction op (car val) (cdr val)))))
+
+(define (make-instruction op src instrs)
+  (let ((dst (make-temporary)))
+    (cons dst
+            (append instrs
+                    (list (op dst src))))))
+
+(define make-temporary
+  (let ((count 100))
+    (lambda ()
+      (set! count (1+ count))
+      (list 'tmp count))))
+
+(define (neg dst src)
+  (list 'neg dst src))
+
+(define (not dst src)
+  (list 'not dst src))
diff --git a/src/modules/utils/assign-stack.scm b/src/modules/utils/assign-stack.scm
new file mode 100644
index 0000000..8037400
--- /dev/null
+++ b/src/modules/utils/assign-stack.scm
@@ -0,0 +1,15 @@
+(define-module (modules utils assign-stack)
+  #:export (make-location
+            get-frame-size))
+
+
+(define make-location)
+(define get-frame-size)
+(let ((dict (make-hash-table))
+      (ptr 0))
+  (set! make-location
+        (lambda (id)
+          (or (hash-ref dict id)
+              (begin (set! ptr (1+ ptr))
+                     (hash-set! dict id (get-frame-size))))))
+  (set! get-frame-size (lambda () (* -4 ptr))))
diff --git a/src/modules/utils/merge-instructions.scm b/src/modules/utils/merge-instructions.scm
new file mode 100644
index 0000000..dea5556
--- /dev/null
+++ b/src/modules/utils/merge-instructions.scm
@@ -0,0 +1,7 @@
+(define-module (modules utils merge-instructions)
+  #:use-module (srfi srfi-1)
+  #:export (merge-instr))
+
+
+(define (merge-instr lst)
+  (append-map (lambda (x) (if (list? (car x)) x (list x))) lst))