diff options
Diffstat (limited to 'perl_checker.src/lexer.mll')
| -rw-r--r-- | perl_checker.src/lexer.mll | 423 |
1 files changed, 423 insertions, 0 deletions
diff --git a/perl_checker.src/lexer.mll b/perl_checker.src/lexer.mll new file mode 100644 index 0000000..73c40bb --- /dev/null +++ b/perl_checker.src/lexer.mll @@ -0,0 +1,423 @@ +{ (* -*- caml -*- *) +open Parser +open Common +open Lexing +open Info + + +let next_rule = ref None + +let here_docs = Queue.create() +let current_here_doc_mark = ref "" + +let delimit_char = ref '/' +let not_ok_for_match = ref (-1) +let string_nestness = ref 0 + +let building_current_string = ref "" +let current_string_start_pos = ref 0 + +let ins_with_offset offset t lexbuf = + building_current_string := ""; current_string_start_pos := lexeme_start lexbuf + offset; + t lexbuf ; + !building_current_string, (!current_file, !current_string_start_pos, lexeme_end lexbuf) +let ins t lexbuf = ins_with_offset 0 t lexbuf +let ins_to_string t lexbuf = + let s, pos = ins t lexbuf in + not_ok_for_match := lexeme_end lexbuf; + STRING(s, pos) + +let next_s s t lexbuf = + building_current_string := !building_current_string ^ s ; + t lexbuf +let next t lexbuf = next_s (lexeme lexbuf) t lexbuf + +let pos lexbuf = !current_file, lexeme_start lexbuf, lexeme_end lexbuf + +let pos2sfull_with start end_ = Info.pos2sfull (!current_file, start, end_) + +let pos2sfull lexbuf = pos2sfull_with (lexeme_start lexbuf) (lexeme_end lexbuf) + +let die lexbuf err = failwith (pos2sfull_with !current_string_start_pos (lexeme_end lexbuf) ^ err) + +let rec lexbuf2list t lexbuf = + let rec f () = + match t lexbuf with + | EOF -> [] + | e -> e :: f() + in + let l = f() in + l + +let ident_type_from_char fq name lexbuf c = + not_ok_for_match := lexeme_end lexbuf; + match c with + | '$' -> SCALAR_IDENT(fq, name, pos lexbuf) + | '@' -> ARRAY_IDENT (fq, name, pos lexbuf) + | '%' -> HASH_IDENT (fq, name, pos lexbuf) + | '&' -> FUNC_IDENT (fq, name, pos lexbuf) + | '*' -> STAR_IDENT (fq, name, pos lexbuf) + | _ -> internal_error "ident_type_from_char" + +let ident_from_lexbuf lexbuf = + let fq, name = split_at_two_colons (lexeme lexbuf) in + RAW_IDENT(Some fq, name, pos lexbuf) + +let typed_ident_from_lexbuf lexbuf = + let s = lexeme lexbuf in + ident_type_from_char None (skip_n_char 1 s) lexbuf s.[0] + +let typed_fqident_from_lexbuf lexbuf = + let s = lexeme lexbuf in + let fq, name = split_at_two_colons (skip_n_char 1 s) in + ident_type_from_char (Some fq) name lexbuf s.[0] + +let arraylen_ident_from_lexbuf lexbuf = + not_ok_for_match := lexeme_end lexbuf; + let s = lexeme lexbuf in + ARRAYLEN_IDENT(None, skip_n_char 2 s, pos lexbuf) + +let arraylen_fqident_from_lexbuf lexbuf = + let s = lexeme lexbuf in + let fq, name = split_at_two_colons (skip_n_char 2 s) in + ARRAYLEN_IDENT(Some fq, name, pos lexbuf) + +} + +let space = [' ' '\t'] +let stash = [ '$' '@' '%' '&' '*' ] +let ident_start = ['a'-'z' 'A'-'Z' '_'] +let ident = ident_start ['0'-'9' 'A'-'Z' 'a'-'z' '_'] * +let pattern_separator = [ '/' '!' ',' '|' ] + +rule token = parse +| space+ { + (* propagate not_ok_for_match when it was set by the previous token *) + if lexeme_start lexbuf = !not_ok_for_match then not_ok_for_match := lexeme_end lexbuf; + (*SPACE(pos lexbuf) *) token lexbuf + } +| '#' [^ '\n']* { (*COMMENT(lexeme lexbuf, pos lexbuf)*) token lexbuf } + +| "\n=" { + let s, pos = ins_with_offset 1 pod_command lexbuf in POD(s, pos) } + +| '\n' { + lpush current_file_lines_starts (lexeme_end lexbuf); + (try + let (interpolate, mark, r) = Queue.pop here_docs in + current_here_doc_mark := mark ; + r := ins (if interpolate then here_doc else raw_here_doc) lexbuf + with Queue.Empty -> ()); + token lexbuf + } +| "->" { ARROW } +| "++" { INCR } +| "--" { DECR } +| "**" { POWER } +| "!" { TIGHT_NOT } +| "~" { BIT_NEG } +| "=~" { PATTERN_MATCH } +| "!~" { PATTERN_MATCH_NOT } +| "*" { MULT } +| "%" { MODULO } +| "x" { REPLICATE } +| "+" { PLUS } +| "-" { MINUS } +| "." { CONCAT } +| "<<" { BIT_SHIFT_LEFT } +| ">>" { BIT_SHIFT_RIGHT } +| "<" | ">" | "<=" | ">=" | "lt" | "gt" | "le" | "ge" { COMPARE_OP(lexeme lexbuf) } +| "==" | "!=" | "<=>" | "eq" | "ne" | "cmp" { EQ_OP(lexeme lexbuf) } +| "&" { BIT_AND } +| "|" { BIT_OR } +| "^" { BIT_XOR } +| "&&" { AND_TIGHT } +| "||" { OR_TIGHT } +| ".." { DOTDOT } +| "..." { DOTDOTDOT } +| "?" { QUESTION_MARK } +| ":" { COLON } +| "::" { PKG_SCOPE } + +| "=" | "+=" | "-=" | "*=" | "/=" | ".=" | "|=" | "&=" | "^=" | "||=" | "&&=" { ASSIGN(lexeme lexbuf) } + +| "," { COMMA } +| "=>" { RIGHT_ARROW } +| "not" { NOT } +| "and" { AND } +| "or" { OR } +| "xor" { XOR } + +| "if" { IF } +| "unless" { UNLESS } +| "do" { DO } +| "while" { WHILE } +| "until" { UNTIL } +| "foreach" { FOR("foreach") } +| "for" { FOR("for") } +| "my" { MY } +| "local" { LOCAL } +| "continue" { CONTINUE } +| "sub" { SUB } +| "format" { FORMAT } +| "package" { PACKAGE } +| "use" { USE } +| "print" { PRINT(pos lexbuf) } +| "new" { NEW(pos lexbuf) } + +| '@' { AT } +| '$' { DOLLAR } +| '%' { PERCENT } +| '&' { AMPERSAND } +| '*' { STAR } +| "$#" { ARRAYLEN } + + +| ';' { SEMI_COLON } +| '(' { PAREN } +| '{' { BRACKET } +| '[' { ARRAYREF } +| ')' { not_ok_for_match := lexeme_end lexbuf; PAREN_END } +| '}' { not_ok_for_match := lexeme_end lexbuf; BRACKET_END } +| ']' { not_ok_for_match := lexeme_end lexbuf; ARRAYREF_END } + +| '(' [ '$' '@' '\\' '&' ';' ]+ ')' { + (* bloody prototypes, must be caught especially otherwise "($)" is badly tokenized *) + PROTOTYPE(lexeme lexbuf, pos lexbuf) + } + +| "/" { + if lexeme_start lexbuf = !not_ok_for_match then DIVISION + else ( + delimit_char := '/' ; + let s, pos = ins delimited_string lexbuf in + let opts, _ = ins pattern_options lexbuf in + PATTERN(s, opts, pos) + ) + } + +| "m" pattern_separator { + delimit_char := lexeme_char lexbuf 1 ; + let s, pos = ins delimited_string lexbuf in + let opts, _ = ins pattern_options lexbuf in + PATTERN(s, opts, pos) +} + +| "qr" pattern_separator { + delimit_char := lexeme_char lexbuf 2 ; + let s, pos = ins delimited_string lexbuf in + let opts, _ = ins pattern_options lexbuf in + PATTERN(s, opts, pos) +} + +| "s" pattern_separator { + delimit_char := lexeme_char lexbuf 1 ; + let s1, (_, start, _) = ins delimited_string lexbuf in + let s2, (_, _, end_) = ins delimited_string lexbuf in + let opts, _ = ins pattern_options lexbuf in + PATTERN_SUBST(s1, s2, opts, (!current_file, start, end_)) +} + +| "tr" pattern_separator { + delimit_char := lexeme_char lexbuf 2 ; + let s1, (_, start, _) = ins delimited_string lexbuf in + let s2, (_, _, end_) = ins delimited_string lexbuf in + let opts, _ = ins pattern_options lexbuf in + PATTERN_SUBST(s1, s2, opts, (!current_file, start, end_)) +} + +| "<<" ident { + let here_doc_ref = ref("", bpos) in + Queue.push (true, skip_n_char 2 (lexeme lexbuf), here_doc_ref) here_docs ; + HERE_DOC here_doc_ref + } +| "<<'" ident "'" { + not_ok_for_match := lexeme_end lexbuf; + let here_doc_ref = ref("", bpos) in + Queue.push (false, skip_n_char_ 3 1 (lexeme lexbuf), here_doc_ref) here_docs ; + HERE_DOC here_doc_ref + } +| "<<" space+ "'" +| "<<" space+ ident { + failwith (pos2sfull_with (lexeme_start lexbuf + 2) (lexeme_end lexbuf) ^ "No space allowed between \"<<\" and the marker") + } +| "<<" space* '"' { + failwith (pos2sfull_with (lexeme_start lexbuf + 2) (lexeme_end lexbuf) ^ "Don't use <<\"MARK\", use <<MARK instead") + } + +| "\\" stash +| "\\" ['0'-'9' 'A'-'Z' 'a'-'z'] +| "\\" space* '(' + { lexbuf.Lexing.lex_curr_pos <- lexbuf.Lexing.lex_curr_pos - 1; REF } + +| "$#" ident? ("::" ident)+ { arraylen_fqident_from_lexbuf lexbuf } +| "$#" ident { arraylen_ident_from_lexbuf lexbuf } + +| stash ident? ("::" ident)+ { typed_fqident_from_lexbuf lexbuf } +| stash ident +| stash '^'? [^ '{' ' ' '\t' '\n'] { typed_ident_from_lexbuf lexbuf } + +| ident? ("::" ident)+ { ident_from_lexbuf lexbuf } +| ident { BAREWORD(lexeme lexbuf, pos lexbuf) } + +| ident ":" { LABEL(lexeme lexbuf, pos lexbuf) } + +| ['0'-'9'] ['0'-'9' '_']* ('.' ['0'-'9'] ['0'-'9' '_']*)+ +| 'v' ['0'-'9'] ['0'-'9' '_']* ('.' ['0'-'9'] ['0'-'9' '_']*)* + { + not_ok_for_match := lexeme_end lexbuf; + REVISION(lexeme lexbuf, pos lexbuf) + } + +| ['0'-'9']* '.' ['0'-'9']+ (['e' 'E']['-' '+']?['0'-'9']+)? { + not_ok_for_match := lexeme_end lexbuf; + NUM(lexeme lexbuf, pos lexbuf) + } +| ['0'-'9'] ['0'-'9' '_']* { + not_ok_for_match := lexeme_end lexbuf; + NUM(lexeme lexbuf, pos lexbuf) + } +| "0x" ['0'-'9' 'a'-'f' 'A'-'F']+ { + not_ok_for_match := lexeme_end lexbuf; + NUM(lexeme lexbuf, pos lexbuf) + } + +| '"' { ins_to_string string lexbuf } +| "'" { ins_to_string rawstring lexbuf } +| '`' { delimit_char := '`'; + not_ok_for_match := lexeme_end lexbuf; + let s, pos = ins delimited_string lexbuf in COMMAND_STRING(s, pos) } +| "q(" { ins_to_string qstring lexbuf } +| "qq(" { ins_to_string qqstring lexbuf } +| "qw(" { let s, pos = ins qstring lexbuf in QUOTEWORDS(s, pos) } + +| eof { EOF } +| _ { failwith (Printf.sprintf "%serror tokenizing <<%s>>" (pos2sfull lexbuf) (lexeme lexbuf)) } + +and string = parse + '"' { () } +| '\\' { next_rule := Some string ; string_escape lexbuf } +| '\n' { + lpush current_file_lines_starts (lexeme_end lexbuf); + next string lexbuf + } +| [^ '\n' '\\' '"']+ { next string lexbuf } +| eof { die lexbuf "Unterminated_string" } + +and delimited_string = parse +| '\\' { next_rule := Some delimited_string ; string_escape lexbuf } +| '\n' { + lpush current_file_lines_starts (lexeme_end lexbuf); + next delimited_string lexbuf + } +| eof { die lexbuf "Unterminated_delimited_string" } +| [ ^ '\\' '\n' ] { if lexeme_char lexbuf 0 <> !delimit_char then next delimited_string lexbuf } + +and rawstring = parse + ''' { () } +| '\n' { + lpush current_file_lines_starts (lexeme_end lexbuf); + next rawstring lexbuf + } +| "\\'" +| [^ '\n' ''']+ { next rawstring lexbuf } +| eof { die lexbuf "Unterminated_rawstring" } + +and qqstring = parse + ')' { + if !string_nestness <> 0 then (decr string_nestness; next qqstring lexbuf) + } +| '(' { + incr string_nestness; + next qqstring lexbuf + } +| '\\' { next_rule := Some qqstring ; string_escape lexbuf } +| '\n' { + lpush current_file_lines_starts (lexeme_end lexbuf); + next qqstring lexbuf + } +| [^ '\n' '(' ')' '\\']+ { next qqstring lexbuf } +| eof { die lexbuf "Unterminated_qqstring" } + +and qstring = parse +| ')' { + if !string_nestness <> 0 then (decr string_nestness ; next qstring lexbuf) + } +| '(' { + incr string_nestness; + next qstring lexbuf + } +| '\n' { + lpush current_file_lines_starts (lexeme_end lexbuf); + next qstring lexbuf + } +| [^ '\n' '(' ')']+ { next qstring lexbuf } +| eof { die lexbuf "Unterminated_qstring" } + +and here_doc = parse +| '\\' { next_rule := Some here_doc ; string_escape lexbuf } +| [ ^ '\n' '\\' ]* { + let s = lexeme lexbuf in + if chomps s <> !current_here_doc_mark + then next_s s here_doc lexbuf + else if s <> !current_here_doc_mark then Printf.eprintf "%sTrailing spaces after HERE-document mark\n" (pos2sfull lexbuf) + } +| '\n' { + lpush current_file_lines_starts (lexeme_end lexbuf); + next here_doc lexbuf + } +| eof { die lexbuf "Unterminated_here_doc" } + +and raw_here_doc = parse +| [ ^ '\n' ]* { + let s = lexeme lexbuf in + if chomps s <> !current_here_doc_mark + then next_s s raw_here_doc lexbuf + else if s <> !current_here_doc_mark then Printf.eprintf "%sTrailing spaces after HERE-document mark\n" (pos2sfull lexbuf) + } +| '\n' { + lpush current_file_lines_starts (lexeme_end lexbuf); + next raw_here_doc lexbuf + } +| eof { die lexbuf "Unterminated_raw_here_doc" } + + +and string_escape = parse +| '0' { next_s "\000" (some !next_rule) lexbuf } +| '"' { next_s "\"" (some !next_rule) lexbuf } +| ''' { next_s "'" (some !next_rule) lexbuf } +| 'n' { next_s "\n" (some !next_rule) lexbuf } +| 't' { next_s "\t" (some !next_rule) lexbuf } +| 'x' _ _ { + try + let s = String.make 1 (Char.chr (int_of_string ("0" ^ lexeme lexbuf))) in + next_s s (some !next_rule) lexbuf + with Failure("int_of_string") -> die lexbuf ("Bad_hex_in_string \"" ^ lexeme lexbuf ^ "\"") + } +| _ { next_s ("\\" ^ lexeme lexbuf) (some !next_rule) lexbuf } + +and pattern_options = parse +| [ 'g' 'i' 'm' 'o' 's' 'x' 'e' ] { next pattern_options lexbuf } +| _ { lexbuf.Lexing.lex_curr_pos <- lexbuf.Lexing.lex_curr_pos - 1; () } + +and pod_command = parse +| [^ '\n' ]+ { + let s = lexeme lexbuf in + if String.contains s '\t' then failwith(pos2sfull lexbuf ^ "tabulations not accepted in POD commands") else + let command = String.sub s 0 (try String.index s ' ' with Not_found -> String.length s) in + match command with + | "cut" -> + if !building_current_string = "" then + failwith(pos2sfull lexbuf ^ "found POD command \"=cut\" but it is not a POD block") + | "head1" | "head2" | "head3" | "head4" | "over" | "item" | "back" | "pod" | "begin" | "end" | "for" -> + next pod lexbuf + | s -> failwith(pos2sfull lexbuf ^ "unknown POD command \"" ^ s ^ "\"") + } +| _ { failwith(pos2sfull lexbuf ^ "POD command expected") } + +and pod = parse +| "\n=" { next pod_command lexbuf } +| "\n" [^ '=' '\n'] [^ '\n']* +| "\n" { next pod lexbuf } +| eof +| _ { failwith(pos2sfull_with !current_string_start_pos (lexeme_end lexbuf) ^ "POD block still open") } |