- Begun implementation of a C statements parser.
- More reorganizations and fixes.
diff --git a/tools/winapi/c_parser.pm b/tools/winapi/c_parser.pm
new file mode 100644
index 0000000..957723a
--- /dev/null
+++ b/tools/winapi/c_parser.pm
@@ -0,0 +1,534 @@
+package c_parser;
+
+use strict;
+
+use options qw($options);
+use output qw($output);
+
+sub _update_c_position {
+ local $_ = shift;
+ my $refline = shift;
+ my $refcolumn = shift;
+
+ my $line = $$refline;
+ my $column = $$refcolumn;
+
+ while($_) {
+ if(s/^[^\n\t\'\"]*//s) {
+ $column += length($&);
+ }
+
+ if(s/^\'//) {
+ $column++;
+ while(/^./ && !s/^\'//) {
+ s/^([^\'\\]*)//s;
+ $column += length($1);
+ if(s/^\\//) {
+ $column++;
+ if(s/^(.)//s) {
+ $column += length($1);
+ if($1 eq "0") {
+ s/^(\d{0,3})//s;
+ $column += length($1);
+ }
+ }
+ }
+ }
+ $column++;
+ } elsif(s/^\"//) {
+ $column++;
+ while(/^./ && !s/^\"//) {
+ s/^([^\"\\]*)//s;
+ $column += length($1);
+ if(s/^\\//) {
+ $column++;
+ if(s/^(.)//s) {
+ $column += length($1);
+ if($1 eq "0") {
+ s/^(\d{0,3})//s;
+ $column += length($1);
+ }
+ }
+ }
+ }
+ $column++;
+ } elsif(s/^\n//) {
+ $line++;
+ $column = 0;
+ } elsif(s/^\t//) {
+ $column = $column + 8 - $column % 8;
+ }
+ }
+
+ $$refline = $line;
+ $$refcolumn = $column;
+}
+
+sub parse_c {
+ my $pattern = shift;
+ my $refcurrent = shift;
+ my $refline = shift;
+ my $refcolumn = shift;
+
+ local $_ = $$refcurrent;
+ my $line = $$refline;
+ my $column = $$refcolumn;
+
+ if(s/$pattern//) {
+ _update_c_position($&, \$line, \$column);
+ } else {
+ return 0;
+ }
+
+ $$refcurrent = $_;
+ $$refline = $line;
+ $$refcolumn = $column;
+
+ return 1;
+}
+
+sub parse_c_until_one_of {
+ my $characters = shift;
+ my $refcurrent = shift;
+ my $refline = shift;
+ my $refcolumn = shift;
+ my $match = shift;
+
+ local $_ = $$refcurrent;
+ my $line = $$refline;
+ my $column = $$refcolumn;
+
+ if(!defined($line) || !defined($column)) {
+ $output->write("error: \$characters = '$characters' \$_ = '$_'\n");
+ exit 1;
+ }
+
+ if(!defined($match)) {
+ my $blackhole;
+ $match = \$blackhole;
+ }
+
+ $$match = "";
+ while(/^[^$characters]/s) {
+ my $submatch = "";
+
+ if(s/^[^$characters\n\t\'\"]*//s) {
+ $submatch .= $&;
+ }
+
+ if(s/^\'//) {
+ $submatch .= "\'";
+ while(/^./ && !s/^\'//) {
+ s/^([^\'\\]*)//s;
+ $submatch .= $1;
+ if(s/^\\//) {
+ $submatch .= "\\";
+ if(s/^(.)//s) {
+ $submatch .= $1;
+ if($1 eq "0") {
+ s/^(\d{0,3})//s;
+ $submatch .= $1;
+ }
+ }
+ }
+ }
+ $submatch .= "\'";
+
+ $$match .= $submatch;
+ $column += length($submatch);
+ } elsif(s/^\"//) {
+ $submatch .= "\"";
+ while(/^./ && !s/^\"//) {
+ s/^([^\"\\]*)//s;
+ $submatch .= $1;
+ if(s/^\\//) {
+ $submatch .= "\\";
+ if(s/^(.)//s) {
+ $submatch .= $1;
+ if($1 eq "0") {
+ s/^(\d{0,3})//s;
+ $submatch .= $1;
+ }
+ }
+ }
+ }
+ $submatch .= "\"";
+
+ $$match .= $submatch;
+ $column += length($submatch);
+ } elsif(s/^\n//) {
+ $submatch .= "\n";
+
+ $$match .= $submatch;
+ $line++;
+ $column = 0;
+ } elsif(s/^\t//) {
+ $submatch .= "\t";
+
+ $$match .= $submatch;
+ $column = $column + 8 - $column % 8;
+ } else {
+ $$match .= $submatch;
+ $column += length($submatch);
+ }
+ }
+
+ $$refcurrent = $_;
+ $$refline = $line;
+ $$refcolumn = $column;
+ return 1;
+}
+
+sub parse_c_block {
+ my $refcurrent = shift;
+ my $refline = shift;
+ my $refcolumn = shift;
+ my $refstatements = shift;
+ my $refstatements_line = shift;
+ my $refstatements_column = shift;
+
+ local $_ = $$refcurrent;
+ my $line = $$refline;
+ my $column = $$refcolumn;
+
+ my $statements;
+ if(s/^\{//) {
+ $column++;
+ $statements = "";
+ } else {
+ return 0;
+ }
+
+ parse_c_until_one_of("\\S", \$_, \$line, \$column);
+
+ my $statements_line = $line;
+ my $statements_column = $column;
+
+ my $plevel = 1;
+ while($plevel > 0) {
+ my $match;
+ parse_c_until_one_of("\\{\\}", \$_, \$line, \$column, \$match);
+
+ $column++;
+
+ $statements .= $match;
+ if(s/^\}//) {
+ $plevel--;
+ if($plevel > 0) {
+ $statements .= "}";
+ }
+ } elsif(s/^\{//) {
+ $plevel++;
+ $statements .= "{";
+ } else {
+ return 0;
+ }
+ }
+
+ $$refcurrent = $_;
+ $$refline = $line;
+ $$refcolumn = $column;
+ $$refstatements = $statements;
+ $$refstatements_line = $statements_line;
+ $$refstatements_column = $statements_column;
+
+ return 1;
+}
+
+sub parse_c_expression {
+ my $refcurrent = shift;
+ my $refline = shift;
+ my $refcolumn = shift;
+ my $found_function_call_callback = shift;
+
+ my $line = $$refline;
+ my $column = $$refcolumn;
+
+ local $_ = $$refcurrent;
+
+ parse_c_until_one_of("\\S", \$_, \$line, \$column);
+
+ if(s/^(.*?)(\w+)(\s*)\(//s) {
+ my $begin_line = $line;
+ my $begin_column = $column + length($1) + 1;
+
+ $line = $begin_line;
+ $column = $begin_column + length("$2$3") - 1;
+
+ my $name = $2;
+
+ $_ = "($'";
+
+ # $output->write("$name: $line.$column: '$_'\n");
+
+ my @arguments;
+ my @argument_lines;
+ my @argument_columns;
+ if(!parse_c_tuple(\$_, \$line, \$column, \@arguments, \@argument_lines, \@argument_columns)) {
+ return 0;
+ }
+
+ if($name =~ /^sizeof$/) {
+ # Nothing
+ } else {
+ &$found_function_call_callback($begin_line, $begin_column, $line, $column,
+ $name, \@arguments);
+ }
+
+ while(defined(my $argument = shift @arguments) &&
+ defined(my $argument_line = shift @argument_lines) &&
+ defined(my $argument_column = shift @argument_columns))
+ {
+ parse_c_expression(\$argument, \$argument_line, \$argument_column, $found_function_call_callback);
+ }
+ } elsif(s/^return//) {
+ $column += length($&);
+ parse_c_until_one_of("\\S", \$_, \$line, \$column);
+ if(!parse_c_expression(\$_, \$line, \$column, $found_function_call_callback)) {
+ return 0;
+ }
+ } else {
+ return 0;
+ }
+
+ _update_c_position($_, \$line, \$column);
+
+ $$refcurrent = $_;
+ $$refline = $line;
+ $$refcolumn = $column;
+
+ return 1;
+}
+
+sub parse_c_statement {
+ my $refcurrent = shift;
+ my $refline = shift;
+ my $refcolumn = shift;
+ my $found_function_call_callback = shift;
+
+ my $line = $$refline;
+ my $column = $$refcolumn;
+
+ local $_ = $$refcurrent;
+
+ parse_c_until_one_of("\\S", \$_, \$line, \$column);
+
+ if(s/^(?:case\s+)?(\w+)\s*://) {
+ $column += length($&);
+ parse_c_until_one_of("\\S", \$_, \$line, \$column);
+ }
+
+ # $output->write("$line.$column: '$_'\n");
+
+ if(/^$/) {
+ # Nothing
+ } elsif(/^\{/) {
+ my $statements;
+ my $statements_line;
+ my $statements_column;
+ if(!parse_c_block(\$_, \$line, \$column, \$statements, \$statements_line, \$statements_column)) {
+ return 0;
+ }
+ if(!parse_c_statements(\$statements, \$statements_line, \$statements_column, $found_function_call_callback)) {
+ return 0;
+ }
+ } elsif(/^(for|if|switch|while)(\s*)\(/) {
+ $column += length("$1$2");
+ my $name = $1;
+
+ $_ = "($'";
+
+ my @arguments;
+ my @argument_lines;
+ my @argument_columns;
+ if(!parse_c_tuple(\$_, \$line, \$column, \@arguments, \@argument_lines, \@argument_columns)) {
+ return 0;
+ }
+
+ parse_c_until_one_of("\\S", \$_, \$line, \$column);
+ if(!parse_c_statement(\$_, \$line, \$column, $found_function_call_callback)) {
+ return 0;
+ }
+ parse_c_until_one_of("\\S", \$_, \$line, \$column);
+
+ while(defined(my $argument = shift @arguments) &&
+ defined(my $argument_line = shift @argument_lines) &&
+ defined(my $argument_column = shift @argument_columns))
+ {
+ parse_c_expression(\$argument, \$argument_line, \$argument_column, $found_function_call_callback);
+ }
+ } elsif(s/^else//) {
+ $column += length($&);
+ if(!parse_c_statement(\$_, \$line, \$column, $found_function_call_callback)) {
+ return 0;
+ }
+ } elsif(parse_c_expression(\$_, \$line, \$column, $found_function_call_callback)) {
+ # Nothing
+ } else {
+ # $output->write("error '$_'\n");
+ # exit 1;
+ }
+
+ _update_c_position($_, \$line, \$column);
+
+ $$refcurrent = $_;
+ $$refline = $line;
+ $$refcolumn = $column;
+
+ return 1;
+}
+
+sub parse_c_statements {
+ my $refcurrent = shift;
+ my $refline = shift;
+ my $refcolumn = shift;
+ my $found_function_call_callback = shift;
+
+ my $line = $$refline;
+ my $column = $$refcolumn;
+
+ local $_ = $$refcurrent;
+
+ parse_c_until_one_of("\\S", \$_, \$line, \$column);
+ my $statement = "";
+ my $statement_line = $line;
+ my $statement_column = $column;
+
+ my $blevel = 1;
+ my $plevel = 1;
+ while($plevel > 0 || $blevel > 0) {
+ my $match;
+ parse_c_until_one_of("\\(\\)\\[\\]\\{\\};", \$_, \$line, \$column, \$match);
+
+ # $output->write("'$match' '$_'\n");
+
+ $column++;
+ $statement .= $match;
+ if(s/^[\(\[]//) {
+ $plevel++;
+ $statement .= $&;
+ } elsif(s/^[\)\]]//) {
+ $plevel--;
+ if($plevel <= 0) {
+ $output->write("error $plevel: '$statement' '$match' '$_'\n");
+ exit 1;
+ }
+ $statement .= $&;
+ } elsif(s/^\{//) {
+ $blevel++;
+ $statement .= $&;
+ } elsif(s/^\}//) {
+ $blevel--;
+ $statement .= $&;
+ if($blevel == 1) {
+ if(!parse_c_statement(\$statement, \$statement_line, \$statement_column, $found_function_call_callback)) {
+ return 0;
+ }
+ parse_c_until_one_of("\\S", \$_, \$line, \$column);
+ $statement = "";
+ $statement_line = $line;
+ $statement_column = $column;
+ }
+ } elsif(s/^;//) {
+ if($plevel == 1 && $blevel == 1) {
+ if(!parse_c_statement(\$statement, \$statement_line, \$statement_column, $found_function_call_callback)) {
+ return 0;
+ }
+
+ parse_c_until_one_of("\\S", \$_, \$line, \$column);
+ $statement = "";
+ $statement_line = $line;
+ $statement_column = $column;
+ } else {
+ $statement .= $&;
+ }
+ } elsif(/^\s*$/ && $statement =~ /^\s*$/ && $match =~ /^\s*$/) {
+ $plevel = 0;
+ $blevel = 0;
+ } else {
+ $output->write("error $plevel: '$statement' '$match' '$_'\n");
+ exit 1;
+ }
+ }
+
+ _update_c_position($_, \$line, \$column);
+
+ $$refcurrent = $_;
+ $$refline = $line;
+ $$refcolumn = $column;
+
+ return 1;
+}
+
+sub parse_c_tuple {
+ my $refcurrent = shift;
+ my $refline = shift;
+ my $refcolumn = shift;
+
+ # FIXME: Should not write directly
+ my $items = shift;
+ my $item_lines = shift;
+ my $item_columns = shift;
+
+ local $_ = $$refcurrent;
+
+ my $line = $$refline;
+ my $column = $$refcolumn;
+
+ my $item;
+ if(s/^\(//) {
+ $column++;
+ $item = "";
+ } else {
+ return 0;
+ }
+
+ my $item_line = $line;
+ my $item_column = $column + 1;
+
+ my $plevel = 1;
+ while($plevel > 0) {
+ my $match;
+ parse_c_until_one_of("\\(,\\)", \$_, \$line, \$column, \$match);
+
+ $column++;
+
+ $item .= $match;
+ if(s/^\)//) {
+ $plevel--;
+ if($plevel == 0) {
+ push @$item_lines, $item_line;
+ push @$item_columns, $item_column;
+ push @$items, $item;
+ $item = "";
+ } else {
+ $item .= ")";
+ }
+ } elsif(s/^\(//) {
+ $plevel++;
+ $item .= "(";
+ } elsif(s/^,//) {
+ if($plevel == 1) {
+ push @$item_lines, $item_line;
+ push @$item_columns, $item_column;
+ push @$items, $item;
+ parse_c_until_one_of("\\S", \$_, \$line, \$column);
+ $item_line = $line;
+ $item_column = $column + 1;
+ $item = "";
+ } else {
+ $item .= ",";
+ }
+ } else {
+ return 0;
+ }
+ }
+
+ $$refcurrent = $_;
+ $$refline = $line;
+ $$refcolumn = $column;
+
+ return 1;
+}
+
+1;
