diff options
| -rw-r--r-- | perl_checker.src/.cvsignore | 1 | ||||
| -rw-r--r-- | perl_checker.src/Makefile | 7 | ||||
| -rw-r--r-- | perl_checker.src/lexer.mll | 2 | ||||
| -rw-r--r-- | perl_checker.src/parser.mly | 409 | ||||
| -rw-r--r-- | perl_checker.src/perl_checker.ml | 30 |
5 files changed, 253 insertions, 196 deletions
diff --git a/perl_checker.src/.cvsignore b/perl_checker.src/.cvsignore index fe1e303..9d76706 100644 --- a/perl_checker.src/.cvsignore +++ b/perl_checker.src/.cvsignore @@ -6,3 +6,4 @@ gmon.out *.cmo *.cmx parser.ml +parser.output
\ No newline at end of file diff --git a/perl_checker.src/Makefile b/perl_checker.src/Makefile index fcabe3c..1c73153 100644 --- a/perl_checker.src/Makefile +++ b/perl_checker.src/Makefile @@ -3,14 +3,13 @@ CSLC = ocamlc CSLOPT = ocamlopt CSLDEP = ocamldep CSLLEX = ocamllex -CSLYACC = ocamlyacc +CSLYACC = ocamlyacc -v CSLFLAGS = -w A -g CSLOPTFLAGS = LEX_FILES = $(wildcard *.mll) YACC_FILES = $(wildcard *.mly) -TMP_MLFILES = $(YACC_FILES:%.mly=%.ml) $(LEX_FILES:%.mll=%.ml) -TMP_MLIFILES = $(YACC_FILES:%.mly=%.mli) +TMP_FILES = $(YACC_FILES:%.mly=%.mli) $(YACC_FILES:%.mly=%.output) $(YACC_FILES:%.mly=%.ml) $(LEX_FILES:%.mll=%.ml) ALL_PROGS = perl_checker_debug perl_checker @@ -61,7 +60,7 @@ $(PROG_OBJX_WITH_CMI): %.cmx: %.cmi $(CSLC) $(CSLFLAGS) -c $< clean: - rm -f $(ALL_PROGS) *~ *.o *.cm[iox] $(TMP_MLIFILES) $(TMP_MLFILES) .depend .compiling TAGS gmon.out ocamlprof.dump + rm -f $(ALL_PROGS) *~ *.o *.cm[iox] $(TMP_FILES) .depend .compiling TAGS gmon.out ocamlprof.dump tags: ocamltags *.ml diff --git a/perl_checker.src/lexer.mll b/perl_checker.src/lexer.mll index 49f5102..6abbbc2 100644 --- a/perl_checker.src/lexer.mll +++ b/perl_checker.src/lexer.mll @@ -112,7 +112,7 @@ 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 + (*SPACE(pos lexbuf) *) token lexbuf } | '#' [^ '\n']* { (*COMMENT(lexeme lexbuf, pos lexbuf)*) token lexbuf } diff --git a/perl_checker.src/parser.mly b/perl_checker.src/parser.mly index 37ec3ce..0157714 100644 --- a/perl_checker.src/parser.mly +++ b/perl_checker.src/parser.mly @@ -2,8 +2,12 @@ open Types open Common - let parse_error msg = - failwith (Info.pos2sfull_current (Parsing.symbol_start()) (Parsing.symbol_end()) ^ msg) + let die msg = + failwith (Info.pos2sfull_current (Parsing.symbol_start()) (Parsing.symbol_end()) ^ msg) + + let parse_error msg = die msg + + let warn msg = if false then prerr_endline msg let to_Ident = function | BAREWORD(name, pos) -> Ident(I_raw, None, name, pos) @@ -99,199 +103,254 @@ %% -prog: lineseq EOF { "" } - -block: BRACKET lineseq BRACKET_END { $2 } +prog: lines EOF { "" } -lineseq: /* A collection of "lines" in the program */ -| {[]} -| decl lineseq {[]} -| line {[]} -| LABEL lineseq {[]} -| line {[]} +lines: /* A collection of "lines" in the program */ +| {()} +| sideff {()} +| line lines {()} line: -| if_then_else lineseq { [] } -| loop lineseq { [] } -| SEMI_COLON lineseq { [] } -| sideff SEMI_COLON lineseq { [] } - -| sideff { [] } - +| decl {()} +| if_then_else {()} +| loop {()} +| LABEL {()} +| SEMI_COLON {()} +| sideff SEMI_COLON {()} +| BRACKET lines BRACKET_END {()} if_then_else: /* Real conditional expressions */ -| IF PAREN expr PAREN_END block elsif else_ {[]} -| UNLESS PAREN expr PAREN_END block elsif else_ {[]} +| IF PAREN expr PAREN_END BRACKET lines BRACKET_END elsif else_ {()} +| UNLESS PAREN expr PAREN_END BRACKET lines BRACKET_END elsif else_ {()} elsif: -| { [] } -| ELSIF PAREN expr PAREN_END block elsif { [ $3, $5 ] @ $6 } +| {()} +| ELSIF PAREN expr PAREN_END BRACKET lines BRACKET_END elsif {()} else_: -| { None } -| ELSE block { Some $2 } +| { () } +| ELSE BRACKET lines BRACKET_END { () } loop: -| WHILE PAREN expr_or_empty PAREN_END block cont {[]} -| UNTIL PAREN expr PAREN_END block cont {[]} -| FOR MY SCALAR_IDENT PAREN expr PAREN_END block cont {[]} -| FOR SCALAR_IDENT PAREN expr PAREN_END block cont {[]} -| FOR PAREN expr PAREN_END block cont {[]} -| FOR PAREN expr_or_empty SEMI_COLON expr_or_empty SEMI_COLON expr_or_empty PAREN_END block {[]} -| block cont {[]} /* a block is a loop that happens once */ +| WHILE PAREN expr PAREN_END BRACKET lines BRACKET_END cont {()} +| UNTIL PAREN expr PAREN_END BRACKET lines BRACKET_END cont {()} +| FOR MY SCALAR_IDENT PAREN expr PAREN_END BRACKET lines BRACKET_END cont {()} +| FOR SCALAR_IDENT PAREN expr PAREN_END BRACKET lines BRACKET_END cont {()} +| FOR PAREN expr PAREN_END BRACKET lines BRACKET_END cont {()} +| FOR PAREN expr_or_empty SEMI_COLON expr_or_empty SEMI_COLON expr_or_empty PAREN_END BRACKET lines BRACKET_END {()} cont: /* Continue blocks */ -| {[]} -| CONTINUE block {[]} +| {()} +| CONTINUE BRACKET lines BRACKET_END {()} sideff: /* An expression which may have a side-effect */ -| error { [] } -| expr { $1 } -| expr IF expr { [ (*Binary("if", $1, $3)*) ] } -| expr UNLESS expr { [ (*Binary("unless", $1, $3)*) ] } -| expr WHILE expr { [ (*Binary("while", $1, $3)*) ] } -| expr UNTIL expr { [ (*Binary("until", $1, $3)*) ] } -| expr FOR expr { [ (*Binary($2, $1, $3)*) ] } +| error {()} +| expr {()} +| expr IF expr {()} +| expr UNLESS expr {()} +| expr WHILE expr {()} +| expr UNTIL expr {()} +| expr FOR expr {()} decl: -| FORMAT bareword_or_empty ASSIGN {[]} -| SUB word subbody {[]} -| FUNC_DECL_WITH_PROTO subbody {[]} -| PACKAGE word SEMI_COLON {[]} -| BEGIN block {[]} -| END block {[]} -| USE word_or_empty revision_or_empty listexpr SEMI_COLON {[]} - -formname: {[]} | BAREWORD {[]} -subbody: block { $1 } | SEMI_COLON {[]} - +| FORMAT BAREWORD ASSIGN {()} +| FORMAT ASSIGN {()} +| func_decl SEMI_COLON {()} +| func_decl BRACKET lines BRACKET_END {()} +| func_decl BRACKET BRACKET expr BRACKET_END BRACKET_END {()} +| func_decl BRACKET BRACKET expr BRACKET_END SEMI_COLON BRACKET_END {()} +| PACKAGE word SEMI_COLON {()} +| BEGIN BRACKET lines BRACKET_END {()} +| END BRACKET lines BRACKET_END {()} +| use {()} + +use: +| use_word listexpr SEMI_COLON {()} + +use_word: +| use_revision word COLON {()} +| use_revision word {()} +| use_revision {()} + +use_revision: +| USE REVISION COLON {()} +| USE REVISION {()} +| USE {()} + +func_decl: +| SUB word {()} +| FUNC_DECL_WITH_PROTO {()} listexpr: /* Basic list expressions */ -| %prec PREC_LOW {[]} -| argexpr %prec PREC_LOW {[]} +| %prec PREC_LOW {()} +| argexpr %prec PREC_LOW {()} expr: /* Ordinary expressions; logical combinations */ -| expr AND expr {[]} -| expr OR expr {[]} -| argexpr %prec PREC_LOW {[]} +| expr AND expr {()} +| expr OR expr {()} +| argexpr %prec PREC_LOW {()} argexpr: /* Expressions are a list of terms joined by commas */ -| argexpr comma {[]} -| argexpr comma term {[]} -| term %prec PREC_LOW {[]} +| argexpr comma {()} +| argexpr comma term {()} +| argexpr comma BRACKET expr BRACKET_END {()} +| term %prec PREC_LOW {()} +/********************************************************************************/ term: -| term binop term {[]} -| termunop {[]} -| anonymous {[]} -| termdo {[]} -| term QUESTION_MARK term COLON term {[]} -| REF term {[]} /* \$x, \@y, \%z */ -| MY myterm %prec UNIOP {[]} -| LOCAL term %prec UNIOP {[]} -| PAREN expr_or_empty PAREN_END {[]} - -| variable {[]} - -| subscripted {[]} - -| PAREN expr_or_empty PAREN_END ARRAYREF expr ARRAYREF_END {[]} /* list slice */ -| array ARRAYREF expr ARRAYREF_END {[]} /* array slice */ -| array BRACKET expr BRACKET_END {[]} /* @hash{@keys} */ +| term binop term {()} +| term binop BRACKET expr BRACKET_END {()} +| term LT term {()} +| term LT BRACKET expr BRACKET_END {()} +| term GT term {()} +| term GT BRACKET expr BRACKET_END {()} + +/* Unary operators and terms */ +| MINUS term %prec UNARY_MINUS {()} +| TIGHT_NOT term {()} +| BIT_NEG term {()} +| INCR term {()} +| DECR term {()} +| term INCR {()} +| term DECR {()} + +| NOT argexpr {()} + + +/* Constructors for anonymous data */ +| arrayref {()} /* [ 1, 2 ] */ +| BRACKET BRACKET_END {()} /* empty hash */ +| BRACKET_HASHREF expr_or_empty BRACKET_END %prec PAREN {()} /* { foo => "Bar" } */ +| SUB BRACKET lines BRACKET_END %prec PAREN {()} + +| termdo {()} +| term question_mark_ colon_ {()} +| REF term {()} /* \$x, \@y, \%z */ +| REF BRACKET expr BRACKET_END {()} /* \$x, \@y, \%z */ +| my %prec UNIOP {()} +| LOCAL term %prec UNIOP {()} + +| parenthesized {()} /* (1, 2) */ +| parenthesized arrayref {()} /* list slice */ + +| variable {()} + +| subscripted {()} + +| array arrayref {()} /* array slice */ +| array BRACKET expr BRACKET_END {()} /* @hash{@keys} */ + + +/* function_calls */ +| func parenthesized {()} /* &foo(@args) */ +| word argexpr {()} /* foo(@args) */ +| word BRACKET lines BRACKET_END listexpr %prec LSTOP {()} /* map { foo } @bar */ +| word BRACKET BRACKET expr BRACKET_END BRACKET_END listexpr %prec LSTOP {()} /* map { foo } @bar */ +| word BRACKET BRACKET expr BRACKET_END SEMI_COLON BRACKET_END listexpr %prec LSTOP {()} /* map { foo } @bar */ + +| term ARROW word_or_scalar parenthesized {warn "term->word_or_scalar(expr_or_empty) -> function_call"} /* $foo->bar(list) */ +| term ARROW word_or_scalar {warn "term->word_or_scalar -> function_call"} /* $foo->bar */ + +| NEW word listexpr {()} /* new Class @args */ +| print listexpr {()} + +| word {()} + +| NUM {()} +| STRING {()} +| REVISION {()} +| COMMAND_STRING {()} +| QUOTEWORDS {()} +| HERE_DOC {()} +| PATTERN {()} +| PATTERN_SUBST {()} +| diamond {()} + +diamond: +| LT GT {()} +| LT term GT {()} + +print: +| PRINT bareword COLON {()} +| PRINT bareword {()} /* print FH @args */ +| PRINT scalar COLON {()} +| PRINT scalar {()} /* print $fh @args */ +| PRINT {()} + +| PRINT bareword BRACKET {die "use parentheses around print"} -| function_call {[]} - -| word {[]} -| value {[]} - -function_call: -| func PAREN expr_or_empty PAREN_END {[]} /* &foo(@args) */ -| word argexpr {[]} /* foo(@args) */ -| word block listexpr %prec LSTOP {[]} /* map { foo } @bar */ - -| term ARROW word_or_scalar PAREN expr_or_empty PAREN_END {[]} /* $foo->bar(list) */ -| term ARROW word_or_scalar {[]} /* $foo->bar */ - -| NEW word listexpr {[]} /* new Class @args */ -| PRINT argexpr {[]} /* print $fh @args */ -| PRINT word_or_scalar argexpr {[]} /* print $fh @args */ +subscripted: /* Some kind of subscripted expression */ +| variable PKG_SCOPE bracket_subscript {()} /* *main::{something} */ +| scalar bracket_subscript {()} /* $foo{bar} */ +| scalar arrayref {()} /* $array[$element] */ +| term ARROW bracket_subscript {()} /* somehref->{bar} */ +| term ARROW arrayref {()} /* somearef->[$element] */ +| term ARROW parenthesized {()} /* $subref->(@args) */ +| subscripted bracket_subscript {()} /* $foo->[bar]{baz} */ +| subscripted arrayref {()} /* $foo->[$bar][$baz] */ +| subscripted parenthesized {()} /* $foo->{bar}(@args) */ + +arrayref: +| arrayref_start ARRAYREF_END {()} +| arrayref_start expr ARRAYREF_END {()} +| arrayref_start BRACKET expr BRACKET_END ARRAYREF_END {()} +parenthesized: +| parenthesized_start PAREN_END {()} +| parenthesized_start expr PAREN_END {()} +| parenthesized_start BRACKET expr BRACKET_END PAREN_END {()} + +arrayref_start: +| ARRAYREF {()} +| arrayref_start expr comma {()} +| arrayref_start BRACKET expr BRACKET_END comma {()} +parenthesized_start: +| PAREN {()} +| parenthesized_start expr comma {()} +| parenthesized_start BRACKET expr BRACKET_END comma {()} + +my: /* Things that can be "my"'d */ +| MY parenthesized {()} +| MY scalar {()} +| MY hash {()} +| MY array {()} termdo: /* Things called with "do" */ -| DO term %prec UNIOP {[]} /* do $filename */ -| DO block %prec PAREN {[]} /* do { code */ - -termunop: /* Unary operators and terms */ -| MINUS term %prec UNARY_MINUS {[]} -| TIGHT_NOT term {[]} -| BIT_NEG term {[]} -| INCR term {[]} -| DECR term {[]} -| term INCR {[]} -| term DECR {[]} - -| NOT argexpr {[]} - -myterm: /* Things that can be "my"'d */ -| PAREN expr_or_empty PAREN_END {[]} -| scalar {[]} -| hash {[]} -| array {[]} +| DO term %prec UNIOP {()} /* do $filename */ +| DO BRACKET lines BRACKET_END %prec PAREN {()} /* do { code */ -subscripted: /* Some kind of subscripted expression */ -| variable PKG_SCOPE bracket_subscript {[]} /* *main::{something} */ -| scalar bracket_subscript {[]} /* $foo{bar} */ -| scalar ARRAYREF expr ARRAYREF_END {[]} /* $array[$element] */ -| term ARROW bracket_subscript {[]} /* somehref->{bar} */ -| term ARROW ARRAYREF expr ARRAYREF_END {[]} /* somearef->[$element] */ -| term ARROW PAREN expr_or_empty PAREN_END {[]} /* $subref->(@args) */ -| subscripted bracket_subscript {[]} /* $foo->[bar]{baz;} */ -| subscripted ARRAYREF expr ARRAYREF_END {[]} /* $foo->[$bar][$baz] */ -| subscripted PAREN expr_or_empty PAREN_END {[]} /* $foo->{bar}(@args) */ +question_mark_: +| QUESTION_MARK term {()} +| QUESTION_MARK BRACKET expr BRACKET_END {()} +colon_: +| COLON term {()} +| COLON BRACKET expr BRACKET_END {()} bracket_subscript: -| BRACKET expr BRACKET_END {[]} -| COMPACT_HASH_SUBSCRIPT {[]} - -anonymous: /* Constructors for anonymous data */ -| ARRAYREF expr_or_empty ARRAYREF_END {[]} -| BRACKET expr_or_empty BRACKET_END %prec PAREN {[]} /* { foo => "Bar" } */ -| BRACKET_HASHREF expr_or_empty BRACKET_END %prec PAREN {[]} /* { foo => "Bar" } */ -| SUB block %prec PAREN {[]} +| BRACKET expr BRACKET_END {()} +| COMPACT_HASH_SUBSCRIPT {()} binop: -| ASSIGN {[]} -| POWER {[]} -| MULT {[]} | DIVISION {[]} | MODULO {[]} | REPLICATE {[]} -| PLUS {[]} | MINUS {[]} | CONCAT {[]} -| BIT_SHIFT_LEFT {[]} | BIT_SHIFT_RIGHT {[]} -| LT {[]} | GT {[]} | COMPARE_OP {[]} -| EQ_OP {[]} -| BIT_AND {[]} -| BIT_OR {[]} | BIT_XOR {[]} -| DOTDOT {[]} | DOTDOTDOT {[]} -| AND_TIGHT {[]} -| OR_TIGHT {[]} | XOR {[]} -| PATTERN_MATCH {[]} | PATTERN_MATCH_NOT {[]} - -value: -| NUM {[]} -| STRING {[]} -| REVISION {[]} -| COMMAND_STRING {[]} -| QUOTEWORDS {[]} -| HERE_DOC {[]} -| PATTERN {[]} -| PATTERN_SUBST {[]} -| LT GT {[]} -| LT term GT {[]} +| ASSIGN {()} +| POWER {()} +| MULT {()} | DIVISION {()} | MODULO {()} | REPLICATE {()} +| PLUS {()} | MINUS {()} | CONCAT {()} +| BIT_SHIFT_LEFT {()} | BIT_SHIFT_RIGHT {()} +| COMPARE_OP {()} +| EQ_OP {()} +| BIT_AND {()} +| BIT_OR {()} | BIT_XOR {()} +| DOTDOT {()} | DOTDOTDOT {()} +| AND_TIGHT {()} +| OR_TIGHT {()} | XOR {()} +| PATTERN_MATCH {()} | PATTERN_MATCH_NOT {()} variable: -| scalar %prec PAREN {[]} -| star %prec PAREN {[]} -| hash %prec PAREN {[]} -| array %prec PAREN {[]} -| arraylen %prec PAREN {[]} /* $#x, $#{ something } */ -| func %prec PAREN {[]} /* &foo; */ +| scalar %prec PAREN {()} +| star %prec PAREN {()} +| hash %prec PAREN {()} +| array %prec PAREN {()} +| arraylen %prec PAREN {()} /* $#x, $#{ something } */ +| func %prec PAREN {()} /* &foo; */ word: | bareword { fst $1 } @@ -301,29 +360,23 @@ word: | Some s, name, _ -> s ^ "::" ^ name } -comma: COMMA {[]} | RIGHT_ARROW {[]} +comma: COMMA {()} | RIGHT_ARROW {()} word_or_scalar: -| bareword { [] } -| RAW_IDENT { [] } -| scalar { [] } - -block_or_scalar: block {[]} | scalar {[]} +| word {()} +| scalar {()} bareword: | NEW { "new", $1 } -| PRINT { "print", $1 } | FORMAT { "format", $1 } | BAREWORD { $1 } -arraylen: ARRAYLEN_IDENT {[]} | ARRAYLEN block_or_scalar {[]} -scalar: SCALAR_IDENT {[]} | DOLLAR block_or_scalar {[]} -func: FUNC_IDENT {[]} | AMPERSAND block_or_scalar {[]} -array: ARRAY_IDENT {[]} | AT block_or_scalar {[]} -hash: HASH_IDENT {[]} | PERCENT block_or_scalar {[]} -star: STAR_IDENT {[]} | STAR block_or_scalar {[]} - -expr_or_empty: {[]} | expr {[]} -word_or_empty: {[]} | word {[]} -bareword_or_empty: {[]} | bareword {[]} -revision_or_empty: {[]} | REVISION {[]} +arraylen: ARRAYLEN_IDENT {()} | ARRAYLEN scalar {()} | ARRAYLEN BRACKET lines BRACKET_END {()} +scalar: SCALAR_IDENT {()} | DOLLAR scalar {()} | DOLLAR BRACKET lines BRACKET_END {()} | DOLLAR BRACKET BRACKET expr BRACKET_END BRACKET_END {()} +func: FUNC_IDENT {()} | AMPERSAND scalar {()} | AMPERSAND BRACKET lines BRACKET_END {()} +array: ARRAY_IDENT {()} | AT scalar {()} | AT BRACKET lines BRACKET_END {()} +hash: HASH_IDENT {()} | PERCENT scalar {()} | PERCENT BRACKET lines BRACKET_END {()} +star: STAR_IDENT {()} | STAR scalar {()} | STAR BRACKET lines BRACKET_END {()} + +expr_or_empty: {()} | expr {()} + diff --git a/perl_checker.src/perl_checker.ml b/perl_checker.src/perl_checker.ml index cc5bb19..fbb3f4d 100644 --- a/perl_checker.src/perl_checker.ml +++ b/perl_checker.src/perl_checker.ml @@ -1,18 +1,22 @@ open Types let _ = - let file = try Sys.argv.(2) with _ -> try Sys.argv.(1) with _ -> "/tmp/t.pl" in - let lexbuf = Lexing.from_channel (open_in file) in - let _ = + let args = List.tl (Array.to_list Sys.argv) in + List.iter (fun file -> try - Info.start_a_new_file file ; - if false then - let t = Lexer.lexbuf2list Lexer.token lexbuf in - let _,_ = t, t in "" - else - Parser.prog Lexer.token lexbuf - with Failure s -> ( - prerr_endline s ; - exit 1 + let lexbuf = Lexing.from_channel (open_in file) in + let _ = + try + Info.start_a_new_file file ; + if false then + let t = Lexer.lexbuf2list Lexer.token lexbuf in + let _,_ = t, t in "" + else + Parser.prog Lexer.token lexbuf + with Failure s -> ( + prerr_endline s ; + exit 1 ) in - () + () + with _ -> prerr_endline ("bad file " ^ file) + ) args |