Pattern matching 3

villain/ast.rkt

@@ -12,8 +12,8 @@
 ;;           | (Int Integer)
 ;;           | (Bool Boolean)
 ;;           | (Char Character)
-;;           | (String)         
-;;           | (Symbol Symbol)
+;;           | (String s)         
+;;           | (Symbol s)
 ;;           | (Prim0 Op0)
 ;;           | (Prim1 Op1 Expr)
 ;;           | (Prim2 Op2 Expr Expr)      
@@ -23,7 +23,7 @@
 ;;           | (Let Id Expr Expr)
 ;;           | (Var Id)
 ;;           | (App Id (Listof Expr))
-;;           | (Match Expr (Listof Pat))
+;;           | (Match Expr (Listof Clause))
 ;; type Id   = Symbol
 ;; type Op0  = 'read-byte | 'void | 'collect-garbage
 ;; type Op1  = 'add1 | 'sub1 | 'zero?
@@ -34,13 +34,18 @@
 ;;           | 'empty?
 ;; type Op2  = '+ | '- | 'eq?
 ;;           | 'cons | 'string-ref
-;; type Op3  = 'string-set!                    
+;; type Op3  = 'string-set!
 ;; type Pat  = (Wild)
 ;;           | (Var Id)
 ;;           | (Lit Literal)
+;;           | (Float f)
+;;           | (String s)
+;;           | (Symbol s)
 ;;           | (Cons Id Id)
 ;;           | (Box Id)
-;; type Litral = Boolean | '() | Char | Integer
+;; type Litral = Boolean | '() | Char | Integer | Symbol | String | Float
+;; type Clause = (Pairof Pat Expr)
+
 
 (struct Eof   ()           #:prefab)
 (struct Empty ()           #:prefab)

villain/compile.rkt

@@ -13,8 +13,8 @@
                   ; string-set!, make-string, 
 (define rsp 'rsp) ; stack
 (define rdi 'rdi) ; arg
-(define r10 'r10) ; scratch in compile-prim3, make-string, string-set!
-(define rcx 'rcx) ; arity indicator
+(define r10 'r10) ; scratch in compile-prim3, make-string, string-set!, match
+(define rcx 'rcx) ; arity indicator, match
 
 ;; type CEnv = [Listof Variable]
 
@@ -488,7 +488,7 @@
          (compile-match-clauses cs return c)
          (Label return))))
 
-;; [Listof Clauses] Symbol CEnv -> Asm
+;;[Listof Clauses] Symbol CEnv -> Asm
 (define (compile-match-clauses cs return c)
   (match cs
     ['() (seq (Jmp (error-label c)))]
@@ -498,7 +498,7 @@
             (Label next)
             (compile-match-clauses cs return c)))]))
 
-;; Clause Symbol Symbol CEnv -> Asm
+;;Clause Symbol Symbol CEnv -> Asm
 (define (compile-match-clause cl next return c)
   (match cl
     [(Clause p e)
@@ -508,11 +508,55 @@
              (compile-e e (cons x c))
              (Add rsp 8)
              (Jmp return))]
-       [(Lit l)
-        (seq (Cmp rax (imm->bits l))
+       [(Lit i)
+        (seq
+             (Mov r8 (imm->bits i))
+             (Cmp rax r8)
              (Jne next)
              (compile-e e c)
              (Jmp return))]
+       [(String s)
+        (let ((true (gensym "true"))
+              (false (gensym "false")))
+          (seq
+           (Mov r8 rax)
+           (And r8 ptr-mask)
+           (Cmp r8 type-string)
+           (Jne next)
+           (Push rax)
+           (compile-string s)
+           (Push rax)
+           (compile-string/symbol-eq type-string true false (cons #f (cons #f c)))
+           (Label true)
+           (Pop r8)
+           (Pop r8)
+           (compile-e e c)
+           (Jmp return)
+           (Label false)
+           (Pop r8)
+           (Pop r8)
+           (Jmp next)))]
+       [(Symbol s)
+        (let ((true (gensym "true"))
+              (false (gensym "false")))
+          (seq
+           (Mov r8 rax)
+           (And r8 ptr-mask)
+           (Cmp r8 type-symbol)
+           (Jne next)
+           (Push rax)
+           (compile-symbol s (cons #f c))
+           (Push rax)
+           (compile-string/symbol-eq type-symbol true false (cons #f (cons #f c)))
+           (Label true)
+           (Pop r8)
+           (Pop r8)
+           (compile-e e c)
+           (Jmp return)
+           (Label false)
+           (Pop r8)
+           (Pop r8)
+           (Jmp next)))]
        [(Box x)
         (seq (Mov r8 rax)
              (And r8 ptr-mask)
@@ -538,6 +582,40 @@
              (Add rsp 16)
              (Jmp return))])]))
 
+;;Symbol Symbol CEnv -> ASM
+;;This function determines if the two strings on top of the stack are structurally equal
+(define (compile-string/symbol-eq tag true false c)
+  (let ((loop (gensym "loop")))
+    (seq
+     (Mov rax (Offset rsp 0)) ;;First string
+     (Mov r8 (Offset rsp 8))  ;;Second string
+
+     ;;Untag the strings
+     (Xor rax tag)
+     (Xor r8 tag)
+     (Mov r9 (Offset r8 0))
+
+     ;;If they don't have the same length, they cannot be equal
+     (Cmp r9 (Offset rax 0))
+     (Jne false)
+
+     (Mov r10 0) ;;Keep track of how many characters have been compared
+     (Sar r9 int-shift) ;;Get the integer value of the length
+
+     ;;Compare each word for equality
+     (Label loop)
+     (Cmp r10 r9) ;;Check if the length has been exhausted
+     (Je true)
+     (Jg true)
+
+     (Add r8 8)
+     (Add rax 8)
+     (Mov rcx (Offset r8 0))
+     (Cmp rcx (Offset rax 0))
+     (Jne false)
+     (Add r10 3) ;;3 chars have been checked
+     (Jmp loop))))
+
 ;; CEnv -> Asm
 ;; Pad the stack to be aligned for a call with stack arguments
 (define (pad-stack-call c i)

villain/externs.rkt

@@ -44,6 +44,19 @@
     [(Let x e1 e2)
      (append (externs-e e1)
              (externs-e e2))]
+    [(Match e cs)
+     (append (externs-e e)
+             (foldl (λ (c acc) (append (externs-clause c) acc)) '() cs))]
+    [_ '()]))
+
+(define (externs-clause c)
+  (match c
+    [(Clause p e) (append (externs-pat p)
+                          (externs-e e))]))
+
+(define (externs-pat p)
+  (match p
+    [(Symbol _) (list (Extern 'str_to_symbol))]
     [_ '()]))
 
 (define (externs-es es)

villain/interp.rkt

@@ -100,7 +100,19 @@
           [(Wild)  (interp-env e r ds)]
           [(Var x) (interp-env e (ext r x v) ds)]
           [(Lit l)
-           (if (eq? l v)
+           (if (and (number? l) (number? v))
+               (if (= l v)
+                   (interp-env e r ds)
+                   (interp-match v cs r ds))
+               (if (equal? l v)
+                   (interp-env e r ds)
+                   (interp-match v cs r ds)))]
+          [(String s)
+           (if (equal? v s)
+               (interp-env e r ds)
+               (interp-match v cs r ds))]
+          [(Symbol s)
+           (if (equal? v s)
                (interp-env e r ds)
                (interp-match v cs r ds))]
           [(Box x)
@@ -123,7 +135,7 @@
 
 ;; Defns Symbol -> Defn
 (define (defns-lookup ds f)
-  (findf (match-lambda [(Defn g _ _) (eq? f g)])
+  (findf (match-lambda [(Defn g _ _) (equal? f g)])
          ds))
 
 (define (zip xs ys)

villain/main.c

@@ -24,7 +24,7 @@ void error_exit() {
 }
 
 void raise_error() {
-  return error_handler();
+   return error_handler();
 }
 
 int main(int argc, char** argv) {

villain/parse.rkt

@@ -56,6 +56,9 @@
     [(? boolean?) (Lit s)]
     [(? integer?) (Lit s)]
     [(? char?)    (Lit s)]
+    [(? flonum?) (Lit s)]
+    [(? string?) (String s)]
+    [(cons 'quote (list (? symbol? x))) (Symbol x)]
     [(list 'quote (list))
      (Lit '())]
     [(list 'cons (? symbol? x1) (? symbol? x2))

villain/test/test-runner.rkt

@@ -182,6 +182,29 @@
                     [2 (let ((y #\c)) (char->integer y))]))
                 #t)
 
+  (check-equal? (run
+                 '(match "abcd"
+                    ['abcd #f]
+                    ["abcd" #t]))
+                #t)
+  (check-equal? (run
+                 '(match 'abcd
+                    ['abcd #f]
+                    ["abcd" #t]))
+                #f)
+
+  (check-equal? (run
+                 '(match -2.5678
+                    [2.5678 #f]
+                    [-2.5678 #t]))
+                #t)
+
+  (check-equal? (run
+                 '(match 'abc
+                    [abc abc]
+                    ['abc #t]))
+                'abc)
+
   (check-equal? (run
                  '(match (cons #t #f)
                     [(cons a b) a]
@@ -249,14 +272,17 @@
                         [(cons h t) (+ 1 (len t))]
                         ['() 0]))
                     (len (cons 1 (cons 2 (cons 3 '()))))))
-                 3)
-    (check-equal? (run
+                3)
+  (check-equal? (run
                  '(begin
                     (define (len lst)
                       (match lst
                         [(cons h t) (+ 1 (len t))]))
                     (len (cons 1 (cons 2 (cons 3 '()))))))
-                 'err)
+                'err)
+
+  ;;End of pattern matching tests
+
 
   (check-equal? (run
                  '(begin (define (tri x)
@@ -281,7 +307,7 @@
   (check-equal? (run '(integer-length  16)) 5)
   (check-equal? (run '(integer-length -16)) 4)
 
-#|
+
   (check-equal? (run
                  '(begin (define (even? x)
                            (if (zero? x)
@@ -301,7 +327,7 @@
                                (cons (add1 (car xs))
                                      (map-add1 (cdr xs)))))
                          (map-add1 (cons 1 (cons 2 (cons 3 '()))))))
-  '(2 3 4))|#
+  '(2 3 4))
 
   (check-equal? (run '(char-whitespace? #\a)) #f)
   (check-equal? (run '(char-whitespace? #\ )) #t)
@@ -345,6 +371,11 @@
   (check-equal? (run -8990.32) -8990.32)
   (check-equal? (run -9999999) -9999999)
   (check-equal? (run .9999999) .9999999)
+  (check-equal? (run
+                '(if (eq? -2.5678 -2.5678)
+                     #t
+                     #f))
+                #t)
 
   ;; Errors and stack alignment
   (define (check-err e)