diff options
Diffstat (limited to 'lib/sbin')
-rw-r--r-- | lib/sbin/config_parser.pl | 20 | ||||
-rw-r--r-- | lib/sbin/interface_parser.pl | 275 | ||||
-rw-r--r-- | lib/sbin/parameter_parser.pl | 2 |
3 files changed, 277 insertions, 20 deletions
diff --git a/lib/sbin/config_parser.pl b/lib/sbin/config_parser.pl index d51b5233..73e9d95b 100644 --- a/lib/sbin/config_parser.pl +++ b/lib/sbin/config_parser.pl @@ -42,13 +42,13 @@ require "lib/sbin/create_fortran_stuff.pl"; %thorns = &create_thorn_list; -%interface_database = create_interface_database(%thorns); +%interface_database = &create_interface_database(%thorns); -%parameter_database = create_parameter_database(%thorns); +%parameter_database = &create_parameter_database(%thorns); #&print_parameter_database(%parameter_database); -#&print_interface_database(%interface_database); +&print_interface_database(%interface_database); @implementations = (keys %thorns); @@ -68,13 +68,16 @@ require "lib/sbin/create_fortran_stuff.pl"; @c_structures = &create_c_parameter_structures(scalar(@implementations),@implementations,%parameter_database); -foreach $line (@c_structures) -{ - print "$line\n"; -} +#foreach $line (@c_structures) +#{ +# print "$line\n"; +#} @subroutine = &create_c_param_init_subroutine("test2", %parameter_database); + + + foreach $line (@subroutine) { print "$line\n"; @@ -85,7 +88,8 @@ sub create_thorn_list { return ("flesh", "toolkits/test/flesh", "test1", "toolkits/test/test1", - "test2", "toolkits/test/test2"); + "test2", "toolkits/test/test2", + "test3", "toolkits/test/test3"); } diff --git a/lib/sbin/interface_parser.pl b/lib/sbin/interface_parser.pl index 22f4627e..9611563c 100644 --- a/lib/sbin/interface_parser.pl +++ b/lib/sbin/interface_parser.pl @@ -34,7 +34,7 @@ sub create_interface_database foreach $thorn (keys %thorns) { # Read the data - @indata = read_file("$thorns{$thorn}/interface.ccl"); + @indata = &read_file("$thorns{$thorn}/interface.ccl"); # Get the interface data from it @new_interface_data = &parse_interface_ccl($thorn, @indata); @@ -43,11 +43,264 @@ sub create_interface_database push (@interface_data, @new_interface_data); } + + @interface_data = &cross_index_interface_data(scalar(keys %thorns), (keys %thorns), @interface_data); + return @interface_data; } + +sub cross_index_interface_data +{ + local($n_thorns, @indata) = @_; + local(@thorns); + local(%interface_data); + local(%implementations); + local($implementation); + + @thorns = @indata[0..$n_thorns-1]; + %interface_data = @indata[$n_thorns..$#indata]; + + foreach $thorn (@thorns) + { + $implementation = $interface_data{"\U$thorn\E IMPLEMENTS"}; + if($implementation =~ m:^\s*$:) + { + die "Thorn $thorn doesn't specify an implementation.\n"; + } + + $interface_data{"IMPLEMENTATION \U$implementation\E THORNS"} .= " $thorn"; + + $implementations{"\U$implementation\E"} = "$implementation"; + } + + $interface_data{"THORNS"} = join(" ", @thorns); + + foreach $implementation (keys %implementations) + { + $interface_data{"IMPLEMENTATIONS"} .= $implementations{"\U$implementation\E"} . " "; + + &check_interface_consistency($implementation, %interface_data); + } + + +} + + +sub check_interface_consistency +{ + local($implementation, %interface_data) = @_; + local(@thorns); + local($thorn); + local($thing); + local(%inherits); + local(%friend); + local(%public_groups); + local(%private_groups); + local(%variables); + local($n_errors); + local($group); + local(%attributes); + + # Find out which thorns provide this implementation. + @thorns = split(" ", $interface_data{"IMPLEMENTATION \U$implementation\E THORNS"}); + + if(scalar(@thorns) > 1) + { + foreach $thorn (@thorns) + { + # Record the inheritance + foreach $thing (split(" ", $interface_data{"\U$thorn\E INHERITS"})) + { + if($thing =~ m:\w:) + { + $inherits{"\U$thing\E"} .= "$thorn "; + } + } + + # Record the friends + foreach $thing (split(" ", $interface_data{"\U$thorn\E FRIEND"})) + { + if($thing =~ m:\w:) + { + $friend{"\U$thing\E"} .= "$thorn "; + } + } + + # Record the piblic groups + foreach $thing (split(" ", $interface_data{"\U$thorn\E PUBLIC GROUPS"})) + { + if($thing =~ m:\w:) + { + $public_groups{"\U$thing\E"} .= "$thorn "; + } + } + + # Record the protected groups + foreach $thing (split(" ", $interface_data{"\U$thorn\E PROTECTED GROUPS"})) + { + if($thing =~ m:\w:) + { + $protected_groups{"\U$thing\E"} .= "$thorn "; + } + } + } + + $n_thorns = @thorns; + + # Check the consistency of the inheritance + foreach $thing (keys %inherits) + { + if(split(" ", $inherits{$thing}) != $n_thorns) + { + if(!$n_errors) + { + print STDERR "Inconsistent implementations of $implementation\n"; + print STDERR " Implemented by thorns " . join(" ", @thorns) . "\n"; + } + print STDERR " Not all inherit: $thing\n"; + $n_errors++; + } + } + + # Check the consistency of the friendships + foreach $thing (keys %friend) + { + if(split(" ", $friend{$thing}) != $n_thorns) + { + if(!$n_errors) + { + print STDERR "Inconsistent implementations of $implementation\n"; + print STDERR " Implemented by thorns " . join(" ", @thorns) . "\n"; + } + print STDERR " Not all are friends of : $thing\n"; + $n_errors++; + } + } + + # Check the consistency of the public groups + foreach $thing (keys %public_groups) + { + if(split(" ", $public_groups{$thing}) != $n_thorns) + { + if(!$n_errors) + { + print STDERR "Inconsistent implementations of $implementation\n"; + print STDERR " Implemented by thorns " . join(" ", @thorns) . "\n"; + } + print STDERR " Not all declare public group: $thing\n"; + $n_errors++; + } + } + + # Check the consistency of the protected groups + foreach $thing (keys %protected_groups) + { + if(split(" ", $protected_groups{$thing}) != $n_thorns) + { + if(!$n_errors) + { + print STDERR "Inconsistent implementations of $implementation\n"; + print STDERR " Implemented by thorns " . join(" ", @thorns) . "\n"; + } + print STDERR " Not all declare potected group: $thing\n"; + $n_errors++; + } + } + + # Stop if any errors discovered so far. + if($n_errors) + { + print STDERR "$n_errors Errors found, please fix before continuing.\n"; + exit; + } + + # Check consistancy of group definitions + foreach $group ((keys %public_groups), (keys %protected_groups)) + { + %variables = (); + %attributes = (); + + foreach $thorn (@thorns) + { + # Remember which variables are defined in this group. + foreach $thing (split(" ",$interface_data{"\U$thorn GROUP $group\E"})) + { + $variables{"\U$thing\E"} .= "$thorn "; + } + + # Check variable type definition. + if($attributes{"VTYPE"}) + { + if($attributes{"VTYPE"} ne $interface_data{"\U$thorn GROUP $group\E VTYPE"}) + { + if(!$n_errors) + { + print STDERR "Inconsistent implementations of $implementation\n"; + print STDERR " Implemented by thorns " . join(" ", @thorns) . "\n"; + } + print STDERR " Group $group has inconsistent variable type.\n"; + $n_errors++; + } + } + else + { + $attributes{"VTYPE"} = $interface_data{"\U$thorn GROUP $group\E VTYPE"}; + } + + # Check group type definition. + if($attributes{"GTYPE"}) + { + if($attributes{"GTYPE"} ne $interface_data{"\U$thorn GROUP $group\E GTYPE"}) + { + if(!$n_errors) + { + print STDERR "Inconsistent implementations of $implementation\n"; + print STDERR " Implemented by thorns " . join(" ", @thorns) . "\n"; + } + print STDERR " Group $group has inconsistent group type.\n"; + $n_errors++; + } + } + else + { + $attributes{"GTYPE"} = $interface_data{"\U$thorn GROUP $group\E GTYPE"}; + } + + # Check the dimensions are consistant + if($attributes{"DIM"} && $attributes{"GTYPE"} ne "SCALAR") + { + if($attributes{"DIM"} ne $interface_data{"\U$thorn GROUP $group\E DIM"}) + { + if(!$n_errors) + { + print STDERR "Inconsistent implementations of $implementation\n"; + print STDERR " Implemented by thorns " . join(" ", @thorns) . "\n"; + } + print STDERR " Group $group has inconsistent dimension.\n"; + $n_errors++; + } + } + else + { + $attributes{"DIM"} = $interface_data{"\U$thorn GROUP $group\E DIM"}; + } + } + } + } + else + { + # No need to do a consistency check if only one thorn + # provides this implementation. + + } + +} + + + #/*@@ # @routine parse_interface_ccl # @date Wed Sep 16 15:07:11 1998 @@ -109,10 +362,10 @@ sub parse_interface_ccl { $current_group = "$2"; - if($know_groups{"\U$current_group\E"}) + if($known_groups{"\U$current_group\E"}) { print STDERR "Duplicate group $2 in thorn $thorn.\n"; - if($data[linenum+1] =~ m:\}:) + if($data[linenum+1] =~ m:\{:) { print STDERR "...Skipping block ....\n"; $linenum++ until ($data[$linenum] =~ m:\}:); @@ -121,10 +374,10 @@ sub parse_interface_ccl } else { - $know_groups{"\U$current_group\E"} = 1; + $known_groups{"\U$current_group\E"} = 1; } - $interface_db{"\U$thorn $block GROUPS \E"} .= " $2"; + $interface_db{"\U$thorn $block GROUPS\E"} .= " $2"; $interface_db{"\U$thorn GROUP $current_group\E VTYPE"} = "\U$1\E"; %options = split(/\s+|\s*=\s*/, $3); @@ -157,12 +410,12 @@ sub parse_interface_ccl } # Check that it is a know group type - if($interface_db{"\U$thorn GROUP $current_group\E GTYPE"} !~ m:SCALAR|GF|ARRAY:g) + if($interface_db{"\U$thorn GROUP $current_group\E GTYPE"} !~ m:SCALAR|GF|ARRAY:) { print STDERR "Unknown GROUP TYPE " . $interface_db{"\U$thorn GROUP $current_group\E GTYPE"} . " for group $current_group of thorn $thorn.\n"; - if($data[linenum+1] =~ m:\}:) + if($data[linenum+1] =~ m:\{:) { print STDERR "...Skipping block ....\n"; $linenum++ until ($data[$linenum] =~ m:\}:); @@ -184,9 +437,9 @@ sub parse_interface_ccl if($function =~ m:[^\s]+:) { - if(! $known_functions{"\U$function\E"}) + if(! $known_variables{"\U$function\E"}) { - $known_functions{"\U$function\E"} = 1; + $known_variables{"\U$function\E"} = 1; $interface_db{"\U$thorn GROUP $current_group\E"} .= " $function"; } @@ -203,9 +456,9 @@ sub parse_interface_ccl { # If no block, create a variable with the same name as group. $function = $current_group; - if(! $known_functions{"\U$function\E"}) + if(! $known_variables{"\U$function\E"}) { - $known_functions{"\U$function\E"} = 1; + $known_variables{"\U$function\E"} = 1; $interface_db{"\U$thorn GROUP $current_group\E"} .= " $function"; } diff --git a/lib/sbin/parameter_parser.pl b/lib/sbin/parameter_parser.pl index adb6dc5d..d2881648 100644 --- a/lib/sbin/parameter_parser.pl +++ b/lib/sbin/parameter_parser.pl @@ -31,7 +31,7 @@ sub create_parameter_database foreach $imp (keys %implementations) { # Read the data - @indata = read_file("$implementations{$imp}/param.ccl"); + @indata = &read_file("$implementations{$imp}/param.ccl"); # Get the parameters from it @new_parameter_data = &parse_param_ccl($imp, @indata); |