diff options
| -rw-r--r-- | src/Makefile | 1 | ||||
| -rw-r--r-- | src/boot/fe/ast.ml | 2 | ||||
| -rw-r--r-- | src/boot/fe/item.ml | 25 | ||||
| -rw-r--r-- | src/boot/me/resolve.ml | 69 | ||||
| -rw-r--r-- | src/boot/me/semant.ml | 23 | ||||
| -rw-r--r-- | src/boot/me/trans.ml | 4 | ||||
| -rw-r--r-- | src/boot/me/type.ml | 168 | ||||
| -rw-r--r-- | src/boot/me/walk.ml | 4 | ||||
| -rw-r--r-- | src/test/run-pass/alt-pattern-simple.rs | 7 |
9 files changed, 223 insertions, 80 deletions
diff --git a/src/Makefile b/src/Makefile index 5d4e6aa0..bc187567 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 bf7a11ff..438d9de9 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 75f86a58..209526e5 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 8f034aee..bfbac10d 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 b5000ff3..f7acccfb 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 bca15136..a7ff502c 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 2d4dd94a..2dd27144 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 3486bb16..a8d74cad 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 00000000..d0a4159e --- /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() {} |