Support pattern guards

tjammer · Nov 30, 2024 · 001fb59 · 001fb59
1 parent 13316c7
commit 001fb59
Show file tree

Hide file tree

Showing 9 changed files with 201 additions and 163 deletions.
diff --git a/lib/ast.ml b/lib/ast.ml
@@ -1,29 +1,8 @@
 type loc = (Lexing.position * Lexing.position[@opaque]) [@@deriving show]
 type ident = loc * string
-
-type bop =
-  | Plus_i
-  | Mult_i
-  | Div_i
-  | Less_i
-  | Greater_i
-  | Less_eq_i
-  | Greater_eq_i
-  | Equal_i
-  | Minus_i
-  | Plus_f
-  | Mult_f
-  | Div_f
-  | Less_f
-  | Greater_f
-  | Less_eq_f
-  | Greater_eq_f
-  | Equal_f
-  | Minus_f
-  | And
-  | Or
-[@@deriving show, sexp]
-(* Eventually, this will be handled differently, hopefully not as hardcoded *)
+type bop = Equal_i | And | Or [@@deriving show, sexp]
+(* Equal_i is used in pattern matches, so we keep it even though it is also
+   defined as a builtin function *)
 
 type unop = Uminus_i | Uminus_f [@@deriving show, sexp]
 
@@ -69,11 +48,17 @@ and expr =
   | Pipe_head of loc * argument * pipeable
   | Pipe_tail of loc * argument * pipeable
   | Ctor of loc * ident * expr option
-  | Match of
-      loc * decl_attr * expr * (loc * Path.t option * pattern * expr) list
+  | Match of loc * decl_attr * expr * (clause * expr) list
   | Local_use of loc * string * expr
   | Fmt of loc * expr list
 
+and clause = {
+  cloc : loc;
+  cpath : Path.t option;
+  cpat : pattern;
+  guard : (loc * expr) option;
+}
+
 and pipeable = Pip_expr of expr
 
 and pattern =

diff --git a/lib/codegen/codegen.ml b/lib/codegen/codegen.ml
@@ -346,56 +346,9 @@ end = struct
     in
     let open Llvm in
     match bop with
-    | Plus_i ->
-        { value = bld build_add "add"; typ = Tint; lltyp = int_t; kind = Imm }
-    | Minus_i ->
-        { value = bld build_sub "sub"; typ = Tint; lltyp = int_t; kind = Imm }
-    | Mult_i ->
-        { value = bld build_mul "mul"; typ = Tint; lltyp = int_t; kind = Imm }
-    | Div_i ->
-        { value = bld build_sdiv "div"; typ = Tint; lltyp = int_t; kind = Imm }
-    | Less_i ->
-        let value = bld (build_icmp Icmp.Slt) "lt" in
-        { value; typ = Tbool; lltyp = bool_t; kind = Imm }
-    | Greater_i ->
-        let value = bld (build_icmp Icmp.Sgt) "gt" in
-        { value; typ = Tbool; lltyp = bool_t; kind = Imm }
-    | Less_eq_i ->
-        let value = bld (build_icmp Icmp.Sle) "le" in
-        { value; typ = Tbool; lltyp = bool_t; kind = Imm }
-    | Greater_eq_i ->
-        let value = bld (build_icmp Icmp.Sge) "ge" in
-        { value; typ = Tbool; lltyp = bool_t; kind = Imm }
     | Equal_i ->
         let value = bld (build_icmp Icmp.Eq) "eq" in
         { value; typ = Tbool; lltyp = bool_t; kind = Imm }
-    | Plus_f ->
-        let value = bld build_fadd "add" in
-        { value; typ = Tfloat; lltyp = float_t; kind = Imm }
-    | Minus_f ->
-        let value = bld build_fsub "sub" in
-        { value; typ = Tfloat; lltyp = float_t; kind = Imm }
-    | Mult_f ->
-        let value = bld build_fmul "mul" in
-        { value; typ = Tfloat; lltyp = float_t; kind = Imm }
-    | Div_f ->
-        let value = bld build_fdiv "div" in
-        { value; typ = Tfloat; lltyp = float_t; kind = Imm }
-    | Less_f ->
-        let value = bld (build_fcmp Fcmp.Olt) "lt" in
-        { value; typ = Tbool; lltyp = bool_t; kind = Imm }
-    | Greater_f ->
-        let value = bld (build_fcmp Fcmp.Ogt) "gt" in
-        { value; typ = Tbool; lltyp = bool_t; kind = Imm }
-    | Less_eq_f ->
-        let value = bld (build_fcmp Fcmp.Ole) "le" in
-        { value; typ = Tbool; lltyp = bool_t; kind = Imm }
-    | Greater_eq_f ->
-        let value = bld (build_fcmp Fcmp.Oge) "ge" in
-        { value; typ = Tbool; lltyp = bool_t; kind = Imm }
-    | Equal_f ->
-        let value = bld (build_fcmp Fcmp.Oeq) "eq" in
-        { value; typ = Tbool; lltyp = bool_t; kind = Imm }
     | And ->
         let cond1 = gen e1 |> bring_default in
 

diff --git a/lib/codegen/helpers.ml b/lib/codegen/helpers.ml
@@ -781,8 +781,16 @@ struct
     ignore (List.fold_left f start_index params)
 
   let var_index var =
-    let tagptr = Llvm.build_struct_gep var.lltyp var.value 0 "tag" builder in
-    let value = Llvm.build_load i32_t tagptr "index" builder in
+    let value =
+      match var.kind with
+      | Const_ptr | Ptr ->
+          let tagptr =
+            Llvm.build_struct_gep var.lltyp var.value 0 "tag" builder
+          in
+          Llvm.build_load i32_t tagptr "index" builder
+      | Const -> Llvm.(const_extractelement var.value (const_int i32_t 0))
+      | Imm -> failwith "Did not expect Imm in var_index"
+    in
     { value; typ = Ti32; lltyp = i32_t; kind = Imm }
 
   let var_data var typ =

diff --git a/lib/parser.mly b/lib/parser.mly
@@ -362,7 +362,11 @@ clause_path:
       |> Option.get }
 
 clause:
-  | path = option(clause_path); pattern = match_pattern; Colon; expr = expr { $loc, path, pattern, expr }
+  | cpath = option(clause_path); cpat = match_pattern; guard = option(guard); Colon; expr = expr
+    { { cloc = $loc; cpath; cpat; guard }, expr }
+
+guard:
+  | And; expr = expr { $loc, expr }
 
 clauses:
   | clause = clause { [ clause ] }

diff --git a/lib/syntax_errors.messages b/lib/syntax_errors.messages
@@ -1010,6 +1010,14 @@ prog: Match False Lcurly Ident Hbar Ident Rpar
 
 <YOUR SYNTAX ERROR MESSAGE HERE>
 
+prog: Match False Lcurly Ident And With
+
+<YOUR SYNTAX ERROR MESSAGE HERE>
+
+prog: Match False Lcurly Ident And False Wildcard
+
+<YOUR SYNTAX ERROR MESSAGE HERE>
+
 prog: Match False Lcurly Ident Colon With
 
 <YOUR SYNTAX ERROR MESSAGE HERE>