crook

Author: dvanhorn

iniquity-plus/assert.rkt

@@ -0,0 +1,64 @@
+#lang racket
+(provide assert-integer assert-char assert-byte assert-codepoint
+         assert-box assert-cons
+         assert-natural assert-vector assert-string)
+(require a86/ast)
+(require "types.rkt")
+
+(define r9 'r9)
+
+(define (assert-type mask type)
+  (λ (arg)
+    (seq (Mov r9 arg)
+         (And r9 mask)
+         (Cmp r9 type)
+         (Jne 'err))))
+
+;; Register -> Asm
+
+
+(define assert-integer
+  (assert-type mask-int type-int))
+
+;; Register -> Asm
+
+(define assert-char
+  (assert-type mask-char type-char))
+(define assert-box
+  (assert-type ptr-mask type-box))
+(define assert-cons
+  (assert-type ptr-mask type-cons))
+(define assert-vector
+  (assert-type ptr-mask type-vect))
+(define assert-string
+  (assert-type ptr-mask type-str))
+
+;; Register -> Asm
+(define (assert-codepoint r)
+  (let ((ok (gensym)))
+    (seq (assert-integer r)
+         (Cmp r (value->bits 0))
+         (Jl 'err)
+         (Cmp r (value->bits 1114111))
+         (Jg 'err)
+         (Cmp r (value->bits 55295))
+         (Jl ok)
+         (Cmp r (value->bits 57344))
+         (Jg ok)
+         (Jmp 'err)
+         (Label ok))))
+
+;; Register -> Asm
+(define (assert-byte r)
+  (seq (assert-integer r)
+       (Cmp r (value->bits 0))
+       (Jl 'err)
+       (Cmp r (value->bits 255))
+       (Jg 'err)))
+
+;; Register -> Asm
+(define (assert-natural r)
+  (seq (assert-integer r)
+       (Cmp r (value->bits 0))
+       (Jl 'err)))
+

iniquity-plus/ast.rkt

@@ -30,6 +30,8 @@
 ;;           | (App Id (Listof Expr))
 ;;           | (Apply Id (Listof Expr) Expr)
 
+;; type ClosedExpr = { e ∈ Expr | e contains no free variables }
+
 ;; type Id  = Symbol
 ;; type Datum = Integer
 ;;            | Boolean

iniquity-plus/compile-ops.rkt

@@ -2,6 +2,7 @@
 (provide compile-op0 compile-op1 compile-op2 compile-op3 pad-stack assert-cons)
 (require "ast.rkt")
 (require "types.rkt")
+(require "assert.rkt")
 (require a86/ast)
 
 (define rax 'rax)
@@ -44,15 +45,15 @@
           (Sar rax char-shift)
           (Sal rax int-shift))]
     ['integer->char
-     (seq (assert-codepoint)
+     (seq (assert-codepoint rax)
           (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
+     (seq (assert-byte rax)
           pad-stack
           (Mov rdi rax)
           (Call 'write_byte)
@@ -64,16 +65,13 @@
           (Add rbx 8))]
     ['unbox
      (seq (assert-box rax)
-          (Xor rax type-box)
-          (Mov rax (Offset rax 0)))]
+          (Mov rax (Offset rax (- type-box))))]
     ['car
      (seq (assert-cons rax)
-          (Xor rax type-cons)
-          (Mov rax (Offset rax 8)))]
+          (Mov rax (Offset rax (- 8 type-cons))))]
     ['cdr
      (seq (assert-cons rax)
-          (Xor rax type-cons)
-          (Mov rax (Offset rax 0)))]
+          (Mov rax (Offset rax (- type-cons))))]
 
     ['empty? (seq (Cmp rax (value->bits '())) if-equal)]
     ['cons? (type-pred ptr-mask type-cons)]
@@ -84,10 +82,9 @@
      (let ((zero (gensym))
            (done (gensym)))
        (seq (assert-vector rax)
-            (Xor rax type-vect)
-            (Cmp rax 0)
+            (Cmp rax type-vect)
             (Je zero)
-            (Mov rax (Offset rax 0))
+            (Mov rax (Offset rax (- type-vect)))
             (Sal rax int-shift)
             (Jmp done)
             (Label zero)
@@ -97,10 +94,9 @@
      (let ((zero (gensym))
            (done (gensym)))
        (seq (assert-string rax)
-            (Xor rax type-str)
-            (Cmp rax 0)
+            (Cmp rax type-str)
             (Je zero)
-            (Mov rax (Offset rax 0))
+            (Mov rax (Offset rax (- type-str)))
             (Sal rax int-shift)
             (Jmp done)
             (Label zero)
@@ -270,71 +266,25 @@
           (Mov (Offset r8 8) rax)
           (Mov rax (value->bits (void))))]))
 
+(define (type-pred mask type)
+  (seq (And rax mask)
+       (Cmp rax type)
+       if-equal))
 
-;; -> Asm
+;; 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)))
 
-;; -> Asm
+;; Asm
 ;; set rax to #t or #f if comparison flag is less than
 (define if-lt
   (seq (Mov rax (value->bits #f))
        (Mov r9  (value->bits #t))
        (Cmovl 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-box
-  (assert-type ptr-mask type-box))
-(define assert-cons
-  (assert-type ptr-mask type-cons))
-(define assert-vector
-  (assert-type ptr-mask type-vect))
-(define assert-string
-  (assert-type ptr-mask type-str))
-
-(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)))
-
-(define (assert-natural r)
-  (seq (assert-integer r)
-       (Cmp r (value->bits 0))
-       (Jl 'err)))
 
 ;; Asm
 ;; Dynamically pad the stack to be aligned for a call

iniquity-plus/compile-stdin.rkt

@@ -10,5 +10,5 @@
 ;; emit asm code on stdout
 (define (main)
   (read-line) ; ignore #lang racket line
-  (asm-display (compile (apply parse (read-all)))))
+  (asm-display (compile (apply parse-closed (read-all)))))
 

iniquity-plus/compile.rkt

@@ -1,5 +1,9 @@
 #lang racket
-(provide (all-defined-out))
+(provide compile
+         compile-e
+         compile-es
+         compile-define)
+
 (require "ast.rkt")
 (require "compile-ops.rkt")
 (require "types.rkt")

iniquity-plus/correct.rkt

@@ -0,0 +1,10 @@
+#lang racket
+(provide check-compiler)
+(require rackunit)
+(require "interp-io.rkt")
+(require "exec-io.rkt")
+;; ClosedExpr String -> Void
+(define (check-compiler e i)
+  (check-equal? (interp/io e i)
+                (exec/io e i)))
+

iniquity-plus/env.rkt

@@ -0,0 +1,16 @@
+#lang racket
+(provide lookup ext)
+
+;; Env Variable -> Answer
+(define (lookup env x)
+  (match env
+    ['() 'err]
+    [(cons (list y i) env)
+     (match (symbol=? x y)
+       [#t i]
+       [#f (lookup env x)])]))
+
+;; Env Variable Value -> Value
+(define (ext r x i)
+  (cons (list x i) r))
+

iniquity-plus/exec-io.rkt

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

iniquity-plus/exec.rkt

@@ -0,0 +1,13 @@
+#lang racket
+(require a86/interp)
+(require "compile.rkt")
+(require "types.rkt")
+(require "build-runtime.rkt")
+(provide exec)
+;; Prog -> Answer
+(define (exec p)
+  (parameterize ((current-objs (list (path->string runtime-path))))
+    (match (asm-interp (compile p))
+      ['err 'err]
+      [b (bits->value b)])))
+

iniquity-plus/interp-io.rkt

@@ -1,12 +1,16 @@
 #lang racket
 (provide interp/io)
 (require "interp.rkt")
-;; String Prog -> (Cons Value String)
+;; String Prog -> (Cons Answer String)
 ;; Interpret p with given string as input,
-;; return value and collected output as string
+;; return answer and collected output as string
 (define (interp/io p input)
-  (parameterize ((current-output-port (open-output-string))
-                 (current-input-port  (open-input-string input)))
-      (cons (interp p)
-            (get-output-string (current-output-port)))))
+  (define result (box #f))
+  (define output
+    (with-input-from-string input
+      (λ ()
+        (with-output-to-string
+          (λ ()
+            (set-box! result (interp p)))))))
+  (cons (unbox result) output))