Merge pull request #104 from cmsc430/outlaw

Outlaw

Author: dvanhorn

langs/neerdowell/compile-expr.rkt

@@ -346,7 +346,7 @@
            (list
             (seq (Mov rax (Offset rax (* 8 i)))
                  i1
-                 (Mov rax (Offset rsp (* 8 (sub1 (length cm1)))))
+                 (Mov rax (Offset rsp (* 8 (- (length cm1) (length cm)))))
                  is)
             (seq f1 fs)
             cmn)])])]))

langs/neerdowell/test/test-runner.rkt

@@ -382,7 +382,7 @@
                '()))
    666)
 
-  ;; Outlaw examples
+  ;; Neerdowell examples
   (check-equal? (run '(struct foo ())
                      '(foo? (foo)))
                 #t)
@@ -434,7 +434,43 @@
                      '(match (bar 5)
                         [(foo x) #f]
                         [(bar x) x]))
-                5))
+                5)
+  (check-equal? (run '(struct nil ())
+                     '(struct pair (x y))
+                     '(define (len x)
+                        (match x
+                          [(nil) 0]
+                          [(pair _ x) (add1 (len x))]))
+                     '(len (pair 1 (pair 2 (pair 3 (nil))))))
+                3)
+  (check-equal? (run '(match (cons (cons 1 2) '())
+                        [(cons (cons x y) '()) y]))
+                2)
+  (check-equal? (run '(struct foo (p q))
+                     '(match (cons (foo 1 2) '())
+                        [(cons (foo x y) _) y]))
+                2)
+  (check-equal? (run '(struct foo (p q))
+                     '(match (cons (foo 1 2) '())
+                        [(cons (foo x 3) _) x]
+                        [_ 9]))
+                9)
+  (check-equal? (run '(struct foo (x q))
+                     '(define (get z)
+                        (match z
+                          ['() #f]
+                          [(cons (foo x q) y) x]))
+                     '(get (cons (foo 7 2) '())))
+                7)
+  (check-equal? (run '(struct posn (x y))
+                     '(define (posn-xs ps)
+                        (match ps
+                          ['() '()]
+                          [(cons (posn x y) ps)
+                           (cons x (posn-xs ps))]))
+                     '(posn-xs (cons (posn 3 4) (cons (posn 5 6) (cons (posn 7 8) '())))))
+                '(3 5 7)))
+
 
 (define (test-runner-io run)
   ;; Evildoer examples

langs/outlaw/a86/printer.rkt

@@ -1,5 +1,5 @@
 #lang racket
-(provide asm-string current-shared?)
+(provide asm-string current-shared? asm-display)
 (require "ast.rkt")
 
 (define current-shared?
@@ -216,3 +216,27 @@
        (instrs->string a)
        #;
        (error "program does not have an initial label")])))
+
+(define (asm-display a)
+  (begin
+    (set-box! external-labels '())
+    ;; entry point will be first label
+    (match (findf Label? a)
+      [(Label g)
+       (begin
+         (write-string
+          (string-append
+           tab "global " (label-symbol->string g) "\n"
+           tab "default rel\n"
+           tab "section .text\n"))
+         (asm-display-instrs a))]
+      [_
+       (asm-display-instrs a)])))
+
+(define (asm-display-instrs a)
+  (match a
+    ['() (void)]
+    [(cons i a)
+     (begin (write-string (instr->string i))
+            (write-string "\n")
+            (asm-display-instrs a))]))

langs/outlaw/compile-expr.rkt

@@ -400,7 +400,7 @@
            (list
             (seq (Mov rax (Offset rax (*8 i)))
                  i1
-                 (Mov rax (Offset rsp (*8 (sub1 (length cm1)))))
+                 (Mov rax (Offset rsp (*8 (- (length cm1) (length cm)))))
                  is)
             (seq f1 fs)
             cmn)])])]))

langs/outlaw/compile-library.rkt

@@ -8,4 +8,4 @@
   (begin
     (read-line) ; ignore #lang racket line
     (current-shared? #t)
-    (displayln (asm-string (compile-library (parse-library (read-all)))))))
+    (asm-display (compile-library (parse-library (read-all))))))

langs/outlaw/compile-stdin.rkt

@@ -9,4 +9,4 @@
   (begin
     (read-line) ; ignore #lang racket line
     (current-shared? #t)
-    (displayln (asm-string (compile (parse (read-all)))))))
+    (asm-display (compile (parse (read-all))))))

langs/outlaw/compile.rkt

@@ -81,7 +81,7 @@
          string->uninterned-symbol
          open-input-file
          write-char error integer?
-         eq-hash-code char-alphabetic? char-whitespace? displayln
+         eq-hash-code char-alphabetic? char-whitespace? displayln write-string
          ;; Op2
          + - < = cons eq? make-vector vector-ref
          make-string string-ref string-append

langs/outlaw/stdlib.rkt

@@ -15,6 +15,7 @@
          read-line
          char-alphabetic? char-whitespace?
          displayln ; only works for strings
+         write-string
          ; unimplemented
          exact->inexact / expt string->keyword
          ;; Op0
@@ -305,8 +306,10 @@
   ;; the primitive system type returns 1 for mac, 0 otherwise;
   ;; the fall through case is for when %system-type is implemented in Racket
   (match (%system-type)
-    [1 'macosx]
-    [0 'unix]
+    ;; the use of string->symbol here is to avoid subtle issues about symbol interning
+    ;; in separately compiled libraries
+    [1 (string->symbol "macosx")]
+    [0 (string->symbol "unix")]
     [x x]))
 
 (define (not x)
@@ -559,10 +562,14 @@
 
 (define (displayln s)
   (if (string? s)
-      (begin (map write-char (string->list s))
+      (begin (write-string s)
              (write-char #\newline))
       (error "unimplemented displayln for non-strings")))
 
+(define (write-string s)
+  (begin (map write-char (string->list s))
+         (string-length s)))
+
 (define (exact->inexact x)
   (error "exact->inexact not implemented"))
 

langs/outlaw/test/test-runner.rkt

@@ -428,6 +428,47 @@
   (check-equal? (run '(struct foo (x))
                      '(foo-x #t))
                 'err)
+  (check-equal? (run '(struct foo (x))
+                     '(struct bar (y))
+                     '(match (bar 5)
+                        [(foo x) #f]
+                        [(bar x) x]))
+                5)
+  (check-equal? (run '(struct nil ())
+                     '(struct pair (x y))
+                     '(define (len x)
+                        (match x
+                          [(nil) 0]
+                          [(pair _ x) (add1 (len x))]))
+                     '(len (pair 1 (pair 2 (pair 3 (nil))))))
+                3)
+  (check-equal? (run '(match (cons (cons 1 2) '())
+                        [(cons (cons x y) '()) y]))
+                2)
+  (check-equal? (run '(struct foo (p q))
+                     '(match (cons (foo 1 2) '())
+                        [(cons (foo x y) _) y]))
+                2)
+  (check-equal? (run '(struct foo (p q))
+                     '(match (cons (foo 1 2) '())
+                        [(cons (foo x 3) _) x]
+                        [_ 9]))
+                9)
+  (check-equal? (run '(struct foo (x q))
+                     '(define (get z)
+                        (match z
+                          ['() #f]
+                          [(cons (foo x q) y) x]))
+                     '(get (cons (foo 7 2) '())))
+                7)
+  (check-equal? (run '(struct posn (x y))
+                     '(define (posn-xs ps)
+                        (match ps
+                          ['() '()]
+                          [(cons (posn x y) ps)
+                           (cons x (posn-xs ps))]))
+                     '(posn-xs (cons (posn 3 4) (cons (posn 5 6) (cons (posn 7 8) '())))))
+                '(3 5 7))
 
   ;; Outlaw examples
   (check-equal? (run '(+)) 0)
@@ -684,6 +725,8 @@
                 (cons (void) "a"))
   (check-equal? (run "" '(write-char #\newline))
                 (cons (void) "\n"))
+  (check-equal? (run "" '(write-string "hello world"))
+                (cons 11 "hello world"))
   (check-equal? (run "" '(displayln "hello world"))
                 (cons (void) "hello world\n"))
   )