Outlaw

langs/neerdowell/compile-expr.rkt

@@ -313,10 +313,11 @@
               cm2))])])]
     [(PStruct n ps)
      (match (compile-struct-patterns ps (cons #f cm) next 1)
-       [(list i f cm)
+       [(list i f cm1)
         (let ((fail (gensym)))
           (list
-           (seq (Mov r8 rax)
+           (seq (%%% "struct")
+                (Mov r8 rax)
                 (And r8 ptr-mask)
                 (Cmp r8 type-struct)
                 (Jne fail)
@@ -331,7 +332,7 @@
                 (Label fail)
                 (Add rsp (* 8 (length cm)))
                 (Jmp next))
-           cm))])]))
+           cm1))])]))
 
 ;; [Listof Pat] CEnv Symbol Nat -> (list Asm Asm CEnv)
 (define (compile-struct-patterns ps cm next i)

langs/neerdowell/interp-defun.rkt

@@ -111,7 +111,24 @@
     [(PAnd p1 p2)
      (match (interp-match-pat p1 v r)
        [#f #f]
-       [r1 (interp-match-pat p2 v r1)])]))
+       [r1 (interp-match-pat p2 v r1)])]
+    [(PStruct t ps)
+     (match v
+       [(StructVal n vs)
+        (and (eq? t n)
+             (interp-match-pats ps (vector->list vs) r))]
+       [_ #f])]))
+
+;; [Listof Pat] [Listof Val] Env -> [Maybe Env]
+(define (interp-match-pats ps vs r)
+  (match ps
+    ['() r]
+    [(cons p ps)
+     (match vs
+       [(cons v vs)
+        (match (interp-match-pat p v r)
+          [#f #f]
+          [r1 (interp-match-pats ps vs r1)])])]))
 
 ;; Id Env [Listof Defn] -> Answer
 (define (interp-var x r ds)

langs/neerdowell/interp-prims.rkt

@@ -1,6 +1,6 @@
 #lang racket
 (require "ast.rkt")
-(provide interp-prim)
+(provide interp-prim StructVal)
 
 ;; type Struct = (StructVal Symbol (Vectorof Value))
 (struct StructVal (name vals))

langs/neerdowell/interp.rkt

@@ -108,7 +108,24 @@
     [(PAnd p1 p2)
      (match (interp-match-pat p1 v r)
        [#f #f]
-       [r1 (interp-match-pat p2 v r1)])]))
+       [r1 (interp-match-pat p2 v r1)])]
+    [(PStruct t ps)
+     (match v
+       [(StructVal n vs)
+        (and (eq? t n)
+             (interp-match-pats ps (vector->list vs) r))]
+       [_ #f])]))
+
+;; [Listof Pat] [Listof Val] Env -> [Maybe Env]
+(define (interp-match-pats ps vs r)
+  (match ps
+    ['() r]
+    [(cons p ps)
+     (match vs
+       [(cons v vs)
+        (match (interp-match-pat p v r)
+          [#f #f]
+          [r1 (interp-match-pats ps vs r1)])])]))
 
 ;; Id Env [Listof Defn] -> Answer
 (define (interp-var x r ds)

langs/neerdowell/test/test-runner.rkt

@@ -428,7 +428,13 @@
                 #f)
   (check-equal? (run '(struct foo (x))
                      '(foo-x #t))
-                'err))
+                'err)
+  (check-equal? (run '(struct foo (x))
+                     '(struct bar (y))
+                     '(match (bar 5)
+                        [(foo x) #f]
+                        [(bar x) x]))
+                5))
 
 (define (test-runner-io run)
   ;; Evildoer examples

langs/outlaw/compile-expr.rkt

@@ -340,7 +340,7 @@
               cm2))])])]
     [(PStruct n ps)
      (match (compile-struct-patterns ps c g (cons #f cm) next 1)
-       [(list i f cm)
+       [(list i f cm1)
         (let ((fail (gensym)))
           (list
            (seq (Mov r8 rax)
@@ -358,7 +358,7 @@
                 (Label fail)
                 (Add rsp (*8 (length cm)))
                 (Jmp next))
-           cm))])]
+           cm1))])]
 
     [(PPred e)
      (let ((fail (gensym 'fail)))

langs/outlaw/compile-ops.rkt

@@ -132,6 +132,7 @@
           (unpad-stack))]
     ['error
      (seq (assert-string rax)
+          (Xor rax type-str)
           (Mov rdi rax)
           (pad-stack)
           (Call 'raise_error))]
@@ -146,6 +147,19 @@
           (pad-stack)
           (Call 'is_char_alphabetic)
           (unpad-stack))]
+    ['char-whitespace?
+     (seq (assert-char rax)
+          (Sar rax char-shift)
+          (Mov rdi rax)
+          (pad-stack)
+          (Call 'is_char_whitespace)
+          (unpad-stack))]
+    ['write-char
+     (seq (assert-char rax)
+          (Mov rdi rax)
+          (pad-stack)
+          (Call 'print_codepoint_out)
+          (unpad-stack))]
 
     ;; Op2
     ['+

langs/outlaw/compile-stdin.rkt

@@ -1,5 +1,5 @@
 #lang racket
-(require "parse.rkt" "compile.rkt" "read-all.rkt" "a86/printer.rkt")
+(require "stdlib.rkt" "parse.rkt" "compile.rkt" "read-all.rkt" "a86/printer.rkt")
 (provide main)
 
 ;; -> Void

langs/outlaw/compile.rkt

@@ -58,17 +58,18 @@
   '(list list* make-list list? foldr map filter length append append*
          memq member append-map vector->list
          reverse
-         number->string gensym read read-char
+         number->string gensym read read-char peek-char
          > <= >=
          void?
          list->string string->list
-         char<=?
+         char<=? char=?
          remove-duplicates remq* remove* remove
          andmap vector list->vector boolean?
          substring odd?
          system-type ;; hard-coded
          not findf
          read-line
+         exact->inexact / expt string->keyword ; unimplemented
          ;; Op0
          read-byte peek-byte void
          ;; Op1
@@ -80,7 +81,7 @@
          string->uninterned-symbol
          open-input-file
          write-char error integer?
-         eq-hash-code char-alphabetic?
+         eq-hash-code char-alphabetic? char-whitespace? displayln
          ;; Op2
          + - < = cons eq? make-vector vector-ref
          make-string string-ref string-append
@@ -103,6 +104,8 @@
          read_byte_port
          peek_byte_port
          is_char_alphabetic
+         is_char_whitespace
+         print_codepoint_out
          system_type)))
 
 (define cons-function

langs/outlaw/io.c

@@ -9,6 +9,7 @@
 #define port_buffer_bytes 8
 
 void utf8_encode_string(val_str_t *, char *);
+int utf8_encode_char(val_char_t, char *);
 
 val_t read_byte(void)
 {
@@ -30,6 +31,14 @@ val_t write_byte(val_t c)
   return val_wrap_void();
 }
 
+val_t print_codepoint_out(val_t c)
+{
+  char buffer[5] = {0};
+  utf8_encode_char(val_unwrap_char(c), buffer);
+  fprintf(out, "%s", buffer);
+  return val_wrap_void();
+}
+
 val_t open_input_file(val_t in) {
   FILE *f;
   char *buf;

langs/outlaw/parse.rkt

@@ -291,7 +291,6 @@
     [(? symbol? xs)
      (LamRest (gensym 'lamrest) '() xs (parse-e e))]
     [_
-     (eprintf "xs: ~a e: ~a\n" xs e)
      (error "parse parameter list error")]))
 
 ;; Datum -> Datum
@@ -337,7 +336,7 @@
          write-char
          error integer?
          eq-hash-code
-         char-alphabetic?))
+         char-alphabetic? char-whitespace?))
 (define op2
   '(+ - < = cons eq? make-vector vector-ref make-string string-ref
       string-append set-box! quotient remainder

langs/outlaw/print.c

@@ -19,7 +19,9 @@ val_t is_char_alphabetic(val_char_t c) {
   return val_wrap_bool(uc_is_property_alphabetic(c));
 }
 
-
+val_t is_char_whitespace(val_char_t c) {
+  return val_wrap_bool(uc_is_property_white_space(c));
+}
 
 void print_result(val_t x)
 {

langs/outlaw/read.rkt

@@ -1,6 +1,6 @@
 #lang racket
 (provide read)
-(require "stdlib.rkt")
+(require "stdlib.rkt" "utils.rkt")
 ;(require (only-in "stdlib.rkt" read-char))
 
 ;; read.rkt
@@ -561,7 +561,8 @@
   (let ((x (char->integer c)))
     (cond [(<= 48 x 57)  (- x 48)]
           [(<= 65 x 70)  (- x 55)]
-          [(<= 97 x 102) (- x 87)])))
+          [(<= 97 x 102) (- x 87)]
+          [else (error "bad char-digit16")])))
 
 (define (octal-char d1 d2 d3)
   (let ((x (+ (*64 (char-digit8->number d1))
@@ -672,23 +673,3 @@
 
 (define (unimplemented x)
   (err (string-append "unimplemented: " x)))
-
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Multipliers
-
-(define (*2 a)
-   (arithmetic-shift a 1))
-
-(define (*8 a)
-   (arithmetic-shift a 3))
-
-(define (*16 a)
-   (arithmetic-shift a 4))
-
-(define (*10 a) ; 10a=2^3a+2a
-  (+ (arithmetic-shift a 1)
-     (arithmetic-shift a 3)))
-
-(define (*64 a)
-  (arithmetic-shift a 6))

langs/outlaw/stdlib.rkt

@@ -1,7 +1,7 @@
 #lang racket
 (provide list list* make-list list? map foldr filter length append append*
          memq member append-map vector->list
-         number->string gensym read read-char
+         number->string gensym read read-char peek-char
          > <= >= void?
          char<=? char=?
          list->string string->list
@@ -13,7 +13,8 @@
          not
          findf
          read-line
-         char-alphabetic?
+         char-alphabetic? char-whitespace?
+         displayln ; only works for strings
          ; unimplemented
          exact->inexact / expt string->keyword
          ;; Op0
@@ -65,6 +66,7 @@
 (define (zero? n) (%zero? n))
 (define (char? n) (%char? n))
 (define (write-byte b) (%write-byte b)) ; IMPROVE: add port
+(define (write-char c) (%write-char c))
 (define (eof-object? x) (%eof-object? x))
 (define (integer->char i) (%integer->char i))
 (define (char->integer c) (%char->integer c))
@@ -553,6 +555,13 @@
         (read-line/a (cons c cs)))))
 
 (define (char-alphabetic? x) (%char-alphabetic? x))
+(define (char-whitespace? x) (%char-whitespace? x))
+
+(define (displayln s)
+  (if (string? s)
+      (begin (map write-char (string->list s))
+             (write-char #\newline))
+      (error "unimplemented displayln for non-strings")))
 
 (define (exact->inexact x)
   (error "exact->inexact not implemented"))

langs/outlaw/test/test-runner.rkt

@@ -594,6 +594,8 @@
   (check-equal? (run '(findf odd? '(2 4 3 7))) 3)
   (check-equal? (run '(char-alphabetic? #\a)) #t)
   (check-equal? (run '(char-alphabetic? #\space)) #f)
+  (check-equal? (run '(char-whitespace? #\a)) #f)
+  (check-equal? (run '(char-whitespace? #\space)) #t)
   (check-equal? (run '(begin 1)) 1)
   (check-equal? (run '(begin 1 2)) 2)
   (check-equal? (run '(begin 1 2 3)) 3)
@@ -602,6 +604,12 @@
   (check-equal? (run '(let ((x 1)) x x x)) 1)
   (check-equal? (run '(match 1 [1 2 3])) 3)
   (check-equal? (run '(system-type)) (system-type))
+  (check-equal? (run '(struct Foo (x))
+                     '(struct Bar (y))
+                     '(match (Bar 1)
+                        [(Foo x) #f]
+                        [(Bar x) x]))
+                1)                       
   )
 
 
@@ -672,4 +680,10 @@
                 (cons #\a ""))
   (check-equal? (run "ab" '(cons (read-char) (read-char)))
                 (cons '(#\a . #\b) ""))
+  (check-equal? (run "" '(write-char #\a))
+                (cons (void) "a"))
+  (check-equal? (run "" '(write-char #\newline))
+                (cons (void) "\n"))
+  (check-equal? (run "" '(displayln "hello world"))
+                (cons (void) "hello world\n"))
   )

langs/outlaw/utils.rkt

@@ -1,5 +1,5 @@
 #lang racket
-(provide symbol->label symbol->data-label lookup pad-stack unpad-stack *8)
+(provide symbol->label symbol->data-label lookup pad-stack unpad-stack *2 *8 *10 *16 *64)
 (require "a86/ast.rkt" "registers.rkt")
 
 ;; Symbol -> Label
@@ -49,5 +49,22 @@
 (define (unpad-stack)
   (seq (Add rsp r15)))
 
-(define (*8 n)
-  (arithmetic-shift n 3))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Multipliers
+
+(define (*2 a)
+   (arithmetic-shift a 1))
+
+(define (*8 a)
+   (arithmetic-shift a 3))
+
+(define (*16 a)
+   (arithmetic-shift a 4))
+
+(define (*10 a) ; 10a=2^3a+2a
+  (+ (arithmetic-shift a 1)
+     (arithmetic-shift a 3)))
+
+(define (*64 a)
+  (arithmetic-shift a 6))