Add generated files.

extort/ast.rkt

@@ -0,0 +1,24 @@
+#lang racket
+(provide Lit Prim0 Prim1 If Eof Begin)
+;; type Expr = (Lit Datum)
+;;           | (Eof)
+;;           | (Prim0 Op0)
+;;           | (Prim1 Op1 Expr)
+;;           | (If Expr Expr Expr)
+;;           | (Begin Expr Expr)
+;; type Datum = Integer
+;;            | Boolean
+;;            | Character
+;; type Op0 = 'read-byte | 'peek-byte | 'void
+;; type Op1 = 'add1 | 'sub1
+;;          | 'zero?
+;;          | 'char? | 'integer->char | 'char->integer
+;;          | 'write-byte | 'eof-object?
+
+(struct Eof () #:prefab)
+(struct Lit (d) #:prefab)
+(struct Prim0 (p) #:prefab)
+(struct Prim1 (p e) #:prefab)
+(struct If (e1 e2 e3) #:prefab)
+(struct Begin (e1 e2) #:prefab)
+

extort/build-runtime.rkt

@@ -0,0 +1,14 @@
+#lang racket
+(provide runtime-path)
+
+(require racket/runtime-path)
+(define-runtime-path here ".")
+
+(unless (system (string-append "make -C '"
+                               (path->string (normalize-path here))
+                               "' -s runtime.o"))
+  (error 'build-runtime "could not build runtime"))
+
+(define runtime-path
+  (normalize-path (build-path here "runtime.o")))
+

extort/compile-ops.rkt

@@ -0,0 +1,97 @@
+#lang racket
+(provide compile-op0 compile-op1)
+(require "ast.rkt")
+(require "types.rkt")
+(require a86/ast)
+
+(define rax 'rax)
+(define rdi 'rdi) ; arg
+(define r9  'r9)  ; scratch
+
+;; Op0 -> Asm
+(define (compile-op0 p)
+  (match p
+    ['void      (seq (Mov rax (value->bits (void))))]
+    ['read-byte (seq (Call 'read_byte))]
+    ['peek-byte (seq (Call 'peek_byte))]))
+
+;; Op1 -> Asm
+(define (compile-op1 p)
+  (match p
+    ['add1
+     (seq (assert-integer rax)
+          (Add rax (value->bits 1)))]
+    ['sub1
+     (seq (assert-integer rax)
+          (Sub rax (value->bits 1)))]
+    ['zero?
+     (seq (assert-integer rax)
+          (Cmp rax 0)
+          if-equal)]
+    ['char?
+     (seq (And rax mask-char)
+          (Cmp rax type-char)
+          if-equal)]
+    ['char->integer
+     (seq (assert-char rax)
+          (Sar rax char-shift)
+          (Sal rax int-shift))]
+    ['integer->char
+     (seq (assert-codepoint)
+          (Sar rax int-shift)
+          (Sal rax char-shift)
+          (Xor rax type-char))]
+    ['eof-object?
+     (seq (Cmp rax (value->bits eof))
+          if-equal)]
+    ['write-byte
+     (seq assert-byte
+          (Mov rdi rax)
+          (Call 'write_byte))]))
+
+
+;; -> Asm
+;; set rax to #t or #f if comparison flag is equal
+(define if-equal
+  (seq (Mov rax (value->bits #f))
+       (Mov r9  (value->bits #t))
+       (Cmove rax r9)))
+
+(define (assert-type mask type)
+  (λ (arg)
+    (seq (Mov r9 arg)
+         (And r9 mask)
+         (Cmp r9 type)
+         (Jne 'err))))
+
+(define (type-pred mask type)
+  (seq (And rax mask)
+       (Cmp rax type)
+       if-equal))
+
+(define assert-integer
+  (assert-type mask-int type-int))
+(define assert-char
+  (assert-type mask-char type-char))
+
+(define (assert-codepoint)
+  (let ((ok (gensym)))
+    (seq (assert-integer rax)
+         (Cmp rax (value->bits 0))
+         (Jl 'err)
+         (Cmp rax (value->bits 1114111))
+         (Jg 'err)
+         (Cmp rax (value->bits 55295))
+         (Jl ok)
+         (Cmp rax (value->bits 57344))
+         (Jg ok)
+         (Jmp 'err)
+         (Label ok))))
+
+(define assert-byte
+  (seq (assert-integer rax)
+       (Cmp rax (value->bits 0))
+       (Jl 'err)
+       (Cmp rax (value->bits 255))
+       (Jg 'err)))
+

extort/compile-stdin.rkt

@@ -0,0 +1,13 @@
+#lang racket
+(provide main)
+(require "parse.rkt")
+(require "compile.rkt")
+(require a86/printer)
+
+;; -> Void
+;; Compile contents of stdin,
+;; emit asm code on stdout
+(define (main)
+  (read-line) ; ignore #lang racket line
+  (asm-display (compile (parse (read)))))
+

extort/compile.rkt

@@ -0,0 +1,69 @@
+#lang racket
+(provide (all-defined-out))
+(require "ast.rkt")
+(require "compile-ops.rkt")
+(require "types.rkt")
+(require a86/ast)
+
+(define rax 'rax)
+(define rsp 'rsp) ; stack
+
+;; Expr -> Asm
+(define (compile e)
+  (prog (Global 'entry)
+        (Extern 'peek_byte)
+        (Extern 'read_byte)
+        (Extern 'write_byte)
+        (Extern 'raise_error)
+        (Label 'entry)
+        (Sub rsp 8)
+        (compile-e e)
+        (Add rsp 8)
+        (Ret)
+        ;; Error handler
+        (Label 'err)
+        (Call 'raise_error)))
+
+;; Expr -> Asm
+(define (compile-e e)
+  (match e
+    [(Lit d) (compile-value d)]
+    [(Eof) (compile-value eof)]
+    [(Prim0 p) (compile-prim0 p)]
+    [(Prim1 p e) (compile-prim1 p e)]
+    [(If e1 e2 e3)
+     (compile-if e1 e2 e3)]
+    [(Begin e1 e2)
+     (compile-begin e1 e2)]))
+
+;; Value -> Asm
+(define (compile-value v)
+  (seq (Mov rax (value->bits v))))
+
+;; Op0 -> Asm
+(define (compile-prim0 p)
+  (compile-op0 p))
+
+;; Op1 Expr -> Asm
+(define (compile-prim1 p e)
+  (seq (compile-e e)
+       (compile-op1 p)))
+
+;; Expr Expr Expr -> Asm
+(define (compile-if e1 e2 e3)
+  (let ((l1 (gensym 'if))
+        (l2 (gensym 'if)))
+    (seq (compile-e e1)
+         (Cmp rax (value->bits #f))
+         (Je l1)
+         (compile-e e2)
+         (Jmp l2)
+         (Label l1)
+         (compile-e e3)
+         (Label l2))))
+
+;; Expr Expr -> Asm
+(define (compile-begin e1 e2)
+  (seq (compile-e e1)
+       (compile-e e2)))
+

extort/interp-io.rkt

@@ -0,0 +1,13 @@
+#lang racket
+(provide interp/io)
+(require "interp.rkt")
+
+;; String Expr -> (Cons Value String)
+;; Interpret e with given string as input,
+;; return value and collected output as string
+(define (interp/io e input)
+  (parameterize ((current-output-port (open-output-string))
+                 (current-input-port  (open-input-string input)))
+      (cons (interp e)
+            (get-output-string (current-output-port)))))
+

extort/interp-prim.rkt

@@ -0,0 +1,29 @@
+#lang racket
+(provide interp-prim0 interp-prim1)
+
+;; Op0 -> Value
+(define (interp-prim0 op)
+  (match op
+    ['read-byte (read-byte)]
+    ['peek-byte (peek-byte)]
+    ['void      (void)]))
+
+;; Op1 Value -> Answer
+(define (interp-prim1 op v)
+  (match (list op v)
+    [(list 'add1 (? integer?))            (add1 v)]
+    [(list 'sub1 (? integer?))            (sub1 v)]
+    [(list 'zero? (? integer?))           (zero? v)]
+    [(list 'char? v)                      (char? v)]
+    [(list 'integer->char (? codepoint?)) (integer->char v)]
+    [(list 'char->integer (? char?))      (char->integer v)]
+    [(list 'write-byte    (? byte?))      (write-byte v)]
+    [(list 'eof-object? v)                (eof-object? v)]
+    [_ 'err]))
+
+;; Any -> Boolean
+(define (codepoint? v)
+  (and (integer? v)
+       (or (<= 0 v 55295)
+           (<= 57344 v 1114111))))
+

extort/interp-stdin.rkt

@@ -0,0 +1,12 @@
+#lang racket
+(provide main)
+(require "parse.rkt")
+(require "interp.rkt")
+
+;; -> Void
+;; Parse and interpret contents of stdin,
+;; print result on stdout
+(define (main)
+  (read-line) ; ignore #lang racket line
+  (println (interp (parse (read)))))
+

extort/interp.rkt

@@ -0,0 +1,33 @@
+#lang racket
+(provide interp)
+(require "ast.rkt")
+(require "interp-prim.rkt")
+
+;; type Value =
+;; | Integer
+;; | Boolean
+;; | Character
+;; | Eof
+;; | Void
+;; Expr -> Answer
+(define (interp e)
+  (match e
+    [(Lit d) d]
+    [(Eof)   eof]
+    [(Prim0 p)
+     (interp-prim0 p)]
+    [(Prim1 p e)
+     (match (interp e)
+       ['err 'err]
+       [v (interp-prim1 p v)])]
+    [(If e1 e2 e3)
+     (match (interp e1)
+       ['err 'err]
+       [v (if v
+              (interp e2)
+              (interp e3))])]
+    [(Begin e1 e2)
+     (match (interp e1)
+       ['err 'err]
+       [v (interp e2)])]))
+

extort/main.rkt

@@ -0,0 +1,13 @@
+#lang racket
+(require "ast.rkt")
+(require "parse.rkt")
+(require "interp.rkt")
+(require "compile.rkt")
+(require "run.rkt")
+(provide (all-from-out "ast.rkt"))
+(provide (all-from-out "parse.rkt"))
+(provide (all-from-out "interp.rkt"))
+(provide (all-from-out "compile.rkt"))
+(provide (all-from-out "run.rkt"))
+
+

extort/parse.rkt

@@ -0,0 +1,31 @@
+#lang racket
+(provide parse)
+(require "ast.rkt")
+
+;; S-Expr -> Expr
+(define (parse s)
+  (match s
+    ['eof                (Eof)]
+    [(? datum?)          (Lit s)]
+    [(list (? op0? o))   (Prim0 o)]
+    [(list (? op1? o) e) (Prim1 o (parse e))]
+    [(list 'begin e1 e2) (Begin (parse e1) (parse e2))]
+    [(list 'if e1 e2 e3)
+     (If (parse e1) (parse e2) (parse e3))]
+    [_ (error "Parse error")]))
+
+
+;; Any -> Boolean
+(define (datum? x)
+  (or (exact-integer? x)
+      (boolean? x)
+      (char? x)))
+
+;; Any -> Boolean
+(define (op0? x)
+  (memq x '(read-byte peek-byte void)))
+
+(define (op1? x)
+  (memq x '(add1 sub1 zero? char? integer->char char->integer
+                 write-byte eof-object?)))
+

extort/run-stdin.rkt

@@ -0,0 +1,12 @@
+#lang racket
+(provide main)
+(require "parse.rkt")
+(require "compile.rkt")
+(require "run.rkt")
+
+;; -> Void
+;; Compile contents of stdin and use asm-interp to run
+(define (main)
+  (read-line) ; ignore #lang racket line
+  (run (compile (parse (read)))))
+

extort/run.rkt

@@ -0,0 +1,19 @@
+#lang racket
+(require a86/interp)
+(require "types.rkt")
+(require "build-runtime.rkt")
+(provide run run/io)
+;; Asm -> Answer
+(define (run is)
+  (parameterize ((current-objs (list (path->string runtime-path))))
+    (match (asm-interp is)
+      ['err 'err]
+      [b (bits->value b)])))
+;; Asm String -> (cons Answer String)
+(define (run/io is in)
+  (parameterize ((current-objs (list (path->string runtime-path))))
+    (match (asm-interp/io is in)
+      [(cons 'err out) (cons 'err out)]
+      [(cons b out)
+       (cons (bits->value b) out)])))
+