From 241305caab232b04666704dc6853c41312cd283a Mon Sep 17 00:00:00 2001
From: Roy Frostig <rfrostig@mozilla.com>
Date: Fri, 25 Jun 2010 00:47:23 -0700
Subject: Resolve and typecheck patterns in pattern alt redux.  This time
 featuring way more correctness.

---
 src/boot/fe/ast.ml  |  8 +++++++-
 src/boot/fe/item.ml | 30 ++++++++++++++++--------------
 2 files changed, 23 insertions(+), 15 deletions(-)

(limited to 'src/boot/fe')

diff --git a/src/boot/fe/ast.ml b/src/boot/fe/ast.ml
index 09037510..770b57bf 100644
--- a/src/boot/fe/ast.ml
+++ b/src/boot/fe/ast.ml
@@ -299,9 +299,14 @@ and domain =
     DOMAIN_local
   | DOMAIN_thread
 
+(*
+ * PAT_tag uses lval for the tag constructor so that we can reuse our lval
+ * resolving machinery.  The lval is restricted during parsing to have only
+ * named components.
+ *)
 and pat =
     PAT_lit of lit
-  | PAT_tag of ((name identified) * (pat array))
+  | PAT_tag of (lval * (pat array))
   | PAT_slot of ((slot identified) * ident)
   | PAT_wild
 
@@ -331,6 +336,7 @@ and lval_component =
   | COMP_atom of atom
 
 
+(* identifying the name_base here is sufficient to identify the full lval *)
 and lval =
     LVAL_base of name_base identified
   | LVAL_ext of (lval * lval_component)
diff --git a/src/boot/fe/item.ml b/src/boot/fe/item.ml
index 209526e5..031b9e49 100644
--- a/src/boot/fe/item.ml
+++ b/src/boot/fe/item.ml
@@ -127,6 +127,16 @@ and parse_auto_slot_and_init
 
 and parse_stmts (ps:pstate) : Ast.stmt array =
   let apos = lexpos ps in
+
+  let rec name_to_lval (apos:pos) (bpos:pos) (name:Ast.name)
+      : Ast.lval =
+    match name with
+        Ast.NAME_base nb ->
+          Ast.LVAL_base (span ps apos bpos nb)
+      | Ast.NAME_ext (n, nc) ->
+          Ast.LVAL_ext (name_to_lval apos bpos n, Ast.COMP_named nc)
+  in
+
     match peek ps with
 
         LOG ->
@@ -139,15 +149,6 @@ and parse_stmts (ps:pstate) : Ast.stmt array =
           bump ps;
           begin
 
-            let rec name_to_lval (bpos:pos) (name:Ast.name)
-                : Ast.lval =
-              match name with
-                  Ast.NAME_base nb ->
-                    Ast.LVAL_base (span ps apos bpos nb)
-                | Ast.NAME_ext (n, nc) ->
-                    Ast.LVAL_ext (name_to_lval bpos n, Ast.COMP_named nc)
-            in
-
             let rec carg_path_to_lval (bpos:pos) (path:Ast.carg_path)
                 : Ast.lval =
               match path with
@@ -171,7 +172,7 @@ and parse_stmts (ps:pstate) : Ast.stmt array =
 
             let synthesise_check_call (bpos:pos) (constr:Ast.constr)
                 : (Ast.lval * (Ast.atom array)) =
-              let lval = name_to_lval bpos constr.Ast.constr_name in
+              let lval = name_to_lval apos bpos constr.Ast.constr_name in
               let args =
                 Array.map (carg_to_atom bpos) constr.Ast.constr_args
               in
@@ -243,13 +244,14 @@ and parse_stmts (ps:pstate) : Ast.stmt array =
                                 |_ -> raise (unexpected ps)
                             end
                           else
-                            let pats =
-                              paren_comma_list parse_pat ps
-                            in
-                            Ast.PAT_tag ((span ps apos bpos name), pats)
+                            let lv = name_to_lval apos bpos name in
+                              Ast.PAT_tag (lv, paren_comma_list parse_pat ps)
+
                       | LIT_INT _ | LIT_CHAR _ | LIT_BOOL _ ->
                           Ast.PAT_lit (Pexp.parse_lit ps)
+
                       | UNDERSCORE -> bump ps; Ast.PAT_wild
+
                       | tok -> raise (Parse_err (ps,
                           "Expected pattern but found '" ^
                             (string_of_tok tok) ^ "'"))
-- 
cgit v1.2.3