From 0830b5bf24a7117130e0089754cd96e51411284d Mon Sep 17 00:00:00 2001 From: Or Brostovski Date: Sat, 21 Aug 2010 02:41:43 +0300 Subject: [PATCH] Modified parser to handle alt type andadded a few tests ast.ml - modified arm types for easier polymorphism - fixed a bug in fmt_type_arm dead.ml - modified arm types for easier polymorphism common.ml - added 'either' - added some useful auxiliary functions item.ml - modified arm code to be more polymorphic and handle both alt-tag and alt-type, also fixed the problematic case in bad-alt.rs Makefile - added XFAIL for new alt-type test bad-alt.rs - added test for invalid alt syntax alt-type-simple.rs - added simple test for alt type --- src/Makefile | 1 + src/boot/fe/ast.ml | 9 +- src/boot/fe/item.ml | 172 +++++++++++++++++---------- src/boot/me/dead.ml | 2 +- src/boot/util/common.ml | 31 +++++ src/test/compile-fail/bad-alt.rs | 6 + src/test/run-pass/alt-type-simple.rs | 11 ++ 7 files changed, 166 insertions(+), 66 deletions(-) create mode 100644 src/test/compile-fail/bad-alt.rs create mode 100644 src/test/run-pass/alt-type-simple.rs diff --git a/src/Makefile b/src/Makefile index 1d79a46700a..10810c05d81 100644 --- a/src/Makefile +++ b/src/Makefile @@ -362,6 +362,7 @@ self: $(CFG_COMPILER) # of inter-task shutdown races introduced with notification proxies. TASK_XFAILS := test/run-pass/acyclic-unwind.rs \ + test/run-pass/alt-type-simple.rs \ test/run-pass/basic.rs \ test/run-pass/clone-with-exterior.rs \ test/run-pass/comm.rs \ diff --git a/src/boot/fe/ast.ml b/src/boot/fe/ast.ml index 6cd1114aaa2..3f3d5145f1d 100644 --- a/src/boot/fe/ast.ml +++ b/src/boot/fe/ast.ml @@ -322,7 +322,7 @@ and pat = and tag_arm' = pat * block and tag_arm = tag_arm' identified -and type_arm' = ident * slot * block +and type_arm' = (ident * slot) * block and type_arm = type_arm' identified and port_arm' = port_case * block @@ -1305,8 +1305,11 @@ and fmt_tag_arm (ff:Format.formatter) (tag_arm:tag_arm) : unit = fmt_arm ff (fun ff -> fmt_pat ff pat) block; and fmt_type_arm (ff:Format.formatter) (type_arm:type_arm) : unit = - let (_, slot, block) = type_arm.node in - fmt_arm ff (fun ff -> fmt_slot ff slot) block; + let ((ident, slot), block) = type_arm.node in + let fmt_type_arm_case (ff:Format.formatter) = + fmt_slot ff slot; fmt ff " "; fmt_ident ff ident + in + fmt_arm ff fmt_type_arm_case block; and fmt_port_arm (ff:Format.formatter) (port_arm:port_arm) : unit = let (port_case, block) = port_arm.node in diff --git a/src/boot/fe/item.ml b/src/boot/fe/item.ml index 82ec2fafc10..67a482a643e 100644 --- a/src/boot/fe/item.ml +++ b/src/boot/fe/item.ml @@ -225,69 +225,117 @@ and parse_stmts (ps:pstate) : Ast.stmt array = | ALT -> bump ps; - begin + let rec parse_pat ps = match peek ps with - TYPE -> [| |] - | LPAREN -> - let (stmts, lval) = bracketed LPAREN RPAREN parse_lval ps in - let rec parse_pat ps = - match peek ps with - IDENT _ -> - let apos = lexpos ps in - let name = Pexp.parse_name ps in - let bpos = lexpos ps in - - if peek ps != LPAREN then - begin - match name with - Ast.NAME_base (Ast.BASE_ident ident) -> - let slot = - { Ast.slot_mode = Ast.MODE_local; - Ast.slot_ty = None } - in - Ast.PAT_slot - ((span ps apos bpos slot), ident) - |_ -> raise (unexpected ps) - end - else - let lv = name_to_lval apos bpos name in - Ast.PAT_tag (lv, paren_comma_list parse_pat ps) - - | LIT_INT _ - | LIT_UINT _ - | 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) ^ "'")) - in - let rec parse_arms ps = - match peek ps with - CASE -> - bump ps; - let pat = bracketed LPAREN RPAREN parse_pat ps in - let block = parse_block ps in - let arm = (pat, block) in - (span ps apos (lexpos ps) arm)::(parse_arms ps) - | _ -> [] - in - let parse_alt_block ps = - let arms = ctxt "alt tag arms" parse_arms ps in - spans ps stmts apos begin - Ast.STMT_alt_tag { - Ast.alt_tag_lval = lval; - Ast.alt_tag_arms = Array.of_list arms - } - end - in - bracketed LBRACE RBRACE parse_alt_block ps - | _ -> [| |] - end - + IDENT _ -> + let apos = lexpos ps in + let name = Pexp.parse_name ps in + let bpos = lexpos ps in + + if peek ps != LPAREN then + begin + match name with + Ast.NAME_base (Ast.BASE_ident ident) -> + let slot = + { Ast.slot_mode = Ast.MODE_local; + Ast.slot_ty = None } + in + Left + (Ast.PAT_slot ((span ps apos bpos slot), + ident)) + |_ -> raise (unexpected ps) + end + else + let lv = name_to_lval apos bpos name in + let parse_pat ps = either_get_left (parse_pat ps) in + Left + (Ast.PAT_tag (lv, paren_comma_list parse_pat ps)) + + | LIT_INT _ + | LIT_UINT _ + | LIT_CHAR _ + | LIT_BOOL _ -> + Left (Ast.PAT_lit (Pexp.parse_lit ps)) + + | UNDERSCORE -> bump ps; Left (Ast.PAT_wild) + + | tok -> raise (Parse_err (ps, + "Expected pattern but found '" ^ + (string_of_tok tok) ^ "'")) + in + let rec parse_arms ps parse_case = + match peek ps with + CASE -> + bump ps; + let case = parse_case ps in + let blk = parse_block ps in + let combine_and_span case = + (span ps apos (lexpos ps) (case, blk)) in + let is_default = either_has_right case in + if is_default then + let arm = combine_and_span (either_get_right case) in + ([], Some arm) + else + let rec_result = parse_arms ps parse_case in + let arm = combine_and_span (either_get_left case) in + (arm::(fst rec_result), (snd rec_result)) + | _ -> ([], None) + in + let parse_alt_block ps str parse_case make_stmt = + let br_parse_case = bracketed LPAREN RPAREN parse_case in + let arms = (ctxt (String.concat " " ["alt"; str; "arms"]) + (fun ps -> parse_arms ps br_parse_case) ps) in + make_stmt (fst arms) (snd arms) + in + let which_alt = match peek ps with + TYPE -> "type" | LPAREN -> "tag" | _ -> raise (unexpected ps) + in + let (stmts, lval) = if which_alt = "type" then bump ps; + bracketed LPAREN RPAREN parse_lval ps + in + let make_alt_tag_stmt val_arms dflt_arm = + assert (not (bool_of_option dflt_arm)); + spans ps stmts apos begin + Ast.STMT_alt_tag { + Ast.alt_tag_lval = lval; + Ast.alt_tag_arms = Array.of_list val_arms; + } + end + in + let make_alt_type_stmt val_arms dflt_arm = + spans ps stmts apos begin + Ast.STMT_alt_type { + Ast.alt_type_lval = lval; + Ast.alt_type_arms = Array.of_list val_arms; + Ast.alt_type_else = option_map (fun x -> snd x.node) dflt_arm; + } + end + in + let parse_slot_and_ident ps = + match peek ps with + UNDERSCORE -> Right () + | _ -> Left (pair_rev (Pexp.parse_slot_and_ident false ps)) + + in + let parse_alt_tag_block ps = + parse_alt_block ps + "tag" + parse_pat + make_alt_tag_stmt + in + let parse_alt_type_block ps = + parse_alt_block ps + "type" + parse_slot_and_ident + make_alt_type_stmt + in + let parse_alt_block2 ps = + match which_alt with + "type" -> parse_alt_type_block ps + | "tag" -> parse_alt_tag_block ps + | _ -> assert false + in + bracketed LBRACE RBRACE parse_alt_block2 ps | IF -> let final_else = ref None in let rec parse_stmt_if _ = diff --git a/src/boot/me/dead.ml b/src/boot/me/dead.ml index 7ef4bf8e3e3..a0b666b3f19 100644 --- a/src/boot/me/dead.ml +++ b/src/boot/me/dead.ml @@ -70,7 +70,7 @@ let dead_code_visitor | Ast.STMT_alt_type { Ast.alt_type_arms = arms; Ast.alt_type_else = alt_type_else } -> - let arm_ids = Array.map (fun { node = (_, _, block) } -> + let arm_ids = Array.map (fun { node = ((_, _), block) } -> block.id) arms in let else_ids = begin diff --git a/src/boot/util/common.ml b/src/boot/util/common.ml index 58caf78d0f9..3a467f1c827 100644 --- a/src/boot/util/common.ml +++ b/src/boot/util/common.ml @@ -3,6 +3,8 @@ * types shared across all phases of the compiler. *) +type ('a, 'b) either = Left of 'a | Right of 'b + type filename = string type pos = (filename * int * int) type span = {lo: pos; hi: pos} @@ -343,6 +345,11 @@ let rec list_drop n ls = ;; +(* + * Auxiliary pair functions. + *) +let pair_rev (x,y) = (y,x) + (* * Auxiliary option functions. *) @@ -357,11 +364,35 @@ let may f x = Some x' -> f x' | None -> () +let option_map f x = + match x with + Some x' -> Some (f x') + | None -> None + let option_get x = match x with Some x -> x | None -> raise Not_found +(* + * Auxiliary either functions. + *) +let either_has_left x = + match x with + Left _ -> true + | Right _ -> false + +let either_has_right x = not (either_has_left x) + +let either_get_left x = + match x with + Left x -> x + | Right _ -> raise Not_found + +let either_get_right x = + match x with + Right x -> x + | Left _ -> raise Not_found (* * Auxiliary stack functions. *) diff --git a/src/test/compile-fail/bad-alt.rs b/src/test/compile-fail/bad-alt.rs new file mode 100644 index 00000000000..f2582879ce5 --- /dev/null +++ b/src/test/compile-fail/bad-alt.rs @@ -0,0 +1,6 @@ +// error-pattern: Unexpected token 'x' + +fn main() { + let int x = 5; + alt x; +} diff --git a/src/test/run-pass/alt-type-simple.rs b/src/test/run-pass/alt-type-simple.rs new file mode 100644 index 00000000000..85f6ff68459 --- /dev/null +++ b/src/test/run-pass/alt-type-simple.rs @@ -0,0 +1,11 @@ +fn altsimple(any x) { + alt type (f) { + case (int i) { print("int"); } + case (str s) { print("str"); } + } +} + +fn main() { + altsimple(5); + altsimple("asdfasdfsDF"); +}