Parent Directory
| 
Revision Log
This commit was manufactured by cvs2svn to create branch 'rel-2-4-patches'.
1 #! /usr/bin/perl 2 3 # 4 # Usage: convert-functions [-t | --test] [-q | --quiet] filename [filename ...] 5 # 6 # If the filename is '-', act as a filter (read from stdin and write to stdout), 7 # otherwise, each file is read and modified. 8 # 9 # If --test is specified, then no output is written, but you just see what changes 10 # would have been made. 11 # 12 # If --quiet is specified, the conversions are not printed out 13 # (but the file names still are) 14 # 15 16 # 17 # The functions to be converted and their parameter lists. 18 # 19 # The hash key is the original function name, and the value is an array of two or three items: 20 # The first is the name of the routine it is being mapped to 21 # The second is an array that tells how to map the original functions parameters to the 22 # new functions hash list (see below) 23 # The third is an optional hash of parameters that are always passed to the new routine 24 # 25 # The values in the array of arguments have several special interpretations: 26 # A value listed as "undef" will be passed to the new routine as a plain argument (not as 27 # part of the hash). 28 # An entry of the form name[n] (where n is a number) will be put in position n of an array 29 # reference whose key is name in the hash passed to the new routine. (E.g., "limits[0]" 30 # puts the argument in that position of the original argument list into the first entry 31 # of limits=>[n,m] in the hash.) The default value for the array hash is given by 32 # the variable $default{name}, e.g. $default{limits} = ['$funcLLimitDefault','$funcULimitDefault']. 33 # An entry of '@' means make the rest of the parameters into an array reference and pass them 34 # as the first parameter to the new routine. 35 # 36 # Any extra parameters from the original routine are passed verbatim to the new one. 37 # 38 39 %function = ( 40 std_num_cmp => ['num_cmp',[undef,'relTol','format','zeroLevel','zeroLevelTol']], 41 std_num_cmp_abs => ['num_cmp',[undef,'tol','format'],{tolType=>'absolute'}], 42 std_num_cmp_list => ['num_cmp',['relTol','format','@']], 43 std_num_cmp_abs_list => ['num_cmp',['tol','format','@'],{tolType=>'absolute'}], 44 45 arith_num_cmp => ['num_cmp',[undef,'relTol','format','zeroLevel','zeroLevelTol'],{mode=>'arith'}], 46 arith_num_cmp_abs => ['num_cmp',[undef,'tol','format'],{mode=>'arith',tolType=>'absolute'}], 47 arith_num_cmp_list => ['num_cmp',['relTol','format','@'],{mode=>'arith'}], 48 arith_num_cmp_abs_list => ['num_cmp',['tol','format','@'],{mode=>'arith',tolType=>'absolute'}], 49 50 strict_num_cmp => ['num_cmp',[undef,'relTol','format','zeroLevel','zeroLevelTol'],{mode=>'strict'}], 51 strict_num_cmp_abs => ['num_cmp',[undef,'tol','format'],{mode=>'strict',tolType=>'absolute'}], 52 strict_num_cmp_list => ['num_cmp',['relTol','format','@'],{mode=>'strict'}], 53 strict_num_cmp_abs_list => ['num_cmp',['tol','format','@'],{mode=>'strict',tolType=>'absolute'}], 54 55 frac_num_cmp => ['num_cmp',[undef,'relTol','format','zeroLevel','zeroLevelTol'],{mode=>'frac'}], 56 frac_num_cmp_abs => ['num_cmp',[undef,'tol','format'],{mode=>'frac',tolType=>'absolute'}], 57 frac_num_cmp_list => ['num_cmp',['relTol','format','@'],{mode=>'frac'}], 58 frac_num_cmp_abs_list => ['num_cmp',['tol','format','@'],{mode=>'frac',tolType=>'absolute'}], 59 60 std_num_str_cmp => 61 ['num_cmp',[undef,'strings','relTol','format','zeroLevel','zeroLevelTol']], 62 63 function_cmp => 64 ['fun_cmp',[undef,'vars','limits[0]','limits[1]','relTol','numPoints','zeroLevel','zeroLevelTol']], 65 66 function_cmp_up_to_constant => 67 ['fun_cmp',[undef,'vars','limits[0]','limits[1]','relTol','numPoints','maxConstantOfIntegration', 68 'zeroLevel','zeroLevelTol'],{mode=>'antider'}], 69 70 function_cmp_abs => 71 [fun_cmp,[undef,'vars','limits[0]','limits[1]','tol','numPoints'],{tolType=>'absolute'}], 72 73 function_cmp_up_to_constant_abs => 74 [fun_cmp,[undef,'vars','limits[0]','limits[1]','tol','numPoints','maxConstantOfIntegration'], 75 {mode=>'antider',tolType=>'absolute'}], 76 77 multivar_function_cmp => ['fun_cmp',[undef,'vars']], 78 79 std_str_cmp => ['str_cmp',[]], 80 std_str_cmp_list => ['str_cmp',['@']], 81 std_cs_str_cmp => ['str_cmp',[],{filters=>['trim_whitespace','compress_whitespace']}], 82 std_cs_str_cmp_list => ['str_cmp',['@'],{filters=>['trim_whitespace','compress_whitespace']}], 83 strict_str_cmp => ['str_cmp',[],{filters=>['trim_whitespace']}], 84 strict_str_cmp_list => ['str_cmp',['@'],{filters=>['trim_whitespace']}], 85 unordered_str_cmp => ['str_cmp',[],{filters=>['remove_whitespace','ignore_order','ignore_case']}], 86 unordered_str_cmp_list => ['str_cmp',['@'],{filters=>['remove_whitespace','ignore_order','ignore_case']}], 87 unordered_cs_str_cmp => ['str_cmp',[],{filters=>['remove_whitespace','ignore_order']}], 88 unordered_cs_str_cmp_list => ['str_cmp',['@'],{filters=>['remove_whitespace','ignore_order']}], 89 ordered_str_cmp => ['str_cmp',[],{filters=>['remove_whitespace','ignore_case']}], 90 ordered_str_cmp_list => ['str_cmp',['@'],{filters=>['remove_whitespace','ignore_case']}], 91 ordered_cs_str_cmp => ['str_cmp',[],{filters=>['remove_whitespace']}], 92 ordered_cs_str_cmp_list => ['str_cmp',['@'],{filters=>['remove_whitespace']}], 93 94 ); 95 96 #numerical_compare_with_units() needs to be handled by hand -- but there are very few uses. 97 98 $default{limits} = ['$funcLLimitDefault','$funcULimitDefault']; 99 100 # 101 # Make a patter from all the names (we sort be length of the names, to 102 # make sure prefixes appear later in the list). 103 # 104 $pattern = join("|",sort byName keys(%function)); 105 106 sub byName { 107 return $a <=> $b if length($a) == length($b); 108 return length($b) <=> length($a); 109 } 110 111 # 112 # Remove leading and trailing spaces 113 # 114 sub trim { 115 my $s = shift; 116 $s =~ s/(^\s+|\s+$)//g; 117 return $s; 118 } 119 120 # 121 # Remove leading comment lines 122 # 123 sub trimComments { 124 my $s = shift; 125 $s =~ s/^(\s*#.*?(\n|$))*//; 126 return $s; 127 } 128 129 130 # 131 # Command-line options and internal state parameters 132 # 133 $testing = 0; # true if not writing output files 134 $quiet = 0; # true if not printing changed function calls 135 $changed = 0; # true if we have changes a function in the current file 136 137 # 138 # Read the contents of a file, and search through it for the functions 139 # above. Then modify the argument lists to use hashes rather than 140 # direct parameter lists. 141 # 142 sub Process { 143 my @lines; 144 if ($file eq "-") { 145 @lines = <>; 146 open(PGFILE,">&STDOUT"); # redirect this to STDOUT 147 } elsif ($file eq "--test" || $file eq "-t") { 148 $testing = 1; return; 149 } elsif ($file eq "--quiet" || $file eq "-q") { 150 $quiet = 1; return; 151 } else { 152 print stderr "\n" if $changed; 153 print stderr "Converting: $file\n"; 154 open(PGFILE,$file) || warn "Can't read '$file': $!"; 155 @lines = <PGFILE>; close(PGFILE); 156 open(PGFILE,$testing? ">/dev/null": ">$file"); 157 } 158 $changed = 0; 159 160 my $file = join("",@lines); 161 $file =~ s/\&beginproblem(\(\))?/beginproblem()/gm; # remove unneeded ampersands 162 $file =~ s/\&ANS\(/ANS\(/gm; # remove unneeded ampersands 163 $file =~ s/ANS\( */ANS\(/gm; # remove unneeded spaces 164 my @parts = split(/($pattern)/o,$file); 165 # 166 # Because of the parentheses around the pattern above, split returns the pattern 167 # as well as the stuff it separates. So @parts contains stuff, first function, 168 # args and more stuff, next function, etc. 169 # 170 print PGFILE shift(@parts); 171 while (my $f = shift(@parts)) { 172 my ($args,$rest) = GetArgs(shift(@parts)); 173 unless ($args) {print $f,$rest; next}; # skip it if doesn't look like an actual call 174 print PGFILE HandleFunction($f,$function{$f},$args),$rest; 175 } 176 } 177 178 # 179 # Convert the list of arguments to appropriate hash values 180 # (taking into account the interpretations given above 181 # for the special entries in the list). 182 # Don't include empty parameters (I don't think this should be a problem). 183 # Return the modified function call with the new name and hash 184 # 185 sub HandleFunction { 186 my $original = shift; my $f = shift; my $args = shift; 187 my @names = @{$f->[1]}; my @args = @{$args}; 188 my ($name,$value); 189 # 190 # Get the fixed options needed for this function 191 # 192 my %options = %{$f->[2] || {}}; 193 foreach my $id (keys(%options)) { 194 if (ref($options{$id}) eq 'ARRAY') { 195 $options{$id} = '["'.join('","',@{$options{$id}}).'"]'; 196 } else { 197 $options{$id} = '"'.$options{$id}.'"'; 198 } 199 } 200 # 201 # Process the list of arguments supplied by the user 202 # (treating special cases properly) 203 # 204 my @options = (); my @params = (); 205 while (my ($name,$value) = (shift(@names),shift(@args))) { 206 last unless defined $value; 207 unless ($name) {push(@params,$value); next} 208 if ($name eq '@') {push(@params,'['.join(',',$value,@args).']'); @args = (); last} 209 if ($name =~ s/\[(\d+)\]$//) { 210 $options{$name} = $default{$name} unless defined $options{$name}; 211 $options{$name}[$1] = $value; next; 212 } 213 $options{$name} = $value unless $value eq '""' || $value eq "''"; 214 } 215 # 216 # Add the hash values to the new argument list 217 # 218 while (($name,$value) = each %options) { 219 $value = '['.join(',',@{$options{$name}}).']' if ref($value) eq 'ARRAY'; 220 push(@options,"$name=>$value"); 221 } 222 # 223 # Create the new function and display it 224 # 225 my $F = $f->[0].'('.join(', ',@params,@options,@args).')'; 226 unless ($quiet) { 227 print stderr " $original(",join(',',@{$args}),") -> $F\n"; 228 $changed = 1; 229 } 230 return $F; 231 } 232 233 # 234 # Get the argument list for the function, respecting quotation marks, 235 # nested parentheses, and so on. Remove comments that might be 236 # nested within a multi-line function call. 237 # 238 sub GetArgs { 239 my $text = shift; 240 my @args = (); my $parenCount = 0; my $arg = ""; 241 return (undef,$text) unless $text =~ s/^\s*\(//; # remove leading spaces and opening paren 242 $text = trimComments($text); 243 while ($text =~ s/^((?:"(?:\\.|[^\"])*"|'(?:\\.|[^\'])*'|\\.|[^\\])*?)([(){}\[\],\n])//) { 244 if ($2 eq '(' || $2 eq '[' || $2 eq '{') {$parenCount++; $arg .= $1.$2; next} 245 if ($2 eq ')' && $parenCount == 0) {$arg .= $1; push(@args,trim($arg)); last} 246 if ($2 eq ')' || $2 eq ']' || $2 eq '}') {$parenCount--; $arg .= $1.$2; next} 247 if ($2 eq "\n") {$arg .= $1; $text = trimComments($text); next} 248 if ($parenCount == 0) { 249 push(@args,trim($arg.$1)); $arg = ""; 250 $text = trimComments($text); 251 } else {$arg .= $1.$2} 252 } 253 $text =~ s/^ +//; # remove unneeded leading spaces 254 return(\@args,$text); 255 } 256 257 # 258 # Process each file 259 # 260 push(@ARGV,"-") if (scalar(@ARGV) == 0); 261 foreach $file (@ARGV) {print Process($file)} 262 print stderr "\n";
| aubreyja at gmail dot com | ViewVC Help |
| Powered by ViewVC 1.0.9 |