Mercurial > hg > Members > kono > TL1bt
changeset 0:76f88d2d6cd6
TL/1 implemention in Unix
| author | Shinji KONO <kono@ie.u-ryukyu.ac.jp> |
|---|---|
| date | Wed, 14 Oct 2020 18:22:25 +0900 |
| parents | |
| children | 7e03f04b23ec |
| files | index.ind t1.tl1 t2.tl1 t3.tl1 t4.tl1 tl1trans/tl1trans.pl |
| diffstat | 6 files changed, 310 insertions(+), 0 deletions(-) [+] |
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/index.ind Wed Oct 14 18:22:25 2020 +0900 @@ -0,0 +1,7 @@ +-title: TL/1 + +<a href="tl1j.html"> TL/1 言語仕様書 </a>l +<a href="t1.tl1"> 例題 t1.tl1 </a> +<a href="t2.tl1"> 例題 t2.tl1 </a> +<a href="t3.tl1"> 例題 t3.tl1 </a> +<a href="t4.tl1"> 例題 t4.tl1 </a>
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/t1.tl1 Wed Oct 14 18:22:25 2020 +0900 @@ -0,0 +1,27 @@ +% ** 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
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/t2.tl1 Wed Oct 14 18:22:25 2020 +0900 @@ -0,0 +1,24 @@ +% ** SPRITE TEST PROGRAM ** +PROC WAIT,TIME +%--- MAIN --- +VAR MMI,MMJ,MMK +BEGIN + MMI:=1 MMJ:=2 MMK:=3 + WAIT + WRITE(1:MMI,CRLF) +END +%-- PROCEDURE WAIT -- +WAIT +VAR WWJ,WWK +BEGIN + WWJ:=4 + TIME + WRITE(1:MMI,WWJ,CRLF) +END +%-- PROCEDURE TIME -- +TIME +VAR TTK,TTJ +BEGIN + TTK:=5 + WRITE(1:MMI,TTK,CRLF) +END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/t3.tl1 Wed Oct 14 18:22:25 2020 +0900 @@ -0,0 +1,27 @@ +% ** SPRITE TEST PROGRAM ** +PROC WAIT +FUNC TIME +%--- MAIN --- +VAR MMI,MMJ,MMK +BEGIN + WRITE(1:ASCII($A)) + MMI:=1 MMJ:=2 MMK:=3 + WAIT(4,5) + WRITE(1:MMI,CRLF) +END +%-- PROCEDURE WAIT -- +WAIT(WWA,WWB) +VAR WWJ,WWK +BEGIN + WWJ:=4 + WWK:=TIME(6,7) + WRITE(1:MMI,WWJ,WWA,WWB,WWK,CRLF) +END +%-- PROCEDURE TIME -- +TIME(TTA,TTB) +VAR TTK,TTJ +BEGIN + TTK:=5 + WRITE(1:MMI,TTK,TTA,TTB,CRLF) + RETURN TTK +END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/t4.tl1 Wed Oct 14 18:22:25 2020 +0900 @@ -0,0 +1,44 @@ +% ** TEST PROGRAM ** +FUNC SEARCH +%--- MAIN --- +VAR DICT,BUF +ARRAY TEND[1] +BEGIN + TELL(DICT,TEND) + DICT := OPENM($2,0) + WRITE(DICT:ASCII(0)) + WRITE(DICT:ASCII(30),ASCII(-'P'),"ROC") + WRITE(DICT:ASCII(31),ASCII(-'F'),"UNC") + WRITE(DICT:ASCII(33),ASCII(-'V'),"AR",CRLF) + TELL(DICT,TEND) + BUF := OPENM($2,0) + WRITE(BUF:"FUNC",ASCII(0)) + WRITE(0:SEARCH(BUF),CRLF) + SEEK(BUF,0) + WRITE(BUF:"NONAME",ASCII(0)) + WRITE(0:SEARCH(BUF),CRLF) +END + +SEARCH(BUF) +VAR VAL,K,C +ARRAY BEND[1] +BEGIN + VAL := SEEK(DICT,TEND) + TELL(BUF,BEND) + WHILE VAL#0 DO [ + C:=SEEKR(BUF,-1) + K:=SEEKR(DICT,-1) + IF K.LT.0 THEN [ + IF C=-K THEN + RETURN VAL % FOUND + VAL := SEEKR(DICT,-1) + ] ELSE IF C#K THEN [ + SEEK(BUF,BEND) + REPEAT + K:=SEEKR(DICT,-1) + UNTIL K.LT.0 + VAL := SEEKR(DICT,-1) + ] + ] + RETURN VAL % NOT FOUND +END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tl1trans/tl1trans.pl Wed Oct 14 18:22:25 2020 +0900 @@ -0,0 +1,181 @@ +#!/usr/bin/perl -w +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 @gvar; + +&getDecl; +&procs; + +# get line without comment +sub getline { + exit 1 if (eof) ; + $_ = <>; + 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 (/^VAR (.*)/) { + @gvar = split(/,/,$1); + # print "gvar @gvar\n"; + next; + } + if (/^BEGIN/) { + my $gvar = ""; + for my $var (@gvar) { + $gvar .= "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> + +void write() { +} + +$gvar; +$procs; +$funcs; + +int main(int ac, char *av[]) { +EOFEOF + &getline; + &statement; + print <<"EOFEOF"; + return 0; +} +EOFEOF + last ; + } + } +} + +sub statement { + my $nest = 1 ; + statement : while(1) { + &getline; chop; + while($_ ne "") { + if (s/^WRITE\((\d+)://) { + my $d = $1; + while(s/.//) { + if ($& eq ")") { + &output(" write(); "); + } + } + } elsif (s/^[[({]//) { + &output("{"); next; + } elsif (s/^[])}]//) { + &output("}"); 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/^BEGIN//) { + $nest++; + } elsif (s/^END//) { + $nest--; + last statement if ($nest==0) ; + } elsif (s/^(\w+)//) { + &output(" $1();"); + } elsif (s/^.//) { + } + } + print "\n "; + } +} + +sub body { + while (&getline) {} ; +} + +sub procs { + my @lvar; + my $proc = ""; + 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/) { + &getline; + &statement; + print <<"EOFEOF"; +// end $proc +EOFEOF + } elsif (/^(\w+)/) { + $proc = $1; + } + } +} + +sub output { + my ($o) = @_; + print $o; +} + +print "\n"; + +