Resolve and typecheck patterns in pattern alt.

9 files changed, 223 insertions, 80 deletions

diff --git a/src/Makefile b/src/Makefile
index 5d4e6aa0fd3..bc187567039 100644
--- a/src/Makefile
+++ b/src/Makefile
@@ -331,6 +331,7 @@ TEST_XFAILS_X86 :=  test/run-pass/mlist-cycle.rs \
 
 TEST_XFAILS_LLVM := $(addprefix test/run-pass/, \
                       acyclic-unwind.rs \
+                      alt-pattern-simple.rs \
                       alt-tag.rs \
                       argv.rs \
                       basic.rs \
diff --git a/src/boot/fe/ast.ml b/src/boot/fe/ast.ml
index bf7a11ff4e9..438d9de9052 100644
--- a/src/boot/fe/ast.ml
+++ b/src/boot/fe/ast.ml
@@ -300,7 +300,7 @@ and domain =
 
 and pat =
     PAT_lit of lit
-  | PAT_tag of ident * (pat array)
+  | PAT_tag of ((name identified) * (pat array))
   | PAT_slot of ((slot identified) * ident)
   | PAT_wild
 
diff --git a/src/boot/fe/item.ml b/src/boot/fe/item.ml
index 75f86a58947..209526e52eb 100644
--- a/src/boot/fe/item.ml
+++ b/src/boot/fe/item.ml
@@ -224,24 +224,29 @@ and parse_stmts (ps:pstate) : Ast.stmt array =
                   let (stmts, lval) = bracketed LPAREN RPAREN parse_lval ps in
                   let rec parse_pat ps =
                     match peek ps with
-                        IDENT ident ->
+                        IDENT _ ->
                           let apos = lexpos ps in
-                          bump ps;
+                          let name = Pexp.parse_name ps in
                           let bpos = lexpos ps in
 
-                          (* TODO: nullary constructors *)
                           if peek ps != LPAREN then
-                            let slot =
-                              { Ast.slot_mode = Ast.MODE_interior;
-                                Ast.slot_mutable = false;
-                                Ast.slot_ty = None }
-                            in
-                            Ast.PAT_slot ((span ps apos bpos slot), ident)
+                            begin
+                              match name with
+                                  Ast.NAME_base (Ast.BASE_ident ident) ->
+                                    let slot =
+                                      { Ast.slot_mode = Ast.MODE_interior;
+                                        Ast.slot_mutable = false;
+                                        Ast.slot_ty = None }
+                                    in
+                                      Ast.PAT_slot
+                                        ((span ps apos bpos slot), ident)
+                                |_ -> raise (unexpected ps)
+                            end
                           else
                             let pats =
                               paren_comma_list parse_pat ps
                             in
-                            Ast.PAT_tag (ident, pats)
+                            Ast.PAT_tag ((span ps apos bpos name), pats)
                       | LIT_INT _ | LIT_CHAR _ | LIT_BOOL _ ->
                           Ast.PAT_lit (Pexp.parse_lit ps)
                       | UNDERSCORE -> bump ps; Ast.PAT_wild
diff --git a/src/boot/me/resolve.ml b/src/boot/me/resolve.ml
index 8f034aee3a3..bfbac10d407 100644
--- a/src/boot/me/resolve.ml
+++ b/src/boot/me/resolve.ml
@@ -870,28 +870,61 @@ let pattern_resolving_visitor
     (cx:ctxt)
     (scopes:scope list ref)
     (inner:Walk.visitor) : Walk.visitor =
+
+  let not_tag_ctor (nid:Ast.name identified) : unit =
+    err (Some nid.id) "'%s' is not a tag constructor"
+      (string_of_name nid.node)
+  in
+
+  let resolve_pat_tag
+      (namei:Ast.name identified)
+      (pats:Ast.pat array)
+      (tag_ctor_id:node_id)
+      : unit =
+
+    let tag_ty = 
+      fn_output_ty
+        (Hashtbl.find cx.ctxt_all_item_types tag_ctor_id)
+    in
+      begin
+        match tag_ty with
+            Ast.TY_tag _
+          | Ast.TY_iso _ ->
+              let tag_ty_tup = tag_or_iso_ty_tup_by_name tag_ty namei.node in
+              let arity = Array.length tag_ty_tup in
+                if (Array.length pats) == arity
+                then Hashtbl.add cx.ctxt_pattag_to_item namei.id tag_ctor_id
+                else err (Some namei.id)
+                  "tag pattern '%s' with wrong number of components"
+                  (string_of_name namei.node)
+          | _ -> not_tag_ctor namei
+      end
+  in
+
+  let resolve_arm { node = arm } =
+    match fst arm with
+        Ast.PAT_tag (namei, pats) ->
+          begin
+            match lookup_by_name cx !scopes namei.node with
+                None ->
+                  err (Some namei.id) "unresolved tag constructor '%s'"
+                    (string_of_name namei.node)
+              | Some (_, tag_ctor_id) when referent_is_item cx tag_ctor_id ->
+                  (*
+                   * FIXME we should actually check here that the function
+                   * is a tag value-ctor.  For now this actually allows any
+                   * function returning a tag type to pass as a tag pattern.
+                   *)
+                  resolve_pat_tag namei pats tag_ctor_id
+              |_ -> not_tag_ctor namei
+          end
+      | _ -> ()
+  in
+
   let visit_stmt_pre stmt =
     begin
       match stmt.node with
         Ast.STMT_alt_tag { Ast.alt_tag_lval = _; Ast.alt_tag_arms = arms } ->
-          let resolve_arm { node = arm } =
-            match fst arm with
-                Ast.PAT_tag (ident, _) ->
-                  begin
-                    match lookup_by_ident cx !scopes ident with
-                        None ->
-                          err None "unresolved tag constructor '%s'" ident
-                      | Some (_, tag_id) ->
-                          match Hashtbl.find cx.ctxt_all_defns tag_id with
-                              DEFN_item {
-                                  Ast.decl_item = Ast.MOD_ITEM_tag _
-                                } -> ()
-                            | _ ->
-                                err None "'%s' is not a tag constructor" ident
-                  end
-              | _ -> ()
-
-          in
           Array.iter resolve_arm arms
       | _ -> ()
     end;
diff --git a/src/boot/me/semant.ml b/src/boot/me/semant.ml
index b5000ff38ce..f7acccfb885 100644
--- a/src/boot/me/semant.ml
+++ b/src/boot/me/semant.ml
@@ -102,6 +102,7 @@ type ctxt =
 
       (* reference id --> definition id *)
       ctxt_lval_to_referent: (node_id,node_id) Hashtbl.t;
+      ctxt_pattag_to_item: (node_id,node_id) Hashtbl.t;
 
       ctxt_required_items: (node_id, (required_lib * nabi_conv)) Hashtbl.t;
       ctxt_required_syms: (node_id, string) Hashtbl.t;
@@ -186,6 +187,7 @@ let new_ctxt sess abi crate =
     ctxt_all_lvals = Hashtbl.create 0;
     ctxt_all_defns = Hashtbl.create 0;
     ctxt_lval_to_referent = Hashtbl.create 0;
+    ctxt_pattag_to_item = Hashtbl.create 0;
     ctxt_required_items = crate.Ast.crate_required;
     ctxt_required_syms = crate.Ast.crate_required_syms;
 
@@ -396,6 +398,27 @@ let slot_ty (s:Ast.slot) : Ast.ty =
     | None -> bug () "untyped slot"
 ;;
 
+let fn_output_ty (fn_ty:Ast.ty) : Ast.ty =
+  match fn_ty with
+      Ast.TY_fn ({ Ast.sig_output_slot = slot }, _) ->
+        begin
+          match slot.Ast.slot_ty with
+              Some ty -> ty
+            | None -> bug () "function has untyped output slot"
+        end
+    | _ -> bug () "fn_output_ty on non-TY_fn"
+;;
+
+let tag_or_iso_ty_tup_by_name (ty:Ast.ty) (name:Ast.name) : Ast.ty_tup =
+  match ty with
+      Ast.TY_tag tags ->
+        Hashtbl.find tags name
+    | Ast.TY_iso { Ast.iso_index = i; Ast.iso_group = gp } ->
+        Hashtbl.find gp.(i) name
+    | _ ->
+        bug () "tag_or_iso_ty_tup_by_name called with non-tag or -iso type"
+;;
+
 let defn_is_slot (d:defn) : bool =
   match d with
       DEFN_slot _ -> true
diff --git a/src/boot/me/trans.ml b/src/boot/me/trans.ml
index bca15136389..a7ff502c31f 100644
--- a/src/boot/me/trans.ml
+++ b/src/boot/me/trans.ml
@@ -3757,7 +3757,8 @@ let trans_visitor
               emit (Il.jmp Il.JNE Il.CodeNone);
               [ next_jump ]
 
-          | Ast.PAT_tag (ident, pats) ->
+          | Ast.PAT_tag (tag_namei, pats) ->
+              let tag_name = tag_namei.node in
               let ty_tag =
                 match ty with
                     Ast.TY_tag tag_ty -> tag_ty
@@ -3765,7 +3766,6 @@ let trans_visitor
                   | _ -> bug cx "expected tag type"
               in
               let tag_keys = sorted_htab_keys ty_tag in
-              let tag_name = Ast.NAME_base (Ast.BASE_ident ident) in
               let tag_number = arr_idx tag_keys tag_name in
               let ty_tup = Hashtbl.find ty_tag tag_name in
 
diff --git a/src/boot/me/type.ml b/src/boot/me/type.ml
index 2d4dd94aa7a..2dd271443b0 100644
--- a/src/boot/me/type.ml
+++ b/src/boot/me/type.ml
@@ -165,6 +165,7 @@ let process_crate (cx:ctxt) (crate:Ast.crate) : unit =
     cx.ctxt_sess.Session.sess_log_type
     cx.ctxt_sess.Session.sess_log_out
   in
+
   let retval_tvs = Stack.create () in
   let push_retval_tv tv =
     Stack.push tv retval_tvs
@@ -175,6 +176,18 @@ let process_crate (cx:ctxt) (crate:Ast.crate) : unit =
   let retval_tv _ =
     Stack.top retval_tvs
   in
+
+  let pat_tvs = Stack.create () in
+  let push_pat_tv tv =
+    Stack.push tv pat_tvs
+  in
+  let pop_pat_tv _ =
+    ignore (Stack.pop pat_tvs)
+  in
+  let pat_tv _ =
+    Stack.top pat_tvs
+  in
+
   let (bindings:(node_id, tyvar) Hashtbl.t) = Hashtbl.create 10 in
   let (item_params:(node_id, tyvar array) Hashtbl.t) = Hashtbl.create 10 in
   let (lval_tyvars:(node_id, tyvar) Hashtbl.t) = Hashtbl.create 0 in
@@ -737,23 +750,36 @@ let process_crate (cx:ctxt) (crate:Ast.crate) : unit =
         a := TYSPEC_equiv c;
         b := TYSPEC_equiv c
 
+    and unify_ty_parametric
+        (ty:Ast.ty)
+        (tps:Ast.ty_param array)
+        (tv:tyvar)
+        : unit =
+      unify_tyvars (ref (TYSPEC_resolved (tps, ty))) tv
+
     and unify_ty (ty:Ast.ty) (tv:tyvar) : unit =
-      unify_tyvars (ref (TYSPEC_resolved ([||], ty))) tv
+      unify_ty_parametric ty [||] tv
+
     in
 
-    let rec unify_atom (atom:Ast.atom) (tv:tyvar) : unit =
+    let rec unify_lit (lit:Ast.lit) (tv:tyvar) : unit =
+      let ty =
+        match lit with
+            Ast.LIT_nil -> Ast.TY_nil
+          | Ast.LIT_bool _ -> Ast.TY_bool
+          | Ast.LIT_mach (mty, _, _) -> Ast.TY_mach mty
+          | Ast.LIT_int (_, _) -> Ast.TY_int
+          | Ast.LIT_uint (_, _) -> Ast.TY_uint
+          | Ast.LIT_char _ -> Ast.TY_char
+      in
+        unify_ty ty tv
+
+    and unify_atom (atom:Ast.atom) (tv:tyvar) : unit =
       match atom with
           Ast.ATOM_literal { node = literal; id = _ } ->
-            let ty = match literal with
-                Ast.LIT_nil -> Ast.TY_nil
-              | Ast.LIT_bool _ -> Ast.TY_bool
-              | Ast.LIT_mach (mty, _, _) -> Ast.TY_mach mty
-              | Ast.LIT_int (_, _) -> Ast.TY_int
-              | Ast.LIT_uint (_, _) -> Ast.TY_uint
-              | Ast.LIT_char _ -> Ast.TY_char
-            in
-              unify_ty ty tv
-        | Ast.ATOM_lval lval -> unify_lval lval tv
+            unify_lit literal tv
+        | Ast.ATOM_lval lval ->
+            unify_lval lval tv
 
     and unify_expr (expr:Ast.expr) (tv:tyvar) : unit =
       match expr with
@@ -886,39 +912,40 @@ let process_crate (cx:ctxt) (crate:Ast.crate) : unit =
                             | Ast.BASE_app (_, args) ->
                                 note_args args;
                                 ref (TYSPEC_app (tv, args))
-                          | _ -> err None "bad lval / tyspec combination"
-                      in
-                        unify_tyvars (ref spec) tv
-              end
-        | Ast.LVAL_ext (base, comp) ->
-            let base_ts = match comp with
-                Ast.COMP_named (Ast.COMP_ident id) ->
-                  let names = Hashtbl.create 1 in
-                    Hashtbl.add names id tv;
-                    TYSPEC_dictionary names
-
-              | Ast.COMP_named (Ast.COMP_app (id, args)) ->
-                  note_args args;
-                  let tv = ref (TYSPEC_app (tv, args)) in
-                  let names = Hashtbl.create 1 in
-                    Hashtbl.add names id tv;
-                    TYSPEC_dictionary names
-
-              | Ast.COMP_named (Ast.COMP_idx i) ->
-                  let init j = if i + 1 == j then tv else ref TYSPEC_all in
-                    TYSPEC_tuple (Array.init (i + 1) init)
-
-              | Ast.COMP_atom atom ->
-                  unify_atom atom (ref (TYSPEC_resolved ([||], Ast.TY_int)));
-                  TYSPEC_collection tv
-            in
-            let base_tv = ref base_ts in
-              unify_lval' base base_tv;
-              match !(resolve_tyvar base_tv) with
-                  TYSPEC_resolved (_, ty) ->
-                    unify_ty (slot_ty (project_type_to_slot ty comp)) tv
-                | _ ->
-                    ()
+                            | _ -> err None "bad lval / tyspec combination"
+                        in
+                          unify_tyvars (ref spec) tv
+                end
+          | Ast.LVAL_ext (base, comp) ->
+              let base_ts = match comp with
+                  Ast.COMP_named (Ast.COMP_ident id) ->
+                    let names = Hashtbl.create 1 in
+                      Hashtbl.add names id tv;
+                      TYSPEC_dictionary names
+
+                | Ast.COMP_named (Ast.COMP_app (id, args)) ->
+                    note_args args;
+                    let tv = ref (TYSPEC_app (tv, args)) in
+                    let names = Hashtbl.create 1 in
+                      Hashtbl.add names id tv;
+                      TYSPEC_dictionary names
+
+                | Ast.COMP_named (Ast.COMP_idx i) ->
+                    let init j = if i + 1 == j then tv else ref TYSPEC_all in
+                      TYSPEC_tuple (Array.init (i + 1) init)
+
+                | Ast.COMP_atom atom ->
+                    unify_atom atom
+                      (ref (TYSPEC_resolved ([||], Ast.TY_int)));
+                    TYSPEC_collection tv
+              in
+              let base_tv = ref base_ts in
+                unify_lval' base base_tv;
+                match !(resolve_tyvar base_tv) with
+                    TYSPEC_resolved (_, ty) ->
+                      unify_ty (slot_ty (project_type_to_slot ty comp)) tv
+                  | _ ->
+                      ()
 
     and unify_lval (lval:Ast.lval) (tv:tyvar) : unit =
       let id = lval_base_id lval in
@@ -1080,6 +1107,12 @@ let process_crate (cx:ctxt) (crate:Ast.crate) : unit =
               unify_lval seq seq_tv;
               unify_slot si.node (Some si.id) mem_tv
 
+        | Ast.STMT_alt_tag
+            { Ast.alt_tag_lval = lval; Ast.alt_tag_arms = arms } ->
+            let lval_tv = ref TYSPEC_all in
+              unify_lval lval lval_tv;
+              Array.iter (fun _ -> push_pat_tv lval_tv) arms
+            
         (* FIXME (issue #52): plenty more to handle here. *)
         | _ ->
             log cx "warning: not typechecking stmt %s\n"
@@ -1163,13 +1196,54 @@ let process_crate (cx:ctxt) (crate:Ast.crate) : unit =
         | _ -> ()
     in
 
+    let visit_pat_pre (pat:Ast.pat) : unit =
+      let expected = pat_tv() in
+        match pat with
+            Ast.PAT_lit lit -> unify_lit lit expected
+
+          | Ast.PAT_tag (namei, _) ->
+              let expect ty =
+                let tv = ref TYSPEC_all in
+                  unify_ty ty tv;
+                  push_pat_tv tv;
+              in
+              let item_id = Hashtbl.find cx.ctxt_pattag_to_item namei.id in
+              let tag_ty =
+                fn_output_ty (Hashtbl.find cx.ctxt_all_item_types item_id)
+              in
+              let tag_ty_tup = tag_or_iso_ty_tup_by_name tag_ty namei.node in
+              let tag_tv = ref TYSPEC_all in
+                unify_ty tag_ty tag_tv;
+                unify_tyvars expected tag_tv;
+                (* FIXME check arity here? *)
+                List.iter
+                  begin
+                    fun slot ->
+                      match slot.Ast.slot_ty with
+                          Some ty -> expect ty
+                        | None -> bug () "no slot type in tag slot tuple"
+                  end
+                  (List.rev (Array.to_list tag_ty_tup));
+
+          | Ast.PAT_slot (sloti, _) ->
+              unify_slot sloti.node (Some sloti.id) expected
+
+          | Ast.PAT_wild -> ()
+    in
+
+    let visit_pat_post (_:Ast.pat) : unit =
+      pop_pat_tv()
+    in
+
       {
         inner with
           Walk.visit_mod_item_pre = visit_mod_item_pre;
           Walk.visit_mod_item_post = visit_mod_item_post;
           Walk.visit_obj_fn_pre = visit_obj_fn_pre;
           Walk.visit_obj_fn_post = visit_obj_fn_post;
-          Walk.visit_stmt_pre = visit_stmt_pre
+          Walk.visit_stmt_pre = visit_stmt_pre;
+          Walk.visit_pat_pre = visit_pat_pre;
+          Walk.visit_pat_post = visit_pat_post;
       }
 
   in
@@ -1223,7 +1297,7 @@ let process_crate (cx:ctxt) (crate:Ast.crate) : unit =
                 Hashtbl.find bindings id
         in
           match defn with
-              DEFN_item ({ Ast.decl_item=Ast.MOD_ITEM_mod _ } as item) ->
+              DEFN_item ({ Ast.decl_item = Ast.MOD_ITEM_mod _ } as item) ->
                 ignore (tv_of_item id item)
             | _ -> ()
       in
diff --git a/src/boot/me/walk.ml b/src/boot/me/walk.ml
index 3486bb16421..a8d74cad266 100644
--- a/src/boot/me/walk.ml
+++ b/src/boot/me/walk.ml
@@ -652,10 +652,10 @@ and walk_pat
     (v:visitor)
     (p:Ast.pat)
     : unit =
-  let rec walk p =
+  let walk p =
     match p with
         Ast.PAT_lit lit -> walk_lit v lit
-      | Ast.PAT_tag (_, pats) -> Array.iter walk pats
+      | Ast.PAT_tag (_, pats) -> Array.iter (walk_pat v) pats
       | Ast.PAT_slot (si, _) -> walk_slot_identified v si
       | Ast.PAT_wild -> ()
   in
diff --git a/src/test/run-pass/alt-pattern-simple.rs b/src/test/run-pass/alt-pattern-simple.rs
new file mode 100644
index 00000000000..d0a4159ebb6
--- /dev/null
+++ b/src/test/run-pass/alt-pattern-simple.rs
@@ -0,0 +1,7 @@
+fn altsimple(int f) {
+  alt (f) {
+    case (x) {}
+  }
+}
+
+fn main() {}