# MAIN # print "\f>> XTAB PreProcessor V0.9 (2000/01/09)\n\n"; print ">> Documentation: http://www.holg.com/xtab\n\n"; if (defined($ARGV[0])) {;} else { pp_error("No source program"); exit(1); } $prog=$ARGV[0]; $f_h=''; $f_c=''; $eof=0; $sect=''; $sectid=''; $errs=0; $n_freqs=0; $n_outs=0; $pp_cnt=0; $n_tabs=0; %vars=(); %vlbs=(); $vars{"data"}=0; $vlbs{"data"}="DATA"; if (open (OLD,$ARGV[0])) {;} else { print "Cant open file: <$ARGV[0]>\n\n"; exit(1); } open (PPO,">$prog".".ppo"); print PPO "sub get_pname {return \"$ARGV[0]\"}\n"; get_old(); if (($sect eq "*f") || ($sect eq "*files")) { $sect = "*f"; print PPO "sub pp_files {\n"; s_files(); print PPO "}\n"; } else {print PPO "sub pp_files {}\n"} if (($sect eq "*v") || ($sect eq "*variables")) { $sect = "*v"; print PPO "sub pp_vars {\n"; s_vars(); print PPO "}\n"; } else {print PPO "sub pp_vars {}\n"} if ($sect eq "*init") { $sect = "*init"; print PPO "sub pp_init {\n"; $iflevel=0; s_ins(); if ($iflevel != 0) { pp_error("Unbalanced IF's"); } print PPO "}\n"; } else {print PPO "sub pp_init {}\n"} if (($sect eq "*i") || ($sect eq "*instructions")) { $sect = "*i"; print PPO "sub pp_ins {\n"; $iflevel=0; s_ins(); if ($iflevel != 0) { pp_error("Unbalanced IF's"); } print PPO "}\n"; } else {print PPO "sub pp_ins {}\n"} if ($sect eq "*term") { $sect = "*term"; print PPO "sub pp_term {\n"; $iflevel=0; s_ins(); if ($iflevel != 0) { pp_error("Unbalanced IF's"); } print PPO "}\n"; } else {print PPO "sub pp_term {}\n"} if (($sect eq "*t") || ($sect eq "*tables")) { $sect = "*t"; s_tabs(); print PPO "sub pp_tables {\n"; for ($i=1; $i<=$n_tabs; $i++) {print PPO " pp_table_$i();\n"} print PPO "}\n"; } else {print PPO "sub pp_tables {}\n"} close(OLD); print PPO "sub pp_freqs {\n"; for ($i=1; $i<=$n_freqs; $i++) { $fid="f_".$i."_"; print PPO " \%$fid"."array=();\n"; print PPO " \%$fid"."point=();\n"; print PPO " \$$fid"."count=0;\n"; } print PPO "}\n"; print PPO "sub pp_open_outs {\n"; foreach $oh(keys %ohs) { print PPO " open($oh,'>$ohs{$oh}') || die(\"Cant open output file: <$ohs{$oh}>\");\n"; print PPO " \$c_$oh=0;\n"; # print PPO " \$a_ohs{\$$oh}=\$$oh;\n"; } if ($f_h ne "") { print PPO " open(HTM,'>$f_h');\n"; } if ($f_c ne "") { print PPO " open(CSV,'>$f_c');\n"; } print PPO "}\n"; print PPO "sub pp_close_outs {\n"; foreach $oh(keys %ohs) { print PPO " close($oh);\n"; } print PPO "}\n"; print PPO "sub pp_count_outs {\n"; foreach $oh(keys %ohs) { print PPO ' printf("#%9s: %12.0f\n",'."$oh,\$c_$oh);\n"; } print PPO ' print "\n";'."\n"; print PPO "}\n"; close(PPO); if ($errs > 0) { print "\nERRORS: $errs\n\n"; exit(1); } print "\n\n"; # # END MAIN # sub get_old { $r=''; $rec=''; $e_sw="f"; l_blank: $pp_cnt++; $r=; if (defined $r) { chomp($r); printf("%6.0f. %s\n",$pp_cnt,$r); if (substr($r,0,2) eq "* ") {goto l_blank} if ($r eq "*") {goto l_blank} if ((' ' x length($r)) eq $r) {goto l_blank} if ($r =~ /,$/) { $rec.=$r; goto l_blank; } elsif ($r =~ /&$/) { chop($r); $rec.=$r; goto l_blank; } else {$rec.=$r} $sect=''; if (substr($rec,0,1) eq "*") { $rec=trim($rec); $sect=$rec; $sectid=$sect; return; } @tks=(); @tks=split(' ',$rec); } else { $rec=''; $sect=''; $sectid=''; $eof=1 } } sub pp_error { print "\n\$ERROR: @_\n\n"; $e_sw="t"; $errs++; } sub q_done { if ($eof==1) {return(0)} if ($sect ne '') {return(0)} return(1); } sub g_cds { # Get _ Comma Delimited Strings my $s=shift(@_); my @w=(); my @s=split(',',$s); foreach $s(@s) {$s=~s/^\s+//; $s=~s/\s+$//; @w=(@w,$s);} return(@s); } sub parse_s { (my $s)=(@_); $tk=''; $tkc=0; @tks=(); $qtstate="f"; for ($i=0; $i < length($s); $i++) { $c=substr($s,$i,1); if ($c eq "'") { if ($qtstate eq "t") { $qtstate="f"; } else { $qtstate="t"; } $tk.=$c; } elsif ($c eq ",") { if ($qtstate eq "f") { $tks[$tkc]=$tk; $tkc++; $tk=''; } else { $tk.=$c } } else { $tk.=$c; } } $tks[$tkc]=$tk; # $tkc=0; foreach $tk(@tks) { $tk=trim($tk); if ($tk =~ /'/) { $qtc=0; while ($tk =~ /'/g) {$qtc++} if (!($qtc == 2)) { pp_error("Improper use of ' in <$tk>\n"); last; } if (substr($tk,0,1).substr($tk,-1,1) eq "''") { # $tk =~ s/'//g; $tks[$tkc]=$tk; $tkc++; next; } pp_error("Improper use of ' in <$tk>"); last; } else { $tks[$tkc]=$tk; $tkc++; } } } # sub parse_sr { (my $s)=(@_); $tk=''; $tkc=0; @tks=(); @tkfs=(); @tkts=(); $qtstate="f"; for ($i=0; $i < length($s); $i++) { $c=substr($s,$i,1); if ($c eq "'") { if ($qtstate eq "t") { $qtstate="f"; } else { $qtstate="t"; } $tk.=$c; } elsif ($c eq ",") { if ($qtstate eq "f") { $tks[$tkc]=$tk; $tkc++; $tk=''; } else { $tk.=$c } } else { $tk.=$c; } } $tks[$tkc]=$tk; # $tkc=0; foreach $tk(@tks) { $tk=trim($tk); if ($tk =~ /'/) { $qtc=0; while ($tk =~ /'/g) {$qtc++} if (!(($qtc == 2) || ($qtc == 4))) { pp_error("Improper use of ' in <$tk>\n"); last; } $j=0; for ($i=0; $i < length($tk); $i++) { if (substr($tk,$i,1) eq "'") { $j++; $qts[$j]=$i; } } if ($qtc == 4) { $dash=trim(substr($tk,$qts[2]+1,$qts[3]-$qts[2]-1)); if ($dash ne "-") { pp_error("Dash expected between quote strings <$tk>\n"); last; } $tkfs[$tkc]=substr($tk,$qts[1],$qts[2]-$qts[1]+1); $tkts[$tkc]=substr($tk,$qts[3]); $tkc++; next; } if (substr($tk,0,1).substr($tk,-1,1) eq "''") { $tkfs[$tkc]=$tk; $tkts[$tkc]=$tk; $tkc++; next; } if (substr($tk,0,1) eq "'") { $dash=trim(substr($tk,$qts[2]+1)); if (substr($dash,0,1) ne "-") { pp_error("Dash expected after quote string <$tk>"); last; } $tkfs[$tkc]=substr($tk,0,$qts[2]+1); $tkts[$tkc]=trim(substr($dash,1)); $tkc++; next; } if (substr($tk,-1,1) eq "'") { $dash=trim(substr($tk,0,$qts[1])); if (substr($dash,-1,1) ne "-") { pp_error("Dash expected before quote string <$tk>"); last; } chop($dash); $tkfs[$tkc]=trim($dash); $tkts[$tkc]=substr($tk,$qts[1]); $tkc++; next; } pp_error("Improper use of ' in <$tk>"); last; } else { if ($tk =~ /-/) { ($tkfs[$tkc],$tkts[$tkc])=split('-',$tk); $tkfs[$tkc]=trim($tkfs[$tkc]); $tkts[$tkc]=trim($tkts[$tkc]); } else { $tkfs[$tkc]=$tk; $tkts[$tkc]=$tk; } $tkc++; } } } # sub parse_n { my $s=shift(@_); my $tkc=0; @tks=g_cds($s); @tkfs=(); @tkts=(); foreach $tk(@tks) { if (($tkc+1) == @tks) { if ($tks[$tkc] eq "#") { $tkfs[$tkc]="#"; $tkts[$tkc]="#"; next; } } $dashc=0; while ($tk =~ /-/g) {$dashc++} if ($dashc == 0) { $tkfs[$tkc]=$tk; if (exists($vars{$tkfs[$tkc]})) {;} else { if ($tkfs[$tkc] =~ /^[0-9]+$/) {;} else { pp_error("Not numeric <$tk>"); last; } } $tkts[$tkc]=$tk; $tkc++; } elsif ($dashc == 1) { ($tkfs[$tkc],$tkts[$tkc])=split('-',$tk); $tkfs[$tkc]=trim($tkfs[$tkc]); if (exists($vars{$tkfs[$tkc]})) {;} else { if ($tkfs[$tkc] =~ /^[0-9]+$/) {;} else { pp_error("Not numeric <$tk>"); last; } } $tkts[$tkc]=trim($tkts[$tkc]); if (exists($vars{$tkts[$tkc]})) {;} else { if ($tkts[$tkc] =~ /^[0-9]+$/) {;} else { pp_error("Not numeric <$tk>"); last; } } $tkc++; } else { pp_error("Too many - in <$tk>"); last; } } } # sub trim { (my $s)=(@_); $s =~s/^\s+//; $s =~ s/\s+$//; return $s } sub s_cond { %conds = ("==",1,"!=",1,"eq",1,"ne",1,"<",0,"<=",0,">=",0,">",0,"gt",0,"ge",0,"le",0,"lt",0, "numeric",2,"nnumeric",2); %condn = ("==",1,"!=",1,"<",0,"<=",0,">=",0,">",0); @tks=split(' ',$rec); $v=$tks[0]; if (exists($vars{$v})) {;} else { pp_error("Undefined Variable: ".$v); return; } $rec =~ s/$v//; $cond=$tks[1]; $rec =~ s/$cond//; if ($cond eq "=") {$cond="=="} if (!(exists($conds{$cond}))) { pp_error("<$cond> Expecting condition <= == != < <= >= > eq ne ge gt le lt numeric nnumeric>"); return; } if ($conds{$cond} == 2) {; } else { if (exists($condn{$cond})) { parse_n($rec); if ($e_sw eq "t") {get_old(); if (q_done()==0) {return} next;} } else { parse_sr($rec); if ($e_sw eq "t") {get_old(); if (q_done()==0) {return} next;} } if (@tks == 0) { pp_error("No arguments"); return; } if (@tks > 1) { if ($conds{$cond} == 0) { pp_error("Only 1 argument allowed"); return; } } } if ($cond eq "numeric") { print PPO ' if ($'."$v =~ ".'/^\d+$/) {;} else {$_sel=1; return;}'."\n"; } elsif ($cond eq "nnumeric") { print PPO ' if ($'."$v =~ ".'/^\d+$/) {$_sel=1; return;}'."\n"; } else { if (index("==!=<=>=",$cond) > -1) {$qt=''; $eq=$cond; $ge=">="; $le="<=";} else {$qt="'"; $eq="eq"; $ge="ge"; $le="le";} # if (index("!=ne",$cond) == -1) {$nb='(!'; $ne=")";} else {$nb=''; $ne='';} if (index("!=ne",$cond) == -1) {$nb=' '; $ne='';} else {$nb='(!'; $ne=")";} c_ifs(); } } sub c_ifs { my ($i,$or); $or=" ||"; $fp=$nb."("; $i=0; foreach $tkf(@tkfs) { $tkt=$tkts[$i]; $i++; if ($i > 1) {$fp=" "} if ($i == @tks) {$or =")$ne";} if (exists($vars{$tkf})) { $tkf='$'.$tkf; } elsif (substr($tkf,0,1) ne "'") { $tkf=$qt.$tkf.$qt } if (exists($vars{$tkt})) { $tkt='$'.$tkt; } elsif (substr($tkt,0,1) ne "'") { $tkt=$qt.$tkt.$qt } if ($tkf eq $tkt) { print PPO " $fp"."(\$$v $eq $tkf)$or\n"; } else { print PPO " $fp"."((\$$v $ge $tkf) && (\$$v $le $tkt))$or\n"; } } } sub s_files { $qq='"'; print PPO " \$_limit=0;\n"; get_old(); while (($sectid eq "*f") || ($sectid eq "*files")) { $tk0=$tks[0]; if (($tk0 eq "input") || ($tk0 eq "in")) { print PPO " \$_old=\"$tks[1]\";\n"; } elsif (($tk0 eq "limit") || ($tk0 eq "li")) { print PPO " \$_limit=$tks[1];\n"; } elsif (($tk0 eq "output") || ($tk0 eq "ou")) { $oh=$tks[1]; $n_outs++; $ohs{$oh}=$tks[2]; } elsif (($tk0 eq "html") || ($tk0 eq "ht")) { $f_h=$prog.".htm"; print PPO " \$f_h=$qq$f_h$qq;\n"; } elsif (($tk0 eq "csv") || ($tk0 eq "cs")) { $f_c=$prog.".csv"; print PPO " \$f_c=$qq$f_c$qq;\n"; } else { pp_error("Undefined command: <$tk0>"); } get_old(); if (q_done()==0) {return} } } sub s_vars { get_old(); while (q_done()==1) { @tks=split('/',$rec); $tks=@tks; $v=trim($tks[0]); if (var_ok() eq "f") { pp_error("Invalid varaible name <$v>"); get_old(); if (q_done()==0) {return}; next; } if ($tks == 1) { $vars{$v}=0; $vlbs{$v}=$v; print PPO " \$$v=''; \$$v='';\n"; } elsif ($tks == 2) { $vars{$v}=0; $vlbs{$v}=trim($tks[1]); if ($vlbs{$v} eq "") { $vlbs{$v}=$v; } print PPO " \$$v=''; \$$v='';\n"; } else { $vars{$v}=0; $vlbs{$v}=trim($tks[1]); if ($vlbs{$v} eq "") { $vlbs{$v}=$v; } $tk=trim($tks[2]); if ($tk =~ /^\d+$/) { print PPO " \$$v=''; \$$v=substr(\$_,".($tk-1).",1);\n"; } else { if ($tk =~ /-/) { ($sc,$ec)=(split("-",$tk)); $sc=trim($sc); $ec=trim($ec); if (($sc =~ /^\d+$/) && ($ec =~ /^\d+$/)) { print PPO " \$$v=''; \$$v=substr(\$_,".($sc-1).",".($ec-$sc+1).");\n"; } else { print PPO " \$$v=''; \$$v='$tk';\n"; } } else { print PPO " \$$v=''; \$$v='$tk';\n"; } } } get_old(); } } sub var_ok { if (substr($v,0,1) =~ /[a-zA-Z]/) { for ($i=1; $i"); } $v='_s'; $rec =~ s/$tk0//; $rec =~ s/$oh//; parse_s($rec); if ($e_sw eq "t") {get_old(); if (q_done()==0) {return} next;} print PPO " \$$v='';\n"; foreach $tk(@tks) { if (exists($vars{$tk})) { print PPO " \$$v.=\$$tk;\n"; } elsif ($tk =~ /\dx/) { chop($tk); print PPO " \$$v.=' ' x $tk;\n"; } elsif (substr($tk,0,1) eq "'") { print PPO " \$$v.=$tk;\n"; } else { print PPO " \$$v.='$tk';\n"; } } print PPO ' print '.$oh.' "$_s\n";'."\n"; print PPO " \$c_$oh++;\n"; } elsif ($tk0 eq "trim") { $rec =~ s/$tk0//; @tks=g_cds($rec); foreach $tk(@tks) { if (exists($vars{$tk})) { print PPO " \$$tk=f_trim(\$$tk);\n"; } else { pp_error("Undefined variable: <$tk>"); } } } elsif (($tk0 eq "uc") || ($tk0 eq "ucase")) { $rec =~ s/$tk0//; @tks=g_cds($rec); foreach $tk(@tks) { if (exists($vars{$tk})) { print PPO " \$$tk=uc(\$$tk);\n"; } else { pp_error("Undefined variable: <$tk>"); } } } elsif (($tk0 eq "lc") || ($tk0 eq "lcase")) { $rec =~ s/$tk0//; @tks=g_cds($rec); foreach $tk(@tks) { if (exists($vars{$tk})) { print PPO " \$$tk=lc(\$$tk);\n"; } else { pp_error("Undefined variable: <$tk>"); } } } elsif (exists($vars{$tk0})) { $v=$tk0; if ($tks[1] eq "eq") { $rec =~ s/$v//; $rec =~ s/eq//; parse_s($rec); print PPO " \$$v='';\n"; foreach $tk(@tks) { if (exists($vars{$tk})) { print PPO " \$$v.=\$$tk;\n"; } elsif ($tk =~ /\dx/) { chop($tk); print PPO " \$$v.=' ' x $tk;\n"; } elsif (substr($tk,0,1) eq "'") { print PPO " \$$v.=$tk;\n"; } else { print PPO " \$$v.='$tk';\n"; } } } else { pp_error("Got <$tks[1]> Expecting "); } } else { pp_error("Undefined command: <$tk0>"); } get_old(); } } sub s_tabs { get_old(); while (($sectid eq "*t") || ($sectid eq "*tables")) { if (($tks[0] eq "table") || ($tks[0] eq "ta")) { $n_tabs++; $t="\$t_$n_tabs"; print PPO "sub pp_table_$n_tabs {\n"; print PPO ' my ($i,$j,$k,$key,@s1sort,@spsort,@w);',"\n"; print PPO " if (\$i_g_t == 1) {\n"; $s=$rec; $s =~ s/$tks[0]//; parse_s($s); for ($i=0; $i < @tks; $i++) {if ($tks[$i] eq '/') {$tks[$i]=" "}} $heads=join('&',@tks); $heads =~ s/'//g; } else { pp_error(" expected") } get_old(); if (q_done()==0) {return} while (($tks[0] eq "select") || ($tks[0] eq "se")) { $rec =~ s/$tks[0]//; print PPO " if\n"; s_cond(); print PPO " {;} else {\$_sel=1; return\n"; print PPO " }\n"; get_old(); if (q_done()==0) {return} } @s1ls=(); $s1lc=0; if (($tks[0] eq "labels") || ($tks[0] eq "la")) { $s=$rec; $s =~ s/$tks[0]//; parse_s($s); for ($i=0; $i<@tks; $i++) {$tks[$i] =~ s/'//g} @s1ls=@tks; $s1lc=@s1ls; get_old(); if (q_done()==0) {return} } if (($tks[0] eq "stub") || ($tks[0] eq "st")) { $stub=$tks[0]; shift(@tks); $s1v=shift(@tks); if (exists($vars{$s1v})) {$s1vl=$vlbs{$s1v}} else { pp_error("Undefined Variable: ".$s1v); get_old(); if (q_done()==0) {return} goto end_stub1; } $type=shift(@tks); $s1fn=0; if ($type eq "freq") { $n=shift(@tks); $n1=$n-1; $var="\$$s1v"; $vvar='$_s1'; $s1vc=$n; s_freqs(); $s1fn=$n_freqs; get_old(); if (q_done()==0) {return} goto end_stub1; } if (($type =~ /codes/) || ($type =~ /values/)) { $s=$rec; $s =~ s/$stub//; $s =~ s/$s1v//; $s =~ s/$type//; if ($type =~ /codes/) { parse_sr($s); } else { parse_n($s); } if ($e_sw eq "t") {goto end_stub1} # @tks=g_cds($s); $s1vc=@tks; if ($s1lc == 0) { @s1ls=@tks; $s1lc=@s1ls; } elsif ($s1vc != $s1lc) { pp_error("Label count: $s1lc <> Variable count: $s1vc"); get_old(); if (q_done()==0) {return} goto end_stub1; } $var="\$$s1v"; $vvar='$_s1'; t_ifs(); } else { pp_error("Keyword: expected"); get_old(); if (q_done()==0) {return} } get_old(); if (q_done()==0) {return} } else { pp_error(" expected") } end_stub1: @spls=(); $splc=0; if (($tks[0] eq "labels") || ($tks[0] eq "la")) { $s=$rec; $s =~ s/$tks[0]//; parse_s($s); for ($i=0; $i<@tks; $i++) {$tks[$i] =~ s/'//g} @spls=@tks; $splc=@spls; get_old(); if (q_done()==0) {return} } if (($tks[0] eq "spread") || ($tks[0] eq "sp")) { $spread=$tks[0]; shift(@tks); $spv=shift(@tks); if (exists($vars{$spv})) {$spvl=$vlbs{$spv}} else { pp_error("Undefined Variable: ".$spv); get_old(); if (q_done()==0) {return} goto end_spread; } $type=shift(@tks); $spfn=0; if ($type eq "freq") { $n=shift(@tks); $n1=$n-1; $var="\$$spv"; $vvar='$_sp'; $spvc=$n; s_freqs(); $spfn=$n_freqs; # get_old(); if (q_done()==0) {return} goto end_spread; } if (($type =~ /codes/) || ($type =~ /values/)) { $s=$rec; $s =~ s/$spread//; $s =~ s/$spv//; $s =~s /$type//; if ($type =~ /codes/) { parse_sr($s); } else { parse_n($s); } if ($e_sw eq "t") {goto end_spread} # @tks=g_cds($s); $spvc=@tks; if ($splc == 0) { @spls=@tks; $splc=@spls; } elsif ($spvc != $splc) { pp_error("Label count: $splc <> Variable count: $spvc"); get_old(); if (q_done()==0) {return} goto end_spread; } $var="\$$spv"; $vvar='$_sp'; t_ifs(); } else { pp_error("Keyword: expected"); get_old(); if (q_done()==0) {return} } } else {pp_error(" expected")} end_spread: @s1ls=("TOTAL",@s1ls); @spls=("TOTAL",@spls); print PPO " $t"."[\$_s1][\$_sp]++;"."\n"; print PPO " return;}\n"; print PPO " if (\$i_g_t == 0) {\n"; print PPO " for (\$_i=0; \$_i<=$s1vc;\$_i++) {"."\n"; print PPO " for (\$_j=0; \$_j<=$spvc;\$_j++) {"."\n"; print PPO " $t"."[\$_i][\$_j]=0;"."\n"; print PPO " } }\n"; print PPO " return;}\n"; print PPO " for (\$_i=0; \$_i<=$s1vc;\$_i++) {"."\n"; print PPO " for (\$_j=0; \$_j<=$spvc;\$_j++) {"."\n"; print PPO " $t"."[\$_i][0]+=$t"."[\$_i][\$_j];"."\n"; print PPO " $t"."[0][\$_j]+=$t"."[\$_i][\$_j];"."\n"; print PPO " } }\n"; print PPO " for (\$_i=1; \$_i<=$spvc;\$_i++) {$t"."[0][0]+=$t"."[0][\$_i]}"."\n"; print PPO ' $pt_heads="'.$heads.'";'."\n"; # print PPO ' $pt_s1v="'.$s1v.'";'."\n"; print PPO ' $pt_s1vl="'.$s1vl.'";'."\n"; if ($s1fn == 0) { print PPO ' $pt_s1vc='."$s1vc;\n"; print PPO ' @pt_s1ls=split("&","'.join('&',@s1ls).'");'."\n"; print PPO ' $i=0; foreach $key(@pt_s1ls) {$s1sort[$i]=$i; $i++}'."\n"; } else { print PPO ' $pt_s1vc=$f_'."$s1fn"."_count;\n"; print PPO ' $i=0; $s1sort[0]=0;'."\n"; print PPO ' @pt_s1ls=("TOTAL");'."\n"; print PPO ' foreach $key(sort keys %'."f_$s1fn"."_point) {\n"; print PPO ' $i++; $s1sort[$i]=$f_'.$s1fn.'_point{$key};'."\n"; print PPO ' @pt_s1ls=(@pt_s1ls,$key);'."\n"; print PPO " }\n"; } # print PPO ' $pt_spv="'.$spv.'";'."\n"; print PPO ' $pt_spvl="'.$spvl.'";'."\n"; if ($spfn == 0) { print PPO ' $pt_spvc='."$spvc;\n"; print PPO ' @pt_spls=split("&","'.join('&',@spls).'");'."\n"; print PPO ' $i=0; foreach $key(@pt_spls) {$spsort[$i]=$i; $i++}'."\n"; } else { print PPO ' $pt_spvc=$f_'."$spfn"."_count;\n"; print PPO ' $i=0; $spsort[0]=0;'."\n"; print PPO ' @pt_spls=("TOTAL");'."\n"; print PPO ' foreach $key(sort keys %'."f_$spfn"."_point) {\n"; print PPO ' $i++; $spsort[$i]=$f_'.$spfn.'_point{$key};'."\n"; # print PPO ' foreach $key(sort keys %'.substr($fid,1)."point) {\n"; # print PPO ' $i++; $spsort[$i]='.$fid.'point{$key};'."\n"; print PPO ' @pt_spls=(@pt_spls,$key);'."\n"; print PPO " }\n"; } # print PPO ' $pt_spvc='."$spvc;\n"; # print PPO ' @pt_spls=split("&","'.join('&',@spls).'");'."\n"; print PPO ' for ($i=0; $i<=$pt_s1vc; $i++) {'."\n"; print PPO ' for ($j=0; $j<=$pt_spvc; $j++) {'."\n"; print PPO ' $w[$i][$j]=$'.substr($t,1).'[$s1sort[$i]][$spsort[$j]];'."\n"; print PPO " }}\n"; print PPO ' @pt_tab=@w;'."\n"; print PPO " pp_ptabs();\n"; print PPO "}\n"; get_old(); if (q_done()==0) {return} } } sub t_ifs { my ($if,$i,$i1); $if=" if "; $qt="'"; $eq="eq"; $ge="ge"; $le="le"; if ($type eq "values") { $qt=''; $eq="=="; $ge=">="; $le="<=";} $loopcnt=@tks; if ($tks[-1] eq "#") {$loopcnt--} for ($i=0; $i < $loopcnt; $i++) { $i1=$i+1; if ($i > 0) {$if = " elsif "} if ($tkfs[$i] eq $tkts[$i]) { $tkfs[$i] =~ s/'//g; print PPO "$if ($var $eq $qt$tkfs[$i]$qt) {$vvar=$i1}\n"; } else { $vl=$tkfs[$i]; $vl =~ s/'//g; $vh=$tkts[$i]; $vh =~ s/'//g; print PPO "$if (($var $ge $qt$vl$qt) &&\n"; print PPO " ($var $le $qt$vh$qt)) {$vvar=$i1}\n"; } # if (index($tks[$i],'-') == -1) { # print PPO "$if ($var $eq $qt$tks[$i]$qt) {$vvar=$i1}\n"; # } else { # ($vl,$vh)=split('-',$tks[$i]); # print PPO "$if (($var $ge $qt$vl$qt) &&\n"; # print PPO " ($var $le $qt$vh$qt)) {$vvar=$i1}\n"; # } } if ($tks[-1] eq "#") {$loopcnt++; print PPO " else {$vvar=$loopcnt}\n"} else {print PPO " else {return}\n"} } sub s_freqs { $n_freqs++; $fid='$f_'.$n_freqs."_"; print PPO " if (exists($fid"."array{$var})) {\n"; print PPO " $fid"."array{$var}++;\n"; print PPO " $vvar=$fid"."point{$var};\n"; print PPO " } else {\n"; print PPO " if ($n1 > $fid"."count) {\n"; print PPO " $fid"."count++;\n"; print PPO " $fid"."array{$var}=1;\n"; print PPO " $fid"."point{$var}=$fid"."count;\n"; print PPO " $vvar=$fid"."point{$var};\n"; print PPO " } else {\n"; print PPO " $fid"."count=$n;\n"; print PPO " $fid"."point{\$_hv}=$n;\n"; print PPO " $vvar=$n;\n"; print PPO " } }\n"; }