Mercurial > hg > Members > kono > TL1bt
view tl1trans/tl1trans.pl @ 6:1896f63eedc1
...
author | Shinji KONO <kono@ie.u-ryukyu.ac.jp> |
---|---|
date | Wed, 04 Nov 2020 17:38:45 +0900 |
parents | 91e08ff0630d |
children | c95d28c5aaf2 |
line wrap: on
line source
#!/usr/bin/perl use strict; # % ** SPRITE TEST PROGRAM ** # PROC WAIT,TIME # %--- MAIN --- # VAR I # BEGIN # WRITE(1:"Do ") # FOR I:=1 TO 10 DO [ # WRITE(1:I,CRLF) # TIME # ] # WAIT # END # %-- PROCEDURE WAIT -- # WAIT # VAR I,J,K # BEGIN # FOR I:=0 TO 1 DO [ # FOR J:=0 TO 255 DO [ # FOR K:=0 TO 255 DO []]] # END # %-- PROCEDURE TIME -- # TIME # VAR I,J # BEGIN # FOR I:=0 TO 10 DO [ # FOR J:=0 TO 150 DO []] # END # proc # func # var # main # proc list my @procs; my @funcs; my @array; my @gvar; my %args; my $proc = ""; sub isfunc { foreach my $key (@funcs) { return 1 if ($key eq $proc) ; } return 0; } &getDecl; &procs; my $nest = 0; # get line without comment sub getline { if (eof) { &proto; exit 1; } $_ = <>; s/^\%.*//; } # get declaration sub getDecl { decl : while(1) { &getline; if (/^PROC (.*)/) { @procs = split(/,/,$1); # print "proc @proc\n"; next; } if (/^FUNC (.*)/) { @funcs = split(/,/,$1); # print "func @func\n"; next; } if (/^ARRAY (.*)/) { @array = split(/,/,$1); # print "func @func\n"; next; } if (/^VAR (.*)/) { @gvar = split(/,/,$1); # print "gvar @gvar\n"; next; } if (/^BEGIN/) { my $gvar = ""; for my $var (@gvar) { $gvar .= "unsigned char $var;\n"; } my $array = ""; for my $var (@array) { $array .= "unsigned char $var;\n"; } my $procs = ""; # for my $var (@procs) { # $procs .= "void $var();\n"; #} #my $funcs = ""; #for my $var (@funcs) { # $procs .= "int $var();\n"; #} print <<"EOFEOF"; #include <stdio.h> #include <string.h> #include <unistd.h> #include "proto.h" $gvar; $array; int main(int ac, char *av[]) { { EOFEOF $nest = 1 ; &statement(0); print <<"EOFEOF"; return 0; } EOFEOF last ; } } } # # assumption # an expression has no space in it # space means a statement separation our $cnest = 0; our $st = 0; sub statement { my ($skip) = @_; statement : while(1) { if ($skip) { $skip = 0; } else { &getline; chop; } while($_ ne "") { if (s/^\s+//) { print "$&"; if ($st) { print ";"; $st = 0; } } if (s/^WRITE\((\d+)://) { my $d = $1; while($_ ne "") { if (s/^\"//) { my $str = ""; while(s/.//) { last if ($& eq '"') ; if ($& eq '\\') { if (s/.//) { if ($& eq "\"") { $str .= "\\\"" ; } else { $str .= "\\$&" ; } } } else { $str .= $&; } } if ($str ne "") { $str = "\"$str\""; &output("write($d,$str,strlen($str));") } } elsif (s/^CRLF//) { &output("write($d,\"\\n\",1);"); } elsif (s/^\w+//) { &output("dprintf($d,\"%d\",$&);"); } elsif (s/.//) { } elsif ($& eq ")") { last; } } } elsif (s/^[[{]//) { &output("{"); $nest++; next; } elsif (s/^[]}]//) { &output("}"); $nest--; next; # FOR I:=1 TO 10 DO [ } elsif (s/^FOR\s+(\w+):=(\w+)\s+TO\s+(\w+)\s+DO\s*//) { &output("for($1=$2;$1<$3;$1++)"); } elsif (s/^FOR\s+(\w+):=(\w+)\s+DOWNTO\s+(\w+)\s+DO\s*//) { &output("for($1=$2;$1>$3;$1--)"); } elsif (s/^CASE\s+(\w+)\s+OF\s+(\w+)//) { local $cnest; &output("switch ($1) { \n case $1 : "); while (1) { $cnest = $nest ; $nest = 0; &statement(1); if (s/\s+ELSE\s+(\w+)\s+//) { &output("\ndefault:\n"); &statement(1) ; &output("}\n"); last; } elsif (s/\s+(\w+)\s+//) { &output("\ncase $1:\n"); } } $nest = $cnest ; } elsif (s/^IF\s*//) { &output("if ("); } elsif (s/^THEN\s*//) { &output(") "); } elsif (s/^ELSE\s*//) { &output(" else "); } elsif (s/^DO\s*//) { &output("do { "); } elsif (s/^REPEAT\s*//) { &output("do { "); } elsif (s/^WHILE\s+([^\s]*)\s+DO\s+//) { &output("while ($1) "); } elsif (s/^WHILE\s*//) { &output("while "); } elsif (s/^UNTIL\s+([^\s]*)\s+//) { &output("} while ($1 == 0);"); } elsif (s/^BEGIN\s*//) { &output("{"); $nest++; } elsif (s/^END\s*//) { &output("}"); $nest--; last statement if ($nest==0) ; } elsif (s/^RETURN\s*//) { &output("return"); } elsif (s/^:=\s*//) { &output("="); } elsif (s/^=\s*//) { &output("=="); } elsif (s/^(\w+)//) { &output(" $1"); } elsif (s/^.//) { &output($&); } } print "\n "; } } sub body { while (&getline) {} ; } sub procs { my @lvar; while(1) { &getline; if (/^VAR (.*)/) { @lvar = split(/,/,$1); print "\n\n"; my $type = "void "; my $args = ""; my $lvar = ""; for my $var (@lvar) { $lvar .= " unsigned char $var;\n"; } print <<"EOFEOF"; $type$proc($args) { $lvar; { EOFEOF } elsif (/^BEGIN/) { $nest = 1; &statement(0); print <<"EOFEOF"; }\n // end $proc EOFEOF } elsif (/^(\w+)\([\w,]+\)/) { $proc = $1; $args{$proc} = $2; # split(/,/,$2); } elsif (/^(\w+)/) { $proc = $1; } } } sub proto { open my $fd, ">","proto.h"; foreach my $key ( @procs ) { print $fd "void "; print $fd $key,"("; if ($args{$key}) { print $fd "unsigned char ",join(",unsigned char ",split(/,/,$args{$key})); } print $fd ");\n"; } foreach my $key ( @funcs ) { print $fd "int "; print $fd $key,"("; if ($args{$key}) { print $fd "unsigned char ",join(",unsigned char ",split(/,/,$args{$key})); } print $fd ");\n"; } close $fd; } sub output { my ($o) = @_; $st = 1; print $o; } print "\n";