diff options
Diffstat (limited to 'perl_checker.src/parser_helper.ml')
| -rw-r--r-- | perl_checker.src/parser_helper.ml | 164 |
1 files changed, 144 insertions, 20 deletions
diff --git a/perl_checker.src/parser_helper.ml b/perl_checker.src/parser_helper.ml index 2a1bce2..d4c5842 100644 --- a/perl_checker.src/parser_helper.ml +++ b/perl_checker.src/parser_helper.ml @@ -13,11 +13,14 @@ let get_pos_end { pos = (_, end_) } = end_ let var_dollar_ pos = Deref(I_scalar, Ident(None, "_", pos)) let var_STDOUT = Deref(I_star, Ident(None, "STDOUT", raw_pos2pos bpos)) -let new_any any spaces pos = { any = any ; spaces = spaces ; pos = pos } -let new_esp e esp_start esp_end = new_any e esp_start.spaces (raw_pos_range esp_start esp_end) -let new_pesp prio e esp_start esp_end = new_any { priority = prio ; expr = e } esp_start.spaces (raw_pos_range esp_start esp_end) -let default_esp e = new_any e Space_none bpos -let default_pesp prio e = new_any { priority = prio ; expr = e } Space_none bpos +let new_any mcontext any spaces pos = { mcontext = mcontext ; any = any ; spaces = spaces ; pos = pos } +let new_any_ any spaces pos = new_any M_unknown any spaces pos +let new_esp mcontext e esp_start esp_end = new_any mcontext e esp_start.spaces (raw_pos_range esp_start esp_end) +let new_1esp e esp = new_any esp.mcontext e esp.spaces esp.pos +let new_pesp mcontext prio e esp_start esp_end = new_any mcontext { priority = prio ; expr = e } esp_start.spaces (raw_pos_range esp_start esp_end) +let new_1pesp prio e esp = new_any esp.mcontext { priority = prio ; expr = e } esp.spaces esp.pos +let default_esp e = new_any M_unknown e Space_none bpos +let default_pesp prio e = new_any M_unknown { priority = prio ; expr = e } Space_none bpos let split_name_or_fq_name full_ident = match split_at2 ':'':' full_ident with @@ -290,28 +293,47 @@ let sp_same esp1 esp2 = if esp1.spaces <> Space_0 then sp_p esp2 else if esp2.spaces <> Space_0 then sp_p esp1 -let check_word_alone word = - match word with +let word_alone esp = + let word = esp.any in + let mcontext, e = match word with | Ident(None, f, pos) -> - (match f with + let e = match f with | "length" | "stat" | "lstat" | "chop" | "chomp" | "quotemeta" | "lc" | "lcfirst" | "uc" | "ucfirst" -> Call(Deref(I_func, word), [var_dollar_ pos]) - + | "split" -> Call(Deref(I_func, word), [ Raw_string(" ", pos) ; var_dollar_ pos ]) | "shift" -> Call(Deref(I_func, word), [ Deref(I_array, Ident(None, "_", raw_pos2pos bpos)) ]) | "die" -> Call(Deref(I_func, word), [ Deref(I_scalar, Ident(None, "@", raw_pos2pos bpos)) ]) | "return" | "eof" | "caller" | "redo" | "next" | "last" -> Deref(I_func, word) - + | "hex" | "ref" -> warn_rule (sprintf "please use \"%s $_\" instead of \"%s\"" f f) ; Call(Deref(I_func, word), [ Raw_string(" ", pos) ; var_dollar_ pos ]) | "time" | "wantarray" | "fork" | "getppid" | "arch" -> warn_rule (sprintf "please use %s() instead of %s" f f) ; Deref(I_func, word) - | _ -> word) - | _ -> word + | _ -> word + in + let mcontext = match f with + | "chop" | "chomp" -> M_none + | "hex" | "length" | "time" | "fork" | "getppid" -> M_int + | "eof" | "wantarray" -> M_int + | "stat" | "lstat" -> M_list + | "arch" | "quotemeta" | "lc" | "lcfirst" | "uc" | "ucfirst" -> M_string + + | "split" -> M_array + | "shift" -> M_scalar + | "die" | "return" | "redo" | "next" | "last" -> M_unknown + | "caller" -> M_mixed(M_string, M_list) + + | "ref" -> M_ref M_scalar + | _ -> M_unknown + in mcontext, e + | _ -> M_unknown, word + in + new_pesp mcontext P_tok e esp esp let check_parenthesized_first_argexpr word esp = let want_space = word.[0] = '-' in @@ -412,7 +434,6 @@ let check_unneeded_var_dollar_s esp = if is_var_dollar_ esp.any.expr then warn esp.pos "\"$_ =~ s/regexp/.../\" can be written \"s/regexp/.../\"" else if is_var_number_match esp.any.expr then die_with_rawpos esp.pos "do not modify the result of a match (eg: $1)" -let check_MULT_is_x esp = if esp.any <> "x" then die_rule "syntax error" let check_my esp = if esp.any <> "my" then die_rule "syntax error" let check_foreach esp = if esp.any = "for" then warn esp.pos "write \"foreach\" instead of \"for\"" let check_for esp = if esp.any = "foreach" then warn esp.pos "write \"for\" instead of \"foreach\"" @@ -600,12 +621,12 @@ let cook_call_op op para pos = | _ -> call -let to_Call_op op para esp_start esp_end = +let to_Call_op mcontext op para esp_start esp_end = let pos = raw_pos_range esp_start esp_end in - new_any (cook_call_op op para pos) esp_start.spaces pos -let to_Call_op_ prio op para esp_start esp_end = + new_any mcontext (cook_call_op op para pos) esp_start.spaces pos +let to_Call_op_ mcontext prio op para esp_start esp_end = let pos = raw_pos_range esp_start esp_end in - new_any { priority = prio ; expr = cook_call_op op para pos } esp_start.spaces pos + new_any mcontext { priority = prio ; expr = cook_call_op op para pos } esp_start.spaces pos let followed_by_comma pesp true_comma = if true_comma.any then pesp.any.expr else @@ -749,7 +770,7 @@ let call_one_scalar_para { any = e ; pos = pos } para esp_start esp_end = [var_dollar_ (raw_pos2pos pos)] | _ -> para in - new_pesp P_mul (call(Deref(I_func, Ident(None, e, raw_pos2pos pos)), para)) esp_start esp_end + new_pesp M_unknown P_mul (call(Deref(I_func, Ident(None, e, raw_pos2pos pos)), para)) esp_start esp_end let call_op_if_infix left right esp_start esp_end = @@ -760,7 +781,7 @@ let call_op_if_infix left right esp_start esp_end = warn_rule "\"$foo = ... if !$foo\" can be written \"$foo ||= ...\"" | _ -> ()); let pos = raw_pos_range esp_start esp_end in - new_any (Call_op("if infix", [ left ; right], raw_pos2pos pos)) esp_start.spaces pos + new_any M_none (Call_op("if infix", [ left ; right], raw_pos2pos pos)) esp_start.spaces pos let call_op_unless_infix left right esp_start esp_end = (match left, right with @@ -775,7 +796,7 @@ let call_op_unless_infix left right esp_start esp_end = | _ -> ()); | _ -> ()); let pos = raw_pos_range esp_start esp_end in - new_any (Call_op("unless infix", [ left ; right], raw_pos2pos pos)) esp_start.spaces pos + new_any M_none (Call_op("unless infix", [ left ; right], raw_pos2pos pos)) esp_start.spaces pos let (current_lexbuf : Lexing.lexbuf option ref) = ref None @@ -831,3 +852,106 @@ let from_PATTERN_SUBST parse { any = (s1, s2, opts) ; pos = pos } = [ String(parse_interpolated parse s1, raw_pos2pos pos) ; String(parse_interpolated parse s2, raw_pos2pos pos) ; Raw_string(opts, raw_pos2pos pos) ] + + +let rec mcontext2s = function + | M_none -> "()" + + | M_int -> "int" + | M_float -> "float" + | M_string -> "string" + | M_ref c -> "ref(" ^ mcontext2s c ^ ")" + | M_revision -> "revision" + | M_sub -> "sub" + | M_scalar -> "scalar" + + | M_list -> "list" + | M_array -> "array" + | M_hash -> "hash" + + | M_special -> "special" + | M_unknown -> "unknown" + | M_mixed(a, b) -> mcontext2s a ^ " | " ^ mcontext2s b + +let mcontext_is_scalar = function + | M_int | M_float | M_string | M_ref _ | M_revision + | M_scalar | M_array -> true + | _ -> false + +let rec mcontext_lower c1 c2 = + match c1, c2 with + | M_special, _ | _, M_special -> internal_error "M_special in mcontext_compare" + + | M_array, M_array | M_array, M_int | M_array, M_float | M_array, M_scalar | M_array, M_list + | M_hash, M_hash | M_hash, M_scalar | M_hash, M_list + + | M_int, M_int | M_int, M_float | M_int, M_string | M_int, M_scalar | M_int, M_list + | M_float, M_float | M_float, M_string | M_float, M_scalar | M_float, M_list + | M_ref _, M_scalar | M_ref _, M_list + | M_string, M_string | M_string, M_scalar | M_string, M_list + | M_revision, M_revision | M_revision, M_scalar | M_revision, M_list + | M_scalar, M_scalar | M_scalar, M_list + + | M_list, M_list + | M_none, M_none + | M_sub, M_sub + + | _, M_unknown + + -> true + + | M_ref a, M_ref b -> mcontext_lower a b + | M_mixed(c1, c2), M_mixed(a, b) -> mcontext_lower c1 a && mcontext_lower c2 b || mcontext_lower c2 a && mcontext_lower c1 b + | c, M_mixed(a, b) -> mcontext_lower c a || mcontext_lower c b + + | _ -> false + +let mcontext_merge c1 c2 = + if mcontext_lower c1 c2 then c2 else + if mcontext_lower c2 c1 then c1 else + match c1, c2 with + | M_unknown, _ | _, M_unknown -> internal_error "mcontext_merge1" + | M_mixed _, _ | _, M_mixed _ -> internal_error "TODO: complex mcontext_merge" + | _ -> + if mcontext_is_scalar c1 && mcontext_is_scalar c2 + then M_scalar + else M_mixed(c1, c2) +let mcontext_lmerge = function + | [] -> internal_error "mcontext_lmerge" + | e :: l -> List.fold_left mcontext_merge e l + +let mcontext_lmaybe esp = if esp.any = [] then [] else [esp.mcontext] + +let mcontext_check_raw wanted_mcontext esp f_lower f_greater f_err = + if mcontext_lower esp.mcontext wanted_mcontext then + f_lower() + else if mcontext_lower wanted_mcontext esp.mcontext then + f_greater() + else + (warn_rule (sprintf "context %s is not compatible with context %s" (mcontext2s esp.mcontext) (mcontext2s wanted_mcontext)); + f_err()) + +let mcontext_symops wanted_mcontext esp1 esp2 = + mcontext_check_raw wanted_mcontext esp1 + (fun () -> + mcontext_check_raw wanted_mcontext esp2 + (fun () -> + match mcontext_merge esp1.mcontext esp2.mcontext with + | M_array when mcontext_is_scalar wanted_mcontext -> M_int (* don't allow @a + @b to return M_array *) + | r -> r) + (fun () -> mcontext_merge esp1.mcontext wanted_mcontext) + (fun () -> wanted_mcontext)) + (fun () -> + mcontext_check_raw wanted_mcontext esp2 + (fun () -> mcontext_merge wanted_mcontext esp2.mcontext) + (fun () -> wanted_mcontext) + (fun () -> wanted_mcontext)) + (fun () -> wanted_mcontext) + +let mcontext_check wanted_mcontext esp = + mcontext_check_raw wanted_mcontext esp (fun () -> ()) (fun () -> ()) (fun () -> ()) + +let mcontext_unop wanted_mcontext esp = mcontext_check wanted_mcontext esp ; wanted_mcontext + +let mcontext_check_non_none esp = + if esp.mcontext = M_none then warn_rule "() context not accepted here" |