mikros/rust
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Resolve and typecheck patterns in pattern alt.

Browse Source
This commit is contained in:
Roy Frostig 2010-06-24 08:13:32 -07:00
parent f038f4d533
commit bc286c7f2c
9 changed files with 220 additions and 77 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
src/Makefile
View File

@ -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 \

2
src/boot/fe/ast.ml
View File

@ -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

15
src/boot/fe/item.ml
View File

@ -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
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)
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

69
src/boot/me/resolve.ml
View File

@ -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;

23
src/boot/me/semant.ml
View File

@ -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

4
src/boot/me/trans.ml
View File

@ -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

90
src/boot/me/type.ml
View File

@ -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,14 +750,21 @@ 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 =
match atom with
Ast.ATOM_literal { node = literal; id = _ } ->
let ty = match literal with
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
@ -753,7 +773,13 @@ let process_crate (cx:ctxt) (crate:Ast.crate) : unit =
| Ast.LIT_char _ -> Ast.TY_char
in
unify_ty ty tv
| Ast.ATOM_lval lval -> unify_lval lval tv
and unify_atom (atom:Ast.atom) (tv:tyvar) : unit =
match atom with
Ast.ATOM_literal { node = literal; id = _ } ->
unify_lit literal tv
| Ast.ATOM_lval lval ->
unify_lval lval tv
and unify_expr (expr:Ast.expr) (tv:tyvar) : unit =
match expr with
@ -909,7 +935,8 @@ let process_crate (cx:ctxt) (crate:Ast.crate) : unit =
TYSPEC_tuple (Array.init (i + 1) init)
| Ast.COMP_atom atom ->
unify_atom atom (ref (TYSPEC_resolved ([||], Ast.TY_int)));
unify_atom atom
(ref (TYSPEC_resolved ([||], Ast.TY_int)));
TYSPEC_collection tv
in
let base_tv = ref base_ts 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

4
src/boot/me/walk.ml
View File

@ -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

7
src/test/run-pass/alt-pattern-simple.rs Normal file
View File

@ -0,0 +1,7 @@
fn altsimple(int f) {
alt (f) {
case (x) {}
}
}
fn main() {}