Fix two bugs in tag patterns: 1. Look up the tag constructor function item using lval_item, not lval_to_referent; 2. Correct the form of the name used to query the tag or iso ty_tag when obtaining the corresponding type tuple.

2 files changed, 10 insertions, 10 deletions

diff --git a/src/boot/me/resolve.ml b/src/boot/me/resolve.ml
index 1f563c76..cafb69b1 100644
--- a/src/boot/me/resolve.ml
+++ b/src/boot/me/resolve.ml
@@ -930,7 +930,7 @@ let pattern_resolving_visitor
         Ast.PAT_tag (lval, pats) ->
           let lval_nm = lval_to_name lval in
           let lval_id = lval_base_id lval in
-          let tag_ctor_id = lval_to_referent cx lval_id in
+          let tag_ctor_id = (lval_item cx lval).id in
             if referent_is_item cx tag_ctor_id
 
             (* FIXME (issue #76): we should actually check here that the
diff --git a/src/boot/me/semant.ml b/src/boot/me/semant.ml
index 5160429e..95a5c792 100644
--- a/src/boot/me/semant.ml
+++ b/src/boot/me/semant.ml
@@ -416,15 +416,15 @@ let fn_output_ty (fn_ty:Ast.ty) : Ast.ty =
 (* name of tag constructor function -> name for indexing in the ty_tag *)
 let rec tag_ctor_name_to_tag_name (name:Ast.name) : Ast.name =
   match name with
-      Ast.NAME_base nb ->
-        begin
-          match nb with
-              Ast.BASE_ident _ -> name
-            | Ast.BASE_app (id, _) -> Ast.NAME_base (Ast.BASE_ident id)
-            | _ ->
-                bug () "tag_or_iso_ty_tup_by_name with non-tag-ctor name"
-        end
-    | Ast.NAME_ext (inner_name, _) -> tag_ctor_name_to_tag_name inner_name
+      Ast.NAME_base (Ast.BASE_ident _) -> name
+    | Ast.NAME_base (Ast.BASE_app (id, _)) ->
+        Ast.NAME_base (Ast.BASE_ident id)
+
+    | Ast.NAME_ext (_, Ast.COMP_ident id)
+    | Ast.NAME_ext (_, Ast.COMP_app (id, _)) ->
+        Ast.NAME_base (Ast.BASE_ident id)
+
+    | _ -> bug () "tag_or_iso_ty_tup_by_name with non-tag-ctor name"
 ;;
 
 let tag_or_iso_ty_tup_by_name (ty:Ast.ty) (name:Ast.name) : Ast.ty_tup =