# HG changeset patch
# User Shinji KONO <kono@ie.u-ryukyu.ac.jp>
# Date 1602667345 -32400
# Node ID 76f88d2d6cd6a815742e61908d584dba36b95fab

TL/1 implemention in Unix

diff -r 000000000000 -r 76f88d2d6cd6 index.ind
--- /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>
diff -r 000000000000 -r 76f88d2d6cd6 t1.tl1
--- /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
diff -r 000000000000 -r 76f88d2d6cd6 t2.tl1
--- /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
diff -r 000000000000 -r 76f88d2d6cd6 t3.tl1
--- /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
diff -r 000000000000 -r 76f88d2d6cd6 t4.tl1
--- /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
diff -r 000000000000 -r 76f88d2d6cd6 tl1trans/tl1trans.pl
--- /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";
+
+