Initial upstream version 9.4.3upstream/9.4.3

34 files changed, 2865 insertions, 0 deletions

diff --git a/ipl/packs/tcll1/Makefile b/ipl/packs/tcll1/Makefile
new file mode 100644
index 0000000..d15cf0b
--- /dev/null
+++ b/ipl/packs/tcll1/Makefile
@@ -0,0 +1,10 @@
+tcll1:
+	icont -s -c xcode  escape ebcdic 
+	icont -s -c gramanal ll1 semstk readll1 parsell1 scangram semgram
+	icont -s -fs tcll1
+
+Iexe:	tcll1
+	cp tcll1 ../../iexe/
+
+Clean:
+	rm -f *.u[12] tcll1
diff --git a/ipl/packs/tcll1/NOTICE b/ipl/packs/tcll1/NOTICE
new file mode 100644
index 0000000..625626b
--- /dev/null
+++ b/ipl/packs/tcll1/NOTICE
@@ -0,0 +1,4 @@
+In order to comply with the file-naming requirements for
+CD-ROM production, dashes in file names have been converted to
+underscores.  You may find references to file names with
+dashes in the documentation; use the underscore versions.
diff --git a/ipl/packs/tcll1/README b/ipl/packs/tcll1/README
new file mode 100644
index 0000000..690d7c9
--- /dev/null
+++ b/ipl/packs/tcll1/README
@@ -0,0 +1,94 @@
+				TCLL1
+		The TCLL1 Parser Generator and Parser
+		(TC: "Tools of Computing")
+
+BUILD1.BAT    MS-DOS batch file to compile TCLL1. It should be
+		able to execute	as a shell script under UNIX.
+
+TCLL1.ICN	main program for TCLL1
+LL1.ICN		LL(1) parser generation routines
+SCANGRAM.ICN	scanner for input grammars
+SEMGRAM.ICN	semantics routines for handling the input grammars
+TCLL1.GRM	grammar for input grammars
+TCLL1.LL1	translated input grammar for input grammars
+GRAMANAL.ICN	context-free grammar analysis module
+
+PARSELL1.ICN	LL(1) parser
+READLL1.ICN	input routine for translated grammars
+SEMSTK.ICN	semantics routines called by PARSELL1.ICN to handle
+		the semantics stack
+
+RPTPERR.ICN	routine to report syntax errors
+
+SEMOUT.ICN	semantics routines just to write out the tokens and
+		action symbols (for early stages of debugging the
+		grammar)
+
+
+		Building the parser generator
+
+Before reading the rest of this description of TCLL1, you
+should compile it on your own system. That will allow you to
+try out the test grammars as they are discussed.
+
+If you do not have a copy of Icon, you can get it over the
+Internet: ftp it from cs.arizona.edu:
+	ftp ftp.cs.arizona.edu
+	name: anonymous
+	password: your_e-mail_address
+	cd icon
+
+Versions of Icon for several machines are in subdirectories of
+directory icon. You may also want to pick up the Icon
+Programming Library.
+
+If you have the Icon Programming Library (IPL) installed on a
+DOS/WINDOWS machine, you can execute the batch file
+mktcll1.bat to build the parser generator. The three files from
+the IPL that the parser generator uses are included with this
+distribution and can be compiled separately. To build the
+parser generator by hand, you may execute
+
+	rem 	These are from the Icon Program Library:
+
+	icont -c  escape ebcdic xcode
+
+	rem 	These form the parser generator proper
+
+	icont -c gramanal ll1 semstk readll1 parsell1 scangram semgram
+	icont -fs tcll1
+
+The first icont line compiles the files from the IPL. You may
+omit the line if you have the IPL installed. The second icont
+line compiles modules used by the parser generator. The third
+line compiles the parser generator's main program. The flag -fs
+tells the translator that the parser generator calls some
+procedures by giving their names as strings. In Icon version 8,
+this flag is not needed; in version 9 it is.
+
+To use TCLL1 to build a parsing table, execute
+
+		Under Icon version 8:
+
+	iconx tcll1 grammar.grm
+
+		Under Icon version 9:
+
+	tcll1 grammar.grm
+
+where grammar.grm is the grammar file. The output of the parser
+generator will be encoded parse tables in file grammar.ll1 . If
+you would also like a listing of the grammar and diagnostic
+information, execute
+
+		Under Icon version 8:
+
+	iconx tcll1 -p grammar.grm
+
+		Under Icon version 9:
+
+	tcll1 -p grammar.grm
+
+Tlcll1 reads its own parsing table from file tcll1.ll1 which
+must be in the current directory.
+
diff --git a/ipl/packs/tcll1/bugs.grm b/ipl/packs/tcll1/bugs.grm
new file mode 100644
index 0000000..832932d
--- /dev/null
+++ b/ipl/packs/tcll1/bugs.grm
@@ -0,0 +1,9 @@
+start = e.
+e = e "+" t .
+e = e "-" t .
+t = t "*" t .
+t = t "/" t .
+t = f .
+p = i .
+p = "(" e ")" .
+
diff --git a/ipl/packs/tcll1/build1.bat b/ipl/packs/tcll1/build1.bat
new file mode 100644
index 0000000..2dd52d2
--- /dev/null
+++ b/ipl/packs/tcll1/build1.bat
@@ -0,0 +1,9 @@
+rem 	These are from the Icon Program Library:
+
+icont -c xcode  escape ebcdic 
+
+rem 	These form the parser generator proper
+
+icont -c gramanal ll1 semstk readll1 parsell1 scangram semgram
+icont -fs tcll1
+
diff --git a/ipl/packs/tcll1/c_ll1.grm b/ipl/packs/tcll1/c_ll1.grm
new file mode 100644
index 0000000..9bfec7c
--- /dev/null
+++ b/ipl/packs/tcll1/c_ll1.grm
@@ -0,0 +1,18 @@
+# c-ll1
+# LL(1)
+start = s .
+
+s = i ("=" e | ttail etail) .
+s = n ttail etail .
+s = "(" e ")" ttail etail .
+
+e = t etail.
+etail = { "+" t | "-" t } .
+
+t = f ttail .
+ttail = [ "*" t | f "/" t ].
+
+f = i .
+f = n .
+f = "(" e ")" .
+
diff --git a/ipl/packs/tcll1/c_nll1.grm b/ipl/packs/tcll1/c_nll1.grm
new file mode 100644
index 0000000..dd21dc5
--- /dev/null
+++ b/ipl/packs/tcll1/c_nll1.grm
@@ -0,0 +1,16 @@
+# c-nll1
+# not LL(1)
+
+start = s .
+s = e .
+s = i "=" e .
+e = e "+" t .
+e = e "-" t .
+e = t .
+t = f "*" t .
+t = f "/" t .
+t = f .
+f = i .
+f = n .
+f = "(" e ")" .
+
diff --git a/ipl/packs/tcll1/declacts.icn b/ipl/packs/tcll1/declacts.icn
new file mode 100644
index 0000000..835f200
--- /dev/null
+++ b/ipl/packs/tcll1/declacts.icn
@@ -0,0 +1,48 @@
+link readLL1
+record  LL1(sel,deflt,
+	terminals,actions,
+	fiducials,firstFiducials,
+	minLengRHS,
+	start,eoi)
+
+
+procedure main(L)
+local filename,baseFilename,flags,outfile
+local ll1
+flags := ""
+if L[1][1]=="-" then {
+	flags := L[1]
+	filename := L[2]
+} else {
+	filename:=L[1]
+}
+if /filename then
+	stop("usage: [iconx] tcll1 [flags] filename.ll1")
+
+baseFilename:=fileSuffix(filename)[1]
+if filename==(baseFilename||".inv") then
+	stop("will not write output over input")
+
+ll1:=readLL1(baseFilename||".ll1")
+
+if *ll1.actions > 0 then {
+	outfile:=open(baseFilename||".inv","r")
+	every write("invocable \"",!ll1.actions,"\"")
+}
+
+end
+
+#	From:     filename.icn in Icon Program Library
+#	Author:   Robert J. Alexander, 5 Dec. 89
+#	Modified: Thomas Christopher, 12 Oct. 94
+
+procedure fileSuffix(s,separator)
+   local i
+   /separator := "."
+   i := *s + 1
+   every i := find(separator,s)
+   return [s[1:i],s[(*s >= i) + 1:0] | &null]
+end
+
+
+
diff --git a/ipl/packs/tcll1/e.grm b/ipl/packs/tcll1/e.grm
new file mode 100644
index 0000000..2a200db
--- /dev/null
+++ b/ipl/packs/tcll1/e.grm
@@ -0,0 +1,5 @@
+start = e .
+e = t { ("+" | "-") t } .
+t = f  [ ("*" | "/") t ].
+f = i | "(" e ")" .
+
diff --git a/ipl/packs/tcll1/e_notll1.grm b/ipl/packs/tcll1/e_notll1.grm
new file mode 100644
index 0000000..f9657a2
--- /dev/null
+++ b/ipl/packs/tcll1/e_notll1.grm
@@ -0,0 +1,12 @@
+# errors--not LL(1)
+
+start = e .
+e = e "+" t .
+e = e "-" t .
+e = t .
+t = f "*" t .
+t = f "/" t .
+t = f .
+f = i .
+f = "(" e ")" .
+
diff --git a/ipl/packs/tcll1/ea_ll1.grm b/ipl/packs/tcll1/ea_ll1.grm
new file mode 100644
index 0000000..f39a25f
--- /dev/null
+++ b/ipl/packs/tcll1/ea_ll1.grm
@@ -0,0 +1,8 @@
+# ea-ll1.grm
+# action symbols
+# LL(1)
+start = e .
+e = t { "+" t A! | "-" t S!} .
+t = f  [ "*" t M! | "/" t D!].
+f = i N! | "(" e ")" P!.
+
diff --git a/ipl/packs/tcll1/ea_nll1.grm b/ipl/packs/tcll1/ea_nll1.grm
new file mode 100644
index 0000000..56f0535
--- /dev/null
+++ b/ipl/packs/tcll1/ea_nll1.grm
@@ -0,0 +1,14 @@
+# ea-nll1.grm
+# action symbols
+# not LL(1)
+
+start = e .
+e = e "+" t A!.
+e = e "-" t S!.
+e = t .
+t = f "*" t M!.
+t = f "/" t D!.
+t = f .
+f = i N!.
+f = "(" e ")" P!.
+
diff --git a/ipl/packs/tcll1/ebcdic.icn b/ipl/packs/tcll1/ebcdic.icn
new file mode 100644
index 0000000..1dde431
--- /dev/null
+++ b/ipl/packs/tcll1/ebcdic.icn
@@ -0,0 +1,157 @@
+############################################################################
+#
+#	File:     ebcdic.icn
+#
+#	Subject:  Procedures to convert between ASCII and EBCDIC
+#
+#	Author:   Alan Beale
+#
+#	Date:     March 31, 1990
+#
+############################################################################
+#
+#     These procedures assist in use of the ASCII and EBCDIC character sets,
+#     regardless of the native character set of the host:
+#
+#     Ascii128()    Returns a 128-byte string of ASCII characters in
+#                   numerical order.  Ascii128() should be used in
+#                   preference to &ascii for applications which might
+#                   run on an EBCDIC host.
+#
+#     Ascii256()    Returns a 256-byte string representing the 256-
+#                   character ASCII character set.  On an EBCDIC host,
+#                   the order of the second 128 characters is essentially
+#                   arbitrary.
+#
+#     Ebcdic()      Returns a 256-byte string of EBCDIC characters in
+#                   numerical order.
+#
+#     AsciiChar(i)  Returns the character whose ASCII representation is i.
+#
+#     AsciiOrd(c)   Returns the position of the character c in the ASCII
+#                   collating sequence.
+#
+#     EbcdicChar(i) Returns the character whose EBCDIC representation is i.
+#
+#     EbcdicOrd(c)  Returns the position of the character c in the EBCDIC
+#                   collating sequence.
+#
+#     MapEtoA(s)    Maps a string of EBCDIC characters to the equivalent
+#                   ASCII string, according to a plausible mapping.
+#
+#     MapAtoE(s)    Maps a string of ASCII characters to the equivalent
+#                   EBCDIC string, according to a plausible mapping.
+#
+#     Control(c)    Returns the "control character" associated with the
+#                   character c.  On an EBCDIC host, with $ representing
+#                   an EBCDIC character with no 7-bit ASCII equivalent,
+#                   Control("$") may not be identical to "\^$", as
+#                   translated by ICONT (and neither result is particularly
+#                   meaningful).
+#
+############################################################################
+#
+#   Notes:
+#
+#       There is no universally accepted mapping between ASCII and EBCDIC.
+#       See the SHARE Inc. publication "ASCII and EBCDIC Character Set and
+#       Code Issues in Systems Application Architecture" for more information
+#       than you would ever want to have on this subject.
+#
+#       The mapping of the first 128 characters defined below by Ascii128()
+#       is the most commonly accepted mapping, even though it probably
+#       is not exactly like the mapping used by your favorite PC to mainframe
+#       file transfer utility.  The mapping of the second 128 characters
+#       is quite arbitrary, except that where an alternate translation of
+#       ASCII char(n) is popular, this translation is assigned to
+#       Ascii256()[n+129].
+#
+#       The behavior of all functions in this package is controlled solely
+#       by the string literals in the _Eascii() procedure.  Therefore you
+#       may modify these strings to taste, and still obtain consistent
+#       results, provided that each character appears exactly once in the
+#       result of _Eascii().
+#
+#       Yes, it's really true that the EBCDIC "\n" (NL, char(16r15)) is not
+#       the same as "\l" (LF, char(16r25)).  How can that be?  "Don't blame
+#       me, man, I didn't do it."
+#
+############################################################################
+
+procedure _Eascii()
+    static EinAorder
+    initial
+        EinAorder :=
+#            NUL SOH STX ETX EOT ENQ ACK BEL BS  HT  NL  VT  FF  CR  SO  SI
+           "\x00\x01\x02\x03\x37\x2d\x2e\x2f\x16\x05\x15\x0b\x0c\x0d\x0e\x0f"||
+#            DLE DC1 DC2 DC3 DC4 NAK SYN ETB CAN EM  SUB ESC FS  GS  RS  US
+           "\x10\x11\x12\x13\x3c\x3d\x32\x26\x18\x19\x3f\x27\x1c\x1d\x1e\x1f"||
+#            sp  !   "   #   $   %   &   '   (   )   *   +   ,   -   .   /
+           "\x40\x5a\x7f\x7b\x5b\x6c\x50\x7d\x4d\x5d\x5c\x4e\x6b\x60\x4b\x61"||
+#            0   1   2   3   4   5   6   7   8   9   :   ;   <   =   >   ?
+           "\xf0\xf1\xf2\xf3\xf4\xf5\xf6\xf7\xf8\xf9\x7a\x5e\x4c\x7e\x6e\x6f"||
+#            @   A   B   C   D   E   F   G   H   I   J   K   L   M   N   O
+           "\x7c\xc1\xc2\xc3\xc4\xc5\xc6\xc7\xc8\xc9\xd1\xd2\xd3\xd4\xd5\xd6"||
+#            P   Q   R   S   T   U   V   W   X   Y   Z   $<  \   $>  ^   _
+           "\xd7\xd8\xd9\xe2\xe3\xe4\xe5\xe6\xe7\xe8\xe9\xad\xe0\xbd\x5f\x6d"||
+#            `   a   b   c   d   e   f   g   h   i   j   k   l   m   n   o
+           "\x79\x81\x82\x83\x84\x85\x86\x87\x88\x89\x91\x92\x93\x94\x95\x96"||
+#            p   q   r   s   t   u   v   w   x   y   z   $(  |   $)  ~   DEL
+           "\x97\x98\x99\xa2\xa3\xa4\xa5\xa6\xa7\xa8\xa9\xc0\x4f\xd0\xa1\x07"||
+           "\x04\x06\x08\x09\x0a\x14\x17\x1a\x1b\x20\x25\x21\x22\x23\x24\x28_
+            \x29\x2a\x2b\x2c\x30\x31\x33\x34\x35\x36\x38\x39\x3a\x3b\x3e\xff_
+            \x41\x42\x43\x44\x4a\x45\x46\x47\x48\x49\x51\x52\x53\x54\x55\x56_
+            \x57\x58\x59\x62\x63\x64\x65\x66\x67\x68\x69\x70\x71\x72\x73\x74_
+            \x75\x76\x77\x78\x80\x8a\x8c\x8d\x8e\x8f\x90\x9a\x9c\x9d\x9e\x9f_
+            \xa0\xaa\xab\xac\xae\xaf\xb0\xb1\xb2\xb3\xb4\xb5\xb6\xb7\xb8\xb9_
+            \xba\xbb\xbc\xbe\xbf\xca\xcb\xcc\xcd\xce\xcf\xda\xdb\xdc\xdd\xde_
+            \xdf\xe1\xea\xeb\xec\xed\xee\xef\xfa\xfb\xfc\x8b\x6a\x9b\xfd\xfe"
+    return EinAorder
+end
+
+procedure Ascii128()
+    if "\l" == "\n" then return string(&ascii)
+    return _Eascii()[1+:128]
+end
+
+procedure Ascii256()
+    if "\l" == "\n" then return string(&cset)
+    return _Eascii()
+end
+
+procedure Ebcdic()
+    if "\l" ~== "\n" then return &cset
+    return map(&cset, _Eascii(), &cset)
+end
+
+procedure AsciiChar(i)
+    if "\l" == "\n" then return char(i)
+    return _Eascii()[0 < i+1] | runerr(205,i)
+end
+
+procedure AsciiOrd(c)
+    if "\l" == "\n" then return ord(c)
+    return ord(MapEtoA(c))
+end
+
+procedure EbcdicChar(i)
+    if "\l" ~== "\n" then return char(i)
+    return map(char(i), _Eascii(), &cset)
+end
+
+procedure EbcdicOrd(c)
+    if "\l" ~== "\n" then return ord(c)
+    return ord(MapAtoE(c))
+end
+
+procedure MapEtoA(s)
+    return map(s, _Eascii(), &cset)
+end
+
+procedure MapAtoE(s)
+    return map(s, &cset, _Eascii())
+end
+
+procedure Control(c)
+    return AsciiChar(iand(AsciiOrd(c),16r1f))
+end
diff --git a/ipl/packs/tcll1/escape.icn b/ipl/packs/tcll1/escape.icn
new file mode 100644
index 0000000..b8f2197
--- /dev/null
+++ b/ipl/packs/tcll1/escape.icn
@@ -0,0 +1,93 @@
+############################################################################
+#
+#	File:     escape.icn
+#
+#	Subject:  Procedures to interpret Icon literal escapes
+#
+#	Authors:  William H. Mitchell; modified by Ralph E. Griswold and
+#	          Alan Beale
+#
+#	Date:     April 16, 1993
+#
+############################################################################
+#
+#  The procedure escape(s) produces a string in which Icon quoted
+#  literal escape conventions in s are replaced by the corresponding
+#  characters.  For example, escape("\\143\\141\\164") produces the
+#  string "cat".
+#
+############################################################################
+#
+#  Links: ebcdic
+#
+############################################################################
+
+link ebcdic
+
+procedure escape(s)
+   local ns, c
+
+   ns := ""
+   s ? {
+      while ns ||:= tab(upto('\\')) do {
+         move(1)
+         ns ||:= case map(c := move(1)) | fail of {	# trailing \ illegal
+            "b":  "\b"
+            "d":  "\d"
+            "e":  "\e"
+            "f":  "\f"
+            "l":  "\n"
+            "n":  "\n"
+            "r":  "\r"
+            "t":  "\t"
+            "v":  "\v"
+            "x":  hexcode()
+            "^":  ctrlcode()
+            !"01234567":  octcode()
+            default:  c				# takes care of ", ', and \
+            }
+         }
+      return ns || tab(0)
+      }
+
+end
+
+procedure hexcode()
+   local i, s
+
+   s := tab(many('0123456789ABCDEFabcdef')) | ""	# get hex digits
+
+   if (i := *s) > 2 then {		# if too many digits, back off
+      s := s[1:3]
+      move(*s - i)
+      }
+   
+   return char("16r" || s)
+
+end
+
+procedure octcode()
+   local i, s
+
+   move(-1)				# put back first octal digit
+   s := tab(many('01234567')) | ""	# get octal digits
+
+   i := *s
+   if (i := *s) > 3 then {		# back off if too large
+      s := s[1:4]
+      move(*s - i)
+      }
+   if s > 377 then {			# still could be too large
+      s := s[1:3]
+      move(-1)
+      }
+
+   return char("8r" || s)
+
+end
+
+procedure ctrlcode(s)
+
+   return Control(move(1))
+
+end
diff --git a/ipl/packs/tcll1/euler.grm b/ipl/packs/tcll1/euler.grm
new file mode 100644
index 0000000..4c679de
--- /dev/null
+++ b/ipl/packs/tcll1/euler.grm
@@ -0,0 +1,98 @@
+start : program .
+program = block ENDPROG!.
+vardecl = new id NEWDECL! .
+fordecl = formal id FORMALDECL! .
+labdecl = label id LABELDECL! .
+var = id VARID! {  "[" expr "]" SUBSCR! |  "." DOT! } .
+logval = true LOGVALTRUE! .
+logval = false LOGVALFALSE! .
+number = realN | integerN.
+reference = "@" var REFERENCE! .
+#	listhead -> "(" LISTHD1!
+#	listhead -> listhead expr "," LISTHD2!
+#	listN -> listhead ")" LISTN1!
+#	listN -> listhead expr ")" LISTN2!
+listN = "(" LISTHD1! ( ")" LISTN1! | expr listTl ) .
+listTl = ")" LISTN2! | "," LISTHD2! ( expr listTl | ")" LISTN1! ) .
+prochead = "'" PROCHD! {  fordecl ";" PROCFORDECL! } .
+procdef = prochead expr "'" PROCDEF! .
+primary = var ( listN CALL! | VALUE!) | primary1 .
+primary1 = logval LOADLOGVAL! | number LOADNUM! |
+	symbol LOADSYMB!| reference |
+	listN | tail primary UOP! | procdef |
+	undef LOADUNDEF! | "[" expr "]" PARENS! | in INPUT! |
+	isb var UOP! | isn var UOP! | isr var UOP! |
+	isl var UOP! | isli var UOP! | isy var UOP! |
+	isp var UOP! | isu var UOP! | abs primary UOP! |
+	length var UOP! | integer primary UOP! |
+	real primary UOP! | logical primary UOP! | list primary UOP! .
+factor = primary factortail.
+factortail = { "**" primary BOP! } .
+term = factor termtail.
+termtail = { "*" factor BOP! | "/" factor BOP! |
+		div factor BOP! | mod factor BOP! } .
+sum = ("+" term UPLUS! | "-" term NEG! | term) sumtail.
+sumtail = { "+" term BOP! | "-" term BOP! } .
+choice = sum choicetail.
+choicetail = { min sum BOP! | max sum BOP! } .
+
+relation = choice relationtail.
+relationtail = [ "=" choice BOP! | "~=" choice BOP!
+	| "<" choice BOP! | "<=" choice BOP!
+	| ">" choice BOP! | ">=" choice BOP! ] .
+
+negation =  "~" relation UOP! | relation .
+conj = negation conjtail.
+conjtail = [ and CONJHD! conj CONJ! ].
+disj = conj disjtail.
+disjtail = [ or DISJHD! disj DISJ! ] .
+catenatail = { "&" primary BOP! }.
+
+truepart = expr else TRUEPT! .
+ifclause = if expr then IFCLSE! .
+
+expr = var exprtail | expr1.
+exprtail = "<-" expr BOP! |
+	( listN CALL! | VALUE!)
+	factortail
+	termtail
+	sumtail
+	choicetail
+	relationtail
+	conjtail
+	disjtail
+	catenatail .
+
+expr1 = block .
+expr1 = ifclause truepart expr IFEXPR! .
+expr1 = goto primary UOP! .
+expr1 = out expr UOP! .
+expr1 =	primary1
+	factortail
+	termtail
+	sumtail
+	choicetail
+	relationtail
+	conjtail
+	disjtail
+	catenatail .
+
+expr1 =  ( "+" term UPLUS! | "-" term NEG! )
+	sumtail
+	choicetail
+	relationtail
+	conjtail
+	disjtail
+	catenatail .
+
+expr1 = "~" relation UOP! conjtail disjtail catenatail .
+
+
+stat = expr1
+	| id ( ":" LABDEF! stat LABSTMT!
+		| VARID! {  "[" expr "]" SUBSCR! |  "." DOT! }
+			exprtail ) .
+
+block = begin BEGIN!
+		{ vardecl ";" BLKHD! | labdecl ";" BLKHD!}
+		stat { ";" BLKBODY! stat } end BLK! .
diff --git a/ipl/packs/tcll1/fp.grm b/ipl/packs/tcll1/fp.grm
new file mode 100644
index 0000000..30fd748
--- /dev/null
+++ b/ipl/packs/tcll1/fp.grm
@@ -0,0 +1,34 @@
+start : fpProg.
+fpProg = { def | aplExp}.
+def = DEF ident "=" fnExp DEFN!.
+def = VAL ident "=" fnExp ":" obj VALU!.
+aplExp = fnExp ":" obj APPL!.
+fnExp	= fnComp [ "->" fnComp ";" fnExp COND!]
+	| while func fnExp WHILE!
+	.
+fnComp = func { "." func COMP!}.
+func	= ident FNID!
+	| ( "+" | "-" | "*"
+		| "=" | "~="
+		| "<" | ">" | ">=" "<=" ) FNID!
+	| selector SEL!
+	| bu func obj BU!
+	| "/" func INSERT!
+	| "@" func ALL!
+	| "(" fnExp ")" PARENS!
+	| "[" ( fnExpList | EMPTYCONS! ) "]" CONS!
+	| literal
+	.
+selector = signedInt.
+fnExpList = fnExp CONS1! { "," fnExp CONSNEXT! }.
+literal = "'" obj CONST!
+	| string STRCONST!
+	.
+obj	= atom
+	| "<" objList ">" OBJL!
+	.
+objList = obj OBJ1! { "," obj OBJLNEXT! } | EMPTYOBJL! .
+atom	= signedInt INTOBJ! | signedFloat FLOATOBJ!
+	| string STRINGOBJ! | ident OBJID!
+	.
+fiducials: ":" "->" ";" "]" ")" ">".
diff --git a/ipl/packs/tcll1/gramanal.icn b/ipl/packs/tcll1/gramanal.icn
new file mode 100644
index 0000000..c8349f1
--- /dev/null
+++ b/ipl/packs/tcll1/gramanal.icn
@@ -0,0 +1,573 @@
+# GRAMANAL.ICN
+#
+#  LL(1)/LL(k) parser generator in Icon
+#	written by Dr. Thomas W. Christopher
+#
+#	generally useful grammar analysis routines
+
+#	symbId is a string
+
+record Symbol(
+	name,	# symbId
+	kind,	# string in
+		# { "Nonterminal","Terminal","ActionSymbol"}
+	minLeng)# integer, length of shortest terminal string
+		# that can be derived from this nonterminal
+record Production(
+	lhs,	  # Symbol, left hand side
+	rhs,	  # [ Symbol, ... ], right hand side
+	minLeng)  # minimum length of terminal string derivable from
+		  # lhs using this production
+
+global symbol		#table:symbId->Symbol
+global first		#table:Symbol->set(Symbol)
+global last		#table:Symbol->set(Symbol)
+global follow		#table:Symbol->set(Symbol)
+global productions	#table:Symbol->[Production,...]
+global selectionSet	#table:Production->Set(Symbol)
+			# set of symbols that choose this production
+			# if lhs is atop the stack
+global nonterminals	#set(Symbol)
+global terminals	#set(Symbol)
+global actions		#set(Symbol)
+global startSymbol	#Symbol
+global eoiSymbol	#Symbol, end of input
+global errorFile	#file
+global errorCount	#integer
+global warningCount	#integer
+global tooLong		#integer, too long for a sentence
+global defaultStartName	#string, default name of start symbol
+
+#######################################################################
+#
+#	calls to create grammars
+#
+
+procedure initGrammar(out)
+symbol := table()
+first := table()
+last := table()
+follow := table()
+productions := table()
+selectionSet := table()
+nonterminals := set()
+terminals := set()
+actions := set()
+fiducials := set()
+startSymbol := &null
+eoiSymbol := Symbol("EOI","Terminal")
+symbol["EOI"] := eoiSymbol
+errorFile := \out | &output
+errorCount := warningCount := 0
+tooLong := 10000
+defaultStartName := "start"
+return
+end
+
+procedure error(e[])
+errorCount +:= 1
+writes(errorFile,"Error: ")
+every writes(!e)
+write()
+end
+
+procedure warning(e[])
+warningCount +:= 1
+writes(errorFile,"Warning: ")
+every writes(!e)
+write()
+end
+
+procedure declareProduction(lhs,rhs)
+#	lhs: symbId
+#	rhs: [symbId,...]
+local	n,	#Symbol, the left hand side
+	r,	#[Symbol,...], the right hand side
+	s	#symbId, name of rhs element
+if /symbol[lhs] then {
+	n := symbol[lhs] := Symbol(lhs,"Nonterminal")
+	insert(nonterminals,n)
+} else {
+	n := symbol[lhs]
+	/n.kind := "Nonterminal"
+	if n.kind ~==="Nonterminal" then {
+		error(lhs||" is both nonterminal and "||n.kind)
+		fail
+	}
+}
+r := []
+every s := !rhs do {
+	/symbol[s] := Symbol(s)
+	put(r,symbol[s])
+}
+/productions[n] := []
+put(productions[n],Production(n,r))
+return
+end
+
+procedure declareAction(s)
+local t
+/symbol[s] := Symbol(s)
+t := symbol[s]
+/t.kind := "ActionSymbol"
+if t.kind ~== "ActionSymbol" then {
+	error(t.kind||" "||s||" being declared an ActionSymbol")
+	fail
+}
+insert(actions,t)
+return
+end
+
+procedure declareStartSymbol(s)
+local n
+if \startSymbol then {
+	error(
+		"attempt to redeclare start symbol from "||
+		startSymbol.name||
+		" to "||
+		s)
+	fail
+}
+if n := \symbol[s] then {
+	/n.kind := "Nonterminal"
+	if n.kind ~== "Nonterminal" then {
+		error( "attempt to declare " ||
+			n.kind || " " ||
+			s || " as start symbol")
+		fail
+	}
+	startSymbol := n
+	return
+}
+startSymbol := Symbol(s,"Nonterminal")
+symbol[s] := startSymbol
+insert(nonterminals,startSymbol)
+/productions[startSymbol] := []
+return
+end
+
+procedure declareEOI(s)
+local eoi
+if eoiSymbol.name == s then return
+if \symbol[s] then {
+	error(
+		"attempt to redeclare "||
+		symbol[s].kind||" "||
+		s||" as EOI symbol")
+	fail
+}
+remove(symbol,eoiSymbol.name)
+eoiSymbol.name := s
+symbol[s] := eoiSymbol
+return
+end
+
+procedure finishDeclarations()
+local	s	#Symbol
+
+insert(terminals,eoiSymbol)
+
+#what if no start symbol specified? Create one.
+if /startSymbol then {
+	declareStartSymbol(defaultStartName)
+}
+
+every s := !symbol do
+	case s.kind of {
+	&null : {
+		s.kind := "Terminal"
+		insert(terminals,s)
+		s.minLeng := 1
+		}
+	"Terminal": {
+		s.minLeng := 1
+		insert(terminals,s)
+		}
+	"ActionSymbol": {
+		s.minLeng := 0
+		insert(actions,s)
+		}
+	"Nonterminal": {
+		s.minLeng := tooLong
+		insert(nonterminals,s)
+		}
+	}
+return
+end
+
+#######################################################################
+#
+#	local utility procedures
+#
+
+# succeed returning s if s is a null-deriving symbol
+# (only valid after execution of findMinLeng() )
+#
+procedure isNullDeriving(s)
+if s.minLeng <= 0 then return s else fail
+end
+
+# succeed returning symbol s only if s is the specified type of symbol
+procedure isNonterminal(s)
+return member(nonterminals,s)	#returning s
+end
+
+procedure isTerminal(s)
+return member(terminals,s)	#returning s
+end
+
+procedure isActionSymbol(s)
+return member(actions,s)	#returning s
+end
+
+#######################################################################
+#
+#debugging & output routines
+#
+
+procedure writeIndented(s,i,l,b)
+# write string s, indenting by i positions any overflow lines,
+# breaking after characters in set b (if practical), with overall
+# line length l
+#
+local j,k,r,h
+/l := 72	#default line length
+/i := 8		#default indent
+if /b := ' \t'	#default break set--white space
+	then l+:=1
+r := l - i	#remaining length after indent
+if r <= 1 then fail
+#cut off initial i chars (or all of string if it's short):
+s ?:= (h := tab(i+1 | 0) & tab(0))
+repeat {
+	# find a position j at which to cut the line:
+	j := -1
+	if *s>r then {s ? every k := upto(b) & k <= r & j := k}
+	write(h,s[1:j+1])
+	s := s[j+1:0]
+	if *s = 0 then break
+	h := repl(" ",i)
+}
+return
+end
+
+procedure symbolToString(s)
+static nonIdChars
+initial nonIdChars:=~(&letters++&digits++'_')
+return if upto(nonIdChars,s) then "\"" || s || "\"" else s
+end
+
+procedure productionToString(p)
+local s
+s := symbolToString(p.lhs.name) || " ="
+every s ||:= " " || symbolToString((!p.rhs).name)
+return s||"."
+end
+
+procedure showProductions()
+local p,S,n,i
+write()
+write("Productions:")
+write("start:",startSymbol.name,",  EOI:",eoiSymbol.name)
+S:=table()
+every n:=!nonterminals do S[n.name]:=n
+S:=sort(S,1)
+every i:=1 to *S do S[i]:=S[i][2]
+every p := !productions[!S] do {
+	writeIndented(productionToString(p))
+}
+return
+end
+
+procedure showSymbol(s)
+	write(s.name,": ",\s.kind|"Type undefined",
+		", minLeng=",\s.minLeng|"Undefined")
+return
+end
+
+procedure showSymbols()
+local s
+write()
+write("Symbols:")
+every s := !symbol do {
+	showSymbol(s)
+}
+
+return
+end
+
+procedure showSymbolSet(prefix,s)
+local t, i, L
+t:=set()
+every insert(t,(!s).name)
+L:=sort(t)
+prefix ||:= "{"
+every i := 1 to *L-1 do prefix ||:= symbolToString(L[i]) || ", "
+prefix ||:= symbolToString(L[-1])
+prefix ||:= "}"
+writeIndented(prefix)
+
+return
+end
+
+procedure showSelectionSets()
+local p,s,L
+write()
+write("selection sets:")
+L := sort(selectionSet,3)
+while p:=get(L) & s:=get(L) do {
+	showSymbolSet("selection[ "||productionToString(p)||" ] = ",s)
+}
+return
+end
+
+procedure showSymbolSets(setName,s)
+local n,st,L
+L := sort(s,3)
+write()
+write(setName," sets:")
+while n := get(L) & st := get(L) do {
+	showSymbolSet(n.name||"=",st)
+}
+return
+end
+
+procedure showFirstSets()
+showSymbolSets("first",first)
+return
+end
+
+procedure showLastSets()
+showSymbolSets("last",last)
+return
+end
+
+procedure showFollowSets()
+showSymbolSets("follow",follow)
+return
+end
+
+#######################################################################
+#
+#	Grammar analysis
+#
+
+# compute the min lengths of terminal strings that can be derived
+# from nonterminals and starting from particular productions.
+#
+procedure findMinLeng()
+local n, ns, p, s, changes, leng
+
+every ns:=!symbol do case ns.kind of {
+	"Nonterminal":	ns.minLeng := tooLong
+	"Terminal":	ns.minLeng := 1
+	"ActionSymbol":	ns.minLeng := 0
+	}
+every p := !!productions do p.minLeng := tooLong
+### showSymbols() ####
+changes := 1
+while \changes do {
+	changes := &null
+	every n := !nonterminals  do {
+		every p := !productions[n] do {
+			leng := 0
+			every s := !p.rhs do {
+				leng +:= s.minLeng
+			}
+			p.minLeng := leng
+			### showSymbol(n) ###
+			if n.minLeng > leng then {
+			 changes := 1
+			 n.minLeng := leng
+			}
+		}
+	}
+}
+return
+end
+
+procedure checkMinLeng()
+ local n
+ every n := !nonterminals & n.minLeng >= tooLong do {
+	error(n.name," does not appear to derive a terminal string")
+ }
+ return
+end
+
+#
+# compute transitive closure of a relation
+#
+procedure transitiveClosure(s)
+local n,r,i,k
+
+every	k := key(s) &
+	i := key(s) &
+	member(s[i],k)
+  do {
+	s[i] ++:= s[k]
+}
+return
+end
+
+#
+#	generate exposed symbols on rhs or in string
+#	  "exposed" means preceded (Left) or followed (Right)
+#	  by nullable nonterminal or action symbols
+#	includes all symbols, nonterminal, terminal and action
+#
+procedure exposedLeft(p)
+ local s
+ case type(p) of {
+"Symbol":	p:=[p]
+"Production":	p:=p.rhs
+ }
+ every  s := !p  do {
+ 	suspend s
+	if not isNullDeriving(s) then fail
+ }
+ fail
+end
+
+procedure exposedRight(p)
+ local s
+ case type(p) of {
+"Symbol":	p:=[p]
+"Production":	p:=p.rhs
+ }
+ every s := p[*p to 1 by -1]  do {
+ 	suspend s
+	if not isNullDeriving(s) then fail
+ }
+ fail
+end
+
+#
+#	Compute Accessible Sets
+#
+
+procedure buildInitialAccessibleSets()
+local p, r, s
+
+s:=table()
+every s[!nonterminals] := set()
+every p := !!productions do {
+	every r := !p.rhs do {
+		insert(s[p.lhs],r)
+	}
+}
+return s
+end
+
+procedure findAccessibleSets()
+local s
+s := buildInitialAccessibleSets()
+transitiveClosure(s)
+return s
+end
+
+procedure findAccessibleSymbols()
+ local st,a
+ a := findAccessibleSets()
+ st := a[startSymbol]
+ insert(st,startSymbol)
+ insert(st,eoiSymbol)
+ return st
+end
+
+procedure checkAccessibility()
+ local s,st
+ st := findAccessibleSymbols()
+ every s := !(nonterminals|terminals|actions) do {
+	if not member(st,s) then
+	   error(s.name,
+	   " cannot appear in a sentential form")
+ }
+ return
+end
+
+#
+#	Compute First Sets
+#
+
+procedure initFirstSets()
+local p, r
+
+first := table()
+every first[!nonterminals] := set()
+
+every p := !!productions do {
+	every r := exposedLeft(p) do {
+		insert(first[p.lhs],r)
+	}
+}
+return
+end
+
+procedure findFirstSets()
+initFirstSets()
+transitiveClosure(first)
+return
+end
+
+#
+#	Compute last sets
+#
+procedure initLastSets()
+local p, r
+
+last:=table()
+every last[!nonterminals] := set()
+
+every p := !!productions do {
+	every r := exposedRight(p) do {
+		insert(last[p.lhs],r)
+	}
+}
+return
+end
+
+procedure findLastSets()
+initLastSets()
+transitiveClosure(last)
+return
+end
+
+procedure checkLnRRecursive()
+ local n
+ every n:= !nonterminals do {
+	if member(first[n],n) & member(last[n],n) then {
+		error(n.name," is both left and right recursive,",
+			" the grammar is ambiguous")
+	}
+ }
+ return
+end
+
+procedure findFollowSets()
+local n, p, rhs, x, y, i, j
+
+follow := table()
+
+every n := !nonterminals do follow[n] := set()
+
+every p := !productions[!nonterminals] &
+	rhs := p.rhs & *rhs>1
+  do {
+    every x := rhs[i:=1 to *rhs-1] & isNonterminal(x) do {
+      every y := rhs[j:=i+1 to *rhs] do {
+	every
+	  insert(
+	  	follow[x|isNonterminal(!last[x])],
+	  	isTerminal(y|!\first[y])
+	  )
+	if not isNullDeriving(y) then break #back to "every x" loop
+      }
+    }
+}
+every insert(
+	follow[isNonterminal(startSymbol|!last[startSymbol])],
+	eoiSymbol
+      )
+return
+end
+
diff --git a/ipl/packs/tcll1/if_ll1.grm b/ipl/packs/tcll1/if_ll1.grm
new file mode 100644
index 0000000..50a0679
--- /dev/null
+++ b/ipl/packs/tcll1/if_ll1.grm
@@ -0,0 +1,6 @@
+# if-ll1
+# still not really LL(1), but as close as we can get
+start = statement .
+statement = if e then statement else_option
+	| i "=" e.
+else_option = [ else statement ].
diff --git a/ipl/packs/tcll1/if_nll1.grm b/ipl/packs/tcll1/if_nll1.grm
new file mode 100644
index 0000000..0e74101
--- /dev/null
+++ b/ipl/packs/tcll1/if_nll1.grm
@@ -0,0 +1,8 @@
+# if-nll1
+# not LL(1)
+start = statement .
+statement = if e then statement
+	| if e then statement else statement
+	| i "=" e.
+
+
diff --git a/ipl/packs/tcll1/ll1.icn b/ipl/packs/tcll1/ll1.icn
new file mode 100644
index 0000000..65f97e9
--- /dev/null
+++ b/ipl/packs/tcll1/ll1.icn
@@ -0,0 +1,279 @@
+
+link gramanal
+link xcode
+
+global outFile
+
+global fiducials	#set(Symbol)
+global selectionSet	#table:Production->Set(Symbol)
+			# set of symbols that choose this production
+			# if lhs is atop the stack
+
+#
+#
+#
+procedure analyzeGrammar()
+
+findMinLeng()
+checkMinLeng()
+checkAccessibility()
+findFirstSets()
+findLastSets()
+checkLnRRecursive()
+findFollowSets()
+
+end
+
+procedure declareFiducial(s)
+local t
+/symbol[s] := Symbol(s)
+t := symbol[s]
+/t.kind := "Terminal"
+if t.kind ~== "Terminal" then {
+	error(t.kind," ",s," being declared a fiducial")
+	fail
+}
+insert(fiducials,t)
+return
+end
+
+procedure findSelectionSets()
+local p,r,s,t
+every p:=!!productions do {
+	s:= set()
+	every r := exposedLeft(p) do {
+		if isNonterminal(r) then {
+			s ++:= first[r]
+		} else if isTerminal(r) then {
+			insert(s,r)
+		}
+	}
+	if p.minLeng=0 then s ++:= follow[p.lhs]
+	every t := !s & not isTerminal(t) do delete(s,t)
+	selectionSet[p] := s
+}
+return
+end
+
+procedure ll1(outFileName)
+local t,g
+
+analyzeGrammar()
+findSelectionSets()
+
+testLL1()
+
+if errorCount>0 then fail
+
+outFile := open(outFileName,"w") |
+	{error( "unable to open output file ",outFileName)
+	return}
+
+t:=genLL1()
+#g:=encode(t)
+#write(outFile,g)
+xencode(t,outFile)
+#
+close(outFile)
+return
+
+end
+
+procedure testLL1()
+
+local n, plist, p1, p2, px, py, m, i, s
+
+#check for left recursion
+
+every n := !nonterminals do
+  if member(first[n],n) then
+    error(n.name," is left recursive, the grammar is not LL(1)")
+
+#check for overlapping selection sets
+
+every n := !nonterminals do {
+	plist := productions[n]
+	m := *plist
+	every p1 := plist[i:=1 to m-1] &
+		p2 := plist[i+1 to m] do {
+	   if p1.minLeng = p2.minLeng = 0 then {
+		error("productions\n1.\t",
+			productionToString(p1),"\n2.\t",
+			productionToString(p2),
+			"\nboth derive the empty string" )
+	   } else if *(s:=selectionSet[p1]**selectionSet[p2]) > 0 then {
+		if (p1.minLeng = 0) | (p2.minLeng = 0) then {
+		   px:=p1; py:=p2; if px.minLeng=0 then px:=:py
+		   warning("overlapping selection sets for\n\t",
+			productionToString(px),
+			"\nand empty-deriving production\n\t",
+			productionToString(py) )
+		} else {
+		   error("overlapping selection sets for\n1.\t",
+			productionToString(p1),"\n2.\t",
+			productionToString(p2) )
+		}
+		showSymbolSet("  overlap: ",s)
+	   }
+	}
+}
+return
+end
+
+procedure genLL1()
+local	mapSymbol,
+	rhsList,
+	mapRHS,
+	emptyRHS,
+	sel,
+	deflt,
+	firstFiduc,
+	fiducList,
+	actionList,
+	termList,
+	minLengRHS
+local s,p,r,L,n,m,mr,ml,ms,nullrhs,t,i
+# build encapsulated symbols, [ name ], so that all references
+#  to the symbol can share the same string
+mapSymbol := table()
+every s := !symbol do {
+	mapSymbol[s] := [s.name]
+}
+# map productions into right hand side lists with encapsulated symbols
+emptyRHS:=list()
+mapRHS := table()
+every p := !!productions do {
+	L:=list()
+	every s:= !p.rhs do put(L,mapSymbol[s])
+	mapRHS[p] := if *L = 0 then emptyRHS else L
+}
+#make a list of all right hand sides
+# the list will be used after input to remove the symbols
+# from their encapsulating lists
+rhsList:=[]
+every L:=!mapRHS do put(rhsList,L)
+
+#create selection and default tables
+sel:=table()
+deflt:=table()
+every n:=!nonterminals do {
+
+ # Build a list of productions for the nonterminal sorted by
+ # cardinality of selection set. Reserve a production with an
+ # empty-string-deriving RHS for special treatment. Put the
+ # productions into the sel table, but reserve the empty-deriving
+ # RHS or, if none, then the RHS with the largest selection set to
+ # be the default. If there is an overlap in selection sets between
+ # a non-empty-deriving and the empty-deriving RHS, then this will
+ # give precedence to the non-empty-deriving RHS, as is required to
+ # solve the "dangling else problem."
+
+  nullrhs:=&null
+  t:=table()	#map productions into cardinality of selection set
+  every p:=!productions[n] do
+	if p.minLeng=0
+		then nullrhs:=p
+		else t[p] := *selectionSet[p]
+  L:=sort(t,2)
+  put(L,[\nullrhs,*selectionSet[nullrhs]])
+  if *L = 1  then {
+  	deflt[mapSymbol[n]] := mapRHS[L[1][1]]
+  } else {
+	/sel[mapSymbol[n]] := table()
+	# if there is an empty-deriving RHS then put all other
+	# RHS's into sel table--the empty-deriving one will be
+	# the default. Or, if the largest selection set
+	# for any RHS is small enough, then put all RHS's into
+	# selection table. Otherwise, reserve the RHS with the
+	# largest selection set to be the default.
+	m := if /nullrhs & L[*L][2] < 5 then *L else *L-1
+  	every i := 1 to m &
+		p := L[i][1] &
+		mr := mapRHS[p] &
+		ml := mapSymbol[p.lhs] &
+		ms := mapSymbol[!selectionSet[p]] do {
+	  sel[ml][ms] := mr
+	}
+	# If not included already, handle the last.
+	if m~=*L then deflt[mapSymbol[n]]:=mapRHS[L[*L][1]]
+  }
+}
+
+termList := list()
+every s:=!terminals do put(termList,mapSymbol[s])
+
+actionList := list()
+every put(actionList,mapSymbol[!actions])
+
+fiducList := list()
+insert(fiducials,eoiSymbol)
+every put(fiducList,mapSymbol[!fiducials])
+
+firstFiduc := table()
+every n:=!nonterminals & *(s:=first[n]**fiducials)>0 do {
+	firstFiduc[mapSymbol[n]] := list()
+	every put(firstFiduc[mapSymbol[n]],
+		mapSymbol[!s])
+}
+
+minLengRHS := table()
+every n := !nonterminals do {
+	p := productions[n][1]
+	every r := !productions[n] &
+		p.minLeng > r.minLeng do p:=r
+	minLengRHS[mapSymbol[n]] := mapRHS[p]
+}
+
+return	[
+	rhsList,
+	sel,
+	deflt,
+	termList,
+	actionList,
+	fiducList,
+	firstFiduc,
+	minLengRHS,
+	mapSymbol[startSymbol],
+	mapSymbol[eoiSymbol]
+	]
+end
+
+
+#######################################################################
+#
+#	printing the grammar
+#
+procedure printGrammar()
+local n,p,st,s
+write("start symbol:\t",startSymbol.name)
+write("EOI symbol:\t",eoiSymbol.name)
+write()
+showSymbolSet("terminal symbols: ",terminals)
+
+write()
+showSymbolSet("fiducial symbols: ",fiducials)
+
+write()
+showSymbolSet("action symbols: ",actions)
+
+write()
+write("nonterminal symbols:")
+st := set()
+every insert(st,(!nonterminals).name)
+st := sort(st)
+every n := !st do {
+	s := symbol[n]
+	write(" ",n,":")
+	showSymbolSet("  first set: ",first[s])
+	showSymbolSet("  follow set: ",follow[s])
+	write()
+}
+
+write("productions:")
+every p := !productions[symbol[!st]] do {
+	writeIndented(productionToString(p))
+	showSymbolSet("   : ",selectionSet[p])
+}
+return
+end
+
diff --git a/ipl/packs/tcll1/ls_ll1.grm b/ipl/packs/tcll1/ls_ll1.grm
new file mode 100644
index 0000000..2c4fef8
--- /dev/null
+++ b/ipl/packs/tcll1/ls_ll1.grm
@@ -0,0 +1,23 @@
+# ls-ll1
+# LL(1)
+start = labeled_statement .
+
+#labeled_statement = label statement .
+#label = i ":" label | .
+#statement = i "=" e.
+
+#labeled_statement = i ":" label statement .
+#labeled_statement = statement .
+#label = i ":" label | .
+#statement = i "=" e.
+
+#labeled_statement = i ":" label statement .
+#labeled_statement = i "=" e .
+#label = i ":" label | .
+#statement = i "=" e.
+
+labeled_statement = i labeled_statement_tail .
+labeled_statement_tail = "=" e .
+labeled_statement_tail = ":" labeled_statement .
+
+
diff --git a/ipl/packs/tcll1/ls_nll1.grm b/ipl/packs/tcll1/ls_nll1.grm
new file mode 100644
index 0000000..e8ad77f
--- /dev/null
+++ b/ipl/packs/tcll1/ls_nll1.grm
@@ -0,0 +1,8 @@
+# ls-nll1
+# not LL(1)
+start = labeled_statement .
+labeled_statement = label statement .
+label = { i ":" }.
+statement = i "=" e.
+
+
diff --git a/ipl/packs/tcll1/parsell1.icn b/ipl/packs/tcll1/parsell1.icn
new file mode 100644
index 0000000..665118d
--- /dev/null
+++ b/ipl/packs/tcll1/parsell1.icn
@@ -0,0 +1,71 @@
+# parse using tables produced by tcLL1
+#	(written by Dr. Thomas W. Christopher)
+#
+record Token(type,body,line,column)
+
+link readll1
+
+procedure parseLL1(ll1)
+local predictionStack
+local x,y,z,top,cur,errLine,errColumn
+ predictionStack:=[ll1.start,ll1.eoi]
+ cur := &null
+repeat {
+	if not(top := pop(predictionStack)) then return
+	while member(ll1.actions,top) do {
+		outAction(top)
+		if not(top := pop(predictionStack)) then return
+	}
+	/cur := scan()
+	if top == cur.type then {
+		outToken(cur)
+		cur:=&null
+		if top == ll1.eoi then break
+	} else if x:=\ll1.sel[top] & y:=\x[cur.type] then {
+		every z:=y[*y to 1 by -1] do push(predictionStack,z)
+	} else if y:=\ll1.deflt[top] then {
+		every z:=y[*y to 1 by -1] do push(predictionStack,z)
+	} else {
+		#panic mode error recovery
+		reportParseError(cur)
+		errLine:=cur.line
+		errColumn:=cur.column
+		push(predictionStack,top)
+		repeat {
+		   while not member(ll1.fiducials,cur.type) &
+		   		cur.type~==ll1.eoi do {
+			 #write("scanning past ",cur.body)
+		   	cur := scan()
+		   }
+		   if x:=!predictionStack &
+		   	(x==cur.type) |
+			   member(\ll1.firstFiducials[x], cur.type)
+		   then break
+		   else cur := scan()
+		}
+		repeat {
+		   top := pop(predictionStack) |
+		   	stop("system error in panic mode")
+		    #write("pruning stack ",top)
+		   if top==cur.type then {
+			push(predictionStack,top)
+			break
+		   }
+		   if member(ll1.actions,top) then {
+		   	outAction(top)
+		   } else if member(ll1.terminals,top) then {
+		   	outError(top,errLine,errColumn)
+		   } else if member(\ll1.firstFiducials[top],cur.type)
+		   		then {
+		   	push(predictionStack,top)
+			break
+		   } else {
+		   	predictionStack := ll1.minLengRHS[top] |||
+						predictionStack
+		   }
+		}
+	}
+}
+return
+end
+
diff --git a/ipl/packs/tcll1/readll1.icn b/ipl/packs/tcll1/readll1.icn
new file mode 100644
index 0000000..b1f42b0
--- /dev/null
+++ b/ipl/packs/tcll1/readll1.icn
@@ -0,0 +1,140 @@
+# Read in parse tables produced by TCLL1
+#	(written by Thomas W. Christopher)
+#
+link xcode #xcode is provided by the Icon Programming Library
+invocable all
+
+record  LL1(sel,deflt,
+	terminals,actions,
+	fiducials,firstFiducials,
+	minLengRHS,
+	start,eoi)
+
+procedure readLL1(filename)
+local g,s,f
+f:=open(filename) | fail
+s:=xdecode(f) | fail
+g:=unpackLL1(s)
+close(f)
+return g
+end
+
+procedure unpackLL1(h)
+local	startSymbol,
+	eoiSymbol,
+	rhsList,
+	selIn,
+	defltIn,
+	termList,
+	actionList,
+	fiducList,
+	firstFiduc,
+	minLengRhs
+
+local r,i,n,t,s,
+ actionSet,terminalSet,
+ defaultTable,selTable,
+ fiducialSet,firstFiducials,
+ minLengRHS
+
+# the following must be in the same order they were listed in
+# return statement of genLL1() in module "ll1.icn". With the
+# exception of rhsList, they are in the same order as in record
+# LL1.
+
+rhsList := get(h)
+selIn := get(h)
+defltIn := get(h)
+termList:= get(h)
+actionList:=get(h)
+fiducList:=get(h)
+firstFiduc:=get(h)
+minLengRhs:=get(h)
+startSymbol := get(h)[1]
+eoiSymbol := get(h)[1]
+
+every r:= !rhsList & i := 1 to *r do r[i]:=r[i][1]
+
+actionSet:=set()
+every insert(actionSet,(!actionList)[1])
+terminalSet:=set()
+every insert(terminalSet,(!termList)[1])
+defaultTable:=table()
+every n:=key(defltIn) do defaultTable[n[1]]:=defltIn[n]
+selTable:=table()
+every n:=key(selIn) do {
+	/selTable[n[1]] := t := table()
+	every s:= key(selIn[n]) do {
+		t[s[1]] := selIn[n][s]
+	}
+}
+fiducialSet:=set()
+every insert(fiducialSet,(!fiducList)[1])
+firstFiducials:=table()
+every n:=key(firstFiduc) &
+	s:=firstFiduc[n] do {
+		firstFiducials[n[1]]:=set()
+		every insert(firstFiducials[n[1]],(!s)[1])
+}
+minLengRHS:=table()
+every n:=key(minLengRhs) do
+	minLengRHS[n[1]]:=minLengRhs[n]
+
+return LL1(selTable,defaultTable,
+	terminalSet,actionSet,
+	fiducialSet,firstFiducials,
+	minLengRHS,
+	startSymbol,eoiSymbol)
+
+end
+
+procedure showStructure(h, indent)
+local t,i
+/indent:=""
+i := indent||" "
+case type(h) of {
+"string": write(indent,"\"",h,"\"")
+"list":	{write(indent,"[")
+	every showStructure(!h,i)
+	write(indent,"]")
+	}
+"table":{write(indent,"table")
+	t := sort(h,3)
+	while showStructure(get(t),i) do {
+		write(indent,"->")
+		showStructure(get(t),i)
+		write(indent,"---")
+	  }
+	write(indent,"end table")
+	}
+"set": {write(indent,"{")
+	every showStructure(!h,i)
+	write(indent,"}")
+	}
+}
+return
+end
+
+procedure showLL1(g)
+write("start symbol")
+showStructure( g.start)
+write("eoi symbol")
+showStructure( g.eoi)
+write("action set")
+showStructure( g.actions)
+write("terminal set")
+showStructure( g.terminals)
+write("default table")
+showStructure( g.deflt)
+write("selection table")
+showStructure( g.sel)
+write("fiducial set")
+showStructure( g.fiducials)
+write("first fiducials")
+showStructure( g.firstFiducials)
+write("minimum length RHSs")
+showStructure( g.minLengRHS)
+return
+end
+
+
diff --git a/ipl/packs/tcll1/rptperr.icn b/ipl/packs/tcll1/rptperr.icn
new file mode 100644
index 0000000..316388b
--- /dev/null
+++ b/ipl/packs/tcll1/rptperr.icn
@@ -0,0 +1,12 @@
+#
+# this is a minimal version of the error reporting procedure
+# needed by the parser
+#
+
+procedure reportParseError(t)
+write(&errout,"error: unexpected input ",t.body,
+	" at line ",t.line," column ",t.column)
+return
+end
+
+
diff --git a/ipl/packs/tcll1/scangram.icn b/ipl/packs/tcll1/scangram.icn
new file mode 100644
index 0000000..540d758
--- /dev/null
+++ b/ipl/packs/tcll1/scangram.icn
@@ -0,0 +1,85 @@
+# Scanner for the input language used by TCLL1,
+# an LL(1) parser generator).
+#	(written by Dr. Thomas W. Christopher)
+#
+global inputFile
+global inputLine,inputLineNumber,inputColumn,eoiToken
+global tokenTypes
+
+procedure initScanner(filename)
+inputFile := open(filename,"r") | fail
+return
+end
+
+procedure scan()
+local t,c,b
+static whiteSpace,initIdChars,idChars
+initial {
+	/inputFile:=&input
+	inputLineNumber:=0
+	inputColumn:=1
+	inputLine:=""
+	eoiToken:=&null
+	whiteSpace:=&ascii[1:34] #control ++ blank
+	initIdChars := &letters ++ '_'
+	idChars := &letters ++ &digits ++ '_'
+	tokenTypes := table()
+	t := [	".","DOT",
+		":","COLON",
+		"=","EQ",
+		"|","BAR",
+		"(","LPAR",
+		")","RPAR",
+		"[","LBRACK",
+		"]","RBRACK",
+		"{","LBRACE",
+		"}","RBRACE",
+		"!","BANG"]
+	while tokenTypes[get(t)] := get(t)
+}
+if \eoiToken then return eoiToken
+repeat inputLine ? {
+	tab(inputColumn)
+	tab(many(whiteSpace))
+	c := &pos
+	if any(initIdChars) then {
+		t := Token("ID",tab(many(idChars)),
+			inputLineNumber,c)
+		inputColumn := &pos
+		return t
+	} else
+	if b := tab(any('.:=()[]{}|!')) then {
+		inputColumn := &pos
+		return Token(tokenTypes[b],b,inputLineNumber,c)
+	} else
+	if ="#" | pos(0) then {
+		inputColumn := 1
+		inputLineNumber +:= 1
+		if not (inputLine := read(inputFile)) then {
+			eoiToken := Token("EOI","EOI",
+					inputLineNumber,1)
+			return eoiToken
+		}
+	} else
+	if ="\"" then {
+		if t := Token("ID",tab(find("\"")),
+				inputLineNumber,c) then {
+			move(1)
+		} else {
+			write("unterminated quote at ",
+				inputLineNumber," ",c)
+			t:=Token("ID",tab(many(~whiteSpace)),
+				inputLineNumber,c)
+		}
+		inputColumn := &pos
+		return t
+	} else
+		{
+		write("unexpected character: ",move(1),
+			" at ",inputLineNumber," ",c)
+		inputColumn := &pos
+	}
+}
+end
+
+
diff --git a/ipl/packs/tcll1/semgram.icn b/ipl/packs/tcll1/semgram.icn
new file mode 100644
index 0000000..e07c21b
--- /dev/null
+++ b/ipl/packs/tcll1/semgram.icn
@@ -0,0 +1,126 @@
+# Semantics routines called while parsing the input
+# grammar to TCLL1.
+#	(written by Thomas W. Christopher)
+
+procedure FirstAlt()
+push(semanticsStack,[pop(semanticsStack)])
+return
+end
+
+procedure NextAlt()
+local r
+r:=pop(semanticsStack)
+pop(semanticsStack)	# |
+put(semanticsStack[1],r)
+return
+end
+
+procedure DeclAction()
+pop(semanticsStack)	# !
+declareAction(semanticsStack[1].body)
+return
+end
+
+#procedure edit_rhs(rhs)
+#local s
+#r:=[]
+#every s:=!rhs do put(r,s.body)
+#return
+#end
+
+global lhsymb
+
+procedure DeclProduction()
+local i,a,r
+pop(semanticsStack)	# .
+a:=pop(semanticsStack)
+pop(semanticsStack)	# =
+i:=pop(semanticsStack)
+every r := !a do declareProduction(i,r)
+return
+end
+
+
+procedure Group()
+local a,lp,lhs,r
+pop(semanticsStack)
+a:=pop(semanticsStack)
+lp:=pop(semanticsStack)
+
+lhs:=lhsymb||"_"||lp.line||"_"||lp.column
+every r := !a do declareProduction(lhs,r)
+push(semanticsStack,Token("ID",lhs,lp.line,lp.column))
+return
+end
+
+procedure Option()
+local a,lp,lhs,r
+pop(semanticsStack)
+a:=pop(semanticsStack)
+lp:=pop(semanticsStack)
+
+lhs:=lhsymb||"_"||lp.line||"_"||lp.column
+every r := !a do declareProduction(lhs,r)
+declareProduction(lhs,[])
+push(semanticsStack,Token("ID",lhs,lp.line,lp.column))
+return
+end
+
+procedure Repeat()
+local a,lp,lhs,r
+pop(semanticsStack)
+a:=pop(semanticsStack)
+lp:=pop(semanticsStack)
+
+lhs:=lhsymb||"_"||lp.line||"_"||lp.column
+every r := !a do declareProduction(lhs,r|||[lhs])
+declareProduction(lhs,[])
+push(semanticsStack,Token("ID",lhs,lp.line,lp.column))
+return
+end
+
+procedure StartRHS()
+push(semanticsStack,[])
+return
+end
+
+procedure ExtendRHS()
+local s
+s:=pop(semanticsStack).body
+put(semanticsStack[1],s)
+return
+end
+
+procedure DeclLHS()
+lhsymb:=pop(semanticsStack).body
+push(semanticsStack,lhsymb)
+return
+end
+
+procedure DeclSymbols()
+local l,r,s
+pop(semanticsStack)	# .
+r := pop(semanticsStack)
+pop(semanticsStack)	# :
+l := pop(semanticsStack)
+map(l,&ucase,&lcase) ?
+	if ="s" then {
+		if not (="tart"&pos(0)) then
+			warning(l,"--\"start\" assumed")
+		declareStartSymbol(r[1])
+	} else if ="e" then {
+		if not (="oi"&pos(0)) then
+			warning(l,"--\"EOI\" assumed")
+		declareEOI(r[1])
+	} else if ="f" then {
+		if not (="iducial") then
+			warning(l,"--\"fiducials\" assumed")
+		every declareFiducial(!r)
+	} else if ="a" then {
+		if not (="ction") then
+			warning(l,"--\"actions\" assumed")
+		every declareAction(!r)
+	} else error(l,"--unknown declaration")
+return
+end
+
diff --git a/ipl/packs/tcll1/semout.icn b/ipl/packs/tcll1/semout.icn
new file mode 100644
index 0000000..759e7da
--- /dev/null
+++ b/ipl/packs/tcll1/semout.icn
@@ -0,0 +1,25 @@
+# Routines to test grammars passed through the TCLL1
+# parser generator.
+# Link this with parseLL1 and it will write out the tokens
+# and action symbols recognized by the parser.
+#	(written by Dr. Thomas W. Christopher)
+#
+procedure outToken(tok)
+write(tok.type," ",tok.line," ",tok.column," ",tok.body)
+return
+end
+
+procedure outAction(a)
+write(a)
+return
+end
+
+procedure outError(t)
+write("ERROR: ",t)
+return
+end
+
+procedure initSemantics()
+return
+end
+
diff --git a/ipl/packs/tcll1/semstk.icn b/ipl/packs/tcll1/semstk.icn
new file mode 100644
index 0000000..1197d8f
--- /dev/null
+++ b/ipl/packs/tcll1/semstk.icn
@@ -0,0 +1,56 @@
+# Semantics stack manipulation routines to be called by
+# parseLL1(...), the parser for the TCLL1 LL(1) parser
+# generator.
+#	(written by Thomas W. Christopher)
+#
+
+invocable all
+global semanticsStack
+
+record ErrorToken(type,body,line,column)
+
+procedure initSemanticsStack()
+ semanticsStack:=[]
+return
+end
+
+
+procedure outToken(tok)
+ push(semanticsStack,tok)
+return
+end
+
+procedure outAction(a)
+a()
+return
+end
+
+procedure outError(t,l,c)
+push(semanticsStack,ErrorToken(t,t,\l|0,\c|0))
+return
+end
+
+procedure isError(v)
+ return type(v)=="ErrorToken"
+end
+
+procedure popSem(n)
+local V
+V:=[]
+every 1 to n do push(V,pop(semanticsStack))
+return V
+end
+
+procedure pushSem(s)
+push(semanticsStack,s)
+return
+end
+
+procedure anyError(V)
+local v
+if v:=!V & type(v)=="ErrorToken" then {
+	return v
+}
+fail
+end
+
diff --git a/ipl/packs/tcll1/tcll1.grm b/ipl/packs/tcll1/tcll1.grm
new file mode 100644
index 0000000..6ee31a1
--- /dev/null
+++ b/ipl/packs/tcll1/tcll1.grm
@@ -0,0 +1,14 @@
+# Grammar for tlcll1 parser generator
+start = grammar.
+grammar =  { declaration }.
+declaration = ID DeclLHS! ( COLON rhs DOT DeclSymbols! | 
+		   EQ alts DOT DeclProduction!).
+rhs = StartRHS! {elem ExtendRHS!}.
+alts = rhs FirstAlt! {BAR rhs NextAlt!}.
+elem =	ID bangOpt |
+	LPAR alts RPAR Group! | 
+	LBRACE alts RBRACE Repeat! |
+	LBRACK alts RBRACK Option! .
+bangOpt = [BANG DeclAction!].
+fiducials : DOT.
+
diff --git a/ipl/packs/tcll1/tcll1.icn b/ipl/packs/tcll1/tcll1.icn
new file mode 100644
index 0000000..9541383
--- /dev/null
+++ b/ipl/packs/tcll1/tcll1.icn
@@ -0,0 +1,92 @@
+# TCLL1 -- an LL(1) parser generator
+# Main program.
+#	(written by Dr. Thomas W. Christopher)
+#
+
+link readll1,parsell1,scangram,semgram,semstk,gramanal,ll1
+
+procedure main(L)
+local filename,baseFilename,flags,filenameParts,gf
+
+flags := ""
+if L[1][1]=="-" then {
+	flags := L[1]
+	filename := L[2]
+} else {
+	filename:=L[1]
+}
+if /filename then
+	stop("usage: [iconx] tcll1 [flags] filename.grm")
+
+filenameParts:=fileSuffix(filename)
+baseFilename:=filenameParts[1]
+if filename==(baseFilename||".ll1") then
+	stop("would write output over input")
+initScanner( filename |
+	(/filenameParts[2] & baseFilename||".grm")) |
+    stop("unable to open input: ",filename)
+
+initGrammar()
+initSemanticsStack()
+
+gf:=findFileOnPATH("tcll1.ll1") |
+	stop("unable to find parser's grammar file: tcll1.ll1")
+parseLL1(readLL1(gf)) |
+	stop("unable to read parser's grammar file: tcll1.ll1")
+
+finishDeclarations()
+ll1(baseFilename||".ll1")
+if find("p",flags) then printGrammar()
+write(errorCount," error",(errorCount~=1&"s")|"",
+ " and ",warningCount," warning",(warningCount~=1&"s")|"")
+
+end
+
+#	From:     filename.icn in Icon Program Library
+#	Author:   Robert J. Alexander, 5 Dec. 89
+#	Modified: Thomas Christopher, 12 Oct. 94
+
+procedure fileSuffix(s,separator)
+   local i
+   /separator := "."
+   i := *s + 1
+   every i := find(separator,s)
+   return [s[1:i],s[(*s >= i) + 1:0] | &null]
+end
+
+procedure findFileOnPATH(s) #adapted from DOPEN.ICN
+   local file, paths, path, filename
+
+   if file := open(s) then {			# look in current directory
+   	close(file)
+   	return s
+   }
+
+   paths := getenv("PATH") | fail
+
+   paths := map(paths,"\\;","/ ")		#convert DOS to UNIX-style
+   s := "/" || s				# platform-specific
+
+   paths ? {
+      while path := tab(upto(' ') | 0) do {
+         if file := open(filename:=path || s) then {
+            close(file)
+            return filename
+         }
+         tab(many(' ')) | break
+      }
+   }
+
+   fail
+end
+
+#
+# Error reporting required by parseLL1():
+#
+procedure reportParseError(t)
+error("unexpected input ",t.body,
+	" at line ",t.line," column ",t.column)
+return
+end
+
+
diff --git a/ipl/packs/tcll1/tcll1.ll1 b/ipl/packs/tcll1/tcll1.ll1
new file mode 100644
index 0000000..6f348c7
--- /dev/null
+++ b/ipl/packs/tcll1/tcll1.ll1
@@ -0,0 +1,297 @@
+L
+N10
+L
+N20
+L
+N4
+L
+N1
+"COLON"
+L
+7
+"rhs"
+L
+7
+"DOT"
+L
+7
+"DeclSymbols"
+L
+N3
+10
+L
+7
+"FirstAlt"
+L
+7
+"alts_7_22"
+L
+N2
+L
+7
+"BANG"
+L
+7
+"DeclAction"
+L
+22
+L
+7
+"declaration"
+L
+7
+"grammar_3_12"
+L
+22
+L
+7
+"StartRHS"
+L
+7
+"rhs_6_17"
+L
+16
+L
+7
+"ID"
+L
+7
+"DeclLHS"
+L
+7
+"declaration_4_27"
+L
+5
+L
+7
+"LPAR"
+L
+7
+"alts"
+L
+7
+"RPAR"
+L
+7
+"Group"
+L
+7
+L
+7
+"bangOpt_12_11"
+L
+7
+31
+L
+N0
+L
+7
+L
+7
+"grammar"
+59
+L
+5
+L
+7
+"LBRACK"
+48
+L
+7
+"RBRACK"
+L
+7
+"Option"
+L
+5
+L
+7
+"EQ"
+48
+12
+L
+7
+"DeclProduction"
+L
+22
+39
+L
+7
+"bangOpt"
+59
+59
+L
+5
+L
+7
+"BAR"
+10
+L
+7
+"NextAlt"
+20
+L
+16
+L
+7
+"elem"
+L
+7
+"ExtendRHS"
+36
+L
+5
+L
+7
+"LBRACE"
+48
+L
+7
+"RBRACE"
+L
+7
+"Repeat"
+T
+N6
+
+43
+T
+22
+
+71
+70
+8
+6
+20
+T
+7
+
+79
+78
+84
+T
+5
+
+46
+45
+64
+63
+39
+75
+89
+88
+31
+T
+7
+
+39
+28
+36
+T
+5
+
+46
+83
+64
+83
+39
+83
+89
+83
+55
+T
+7
+
+24
+23
+T
+1
+
+20
+59
+61
+57
+29
+38
+L
+7
+"start"
+60
+10
+33
+48
+17
+31
+59
+36
+59
+55
+59
+76
+54
+L
+N13
+71
+8
+79
+91
+24
+39
+46
+12
+66
+L
+7
+"EOI"
+89
+64
+50
+L
+N11
+68
+26
+14
+18
+93
+86
+41
+52
+73
+34
+81
+L
+22
+12
+108
+T
+58
+
+T
+N12
+
+43
+6
+20
+59
+61
+57
+84
+75
+29
+38
+104
+60
+10
+33
+48
+17
+31
+59
+36
+59
+55
+59
+76
+54
+104
+108
diff --git a/ipl/packs/tcll1/tcll1.pdf b/ipl/packs/tcll1/tcll1.pdf
new file mode 100644
index 0000000..bfaeb51
--- /dev/null
+++ b/ipl/packs/tcll1/tcll1.pdf
diff --git a/ipl/packs/tcll1/xcode.icn b/ipl/packs/tcll1/xcode.icn
new file mode 100644
index 0000000..c8def5f
--- /dev/null
+++ b/ipl/packs/tcll1/xcode.icn
@@ -0,0 +1,421 @@
+############################################################################
+#
+#	File:     xcode.icn
+#
+#	Subject:  Procedures to save and restore Icon data
+#
+#	Author:   Bob Alexander
+#
+#	Date:     January 1, 1996
+#
+############################################################################
+#
+#	Contributor:  Ralph E. Griswold
+#
+############################################################################
+#
+#  Description
+#  -----------
+#
+#     These procedures provide a way of storing Icon values in files
+#  and retrieving them.  The procedure xencode(x,f) stores x in file f
+#  such that it can be converted back to x by xdecode(f).  These
+#  procedures handle several kinds of values, including structures of
+#  arbitrary complexity and even loops.  The following sequence will
+#  output x and recreate it as y:
+#
+#	f := open("xstore","w")
+#	xencode(x,f)
+#	close(f)
+#	f := open("xstore")
+#	y := xdecode(f)
+#	close(f)
+#
+#  For "scalar" types -- null, integer, real, cset, and string, the
+#  above sequence will result in the relationship
+#
+#	x === y
+#
+#     For structured types -- list, set, table, and record types --
+#  y is, for course, not identical to x, but it has the same "shape" and
+#  its elements bear the same relation to the original as if they were
+#  encoded and decoded individually.
+#
+#     Files, co-expressions, and windows cannot generally be restored in any
+#  way that makes much sense.  These objects are restored as empty lists so
+#  that (1) they will be unique objects and (2) will likely generate
+#  run-time errors if they are (probably erroneously) used in
+#  computation.  However, the special files &input, &output, and &errout are
+#  restored.
+#
+#     Not much can be done with functions and procedures, except to preserve
+#  type and identification.
+#
+#     The encoding of strings and csets handles all characters in a way
+#  that it is safe to write the encoding to a file and read it back.
+#
+#     xdecode() fails if given a file that is not in xcode format or it
+#  the encoded file contains a record for which there is no declaration
+#  in the program in which the decoding is done.  Of course, if a record
+#  is declared differently in the encoding and decoding programs, the
+#  decoding may be bogus.
+#
+#     xencoden() and xdecoden() perform the same operations, except
+#  xencoden() and xdecoden() take the name of a file, not a file.
+#
+############################################################################
+#
+#  Complete calling sequences
+#  --------------------------
+#
+#	xencode(x, f, p) # returns f
+#
+#	where
+#
+#		x is the object to encode
+#
+#		f is the file to write (default &output)
+#
+#		p is a procedure that writes a line on f using the
+#		  same interface as write() (the first parameter is
+#		  always a the value passed as "file") (default: write)
+#
+#
+#	xencode(f, p) # returns the restored object
+#
+#	where
+#
+#		f is the file to read (default &input)
+#
+#		p is a procedure that reads a line from f using the
+#		  same interface as read() (the parameter is
+#		  always a the value passed as "file") (default: read)
+#
+#
+#  The "p" parameter is not normally used for storage in text files, but
+#  it provides the flexibility to store the data in other ways, such as
+#  a string in memory.  If "p" is provided, then "f" can be any
+#  arbitrary data object -- it need not be a file.
+#
+#  For example, to "write" x to an Icon string:
+#
+#	record StringFile(s)
+#
+#	procedure main()
+#	   ...
+#	   encodeString := xencode(x,StringFile(""),WriteString).s
+#	   ...
+#	end
+#
+#	procedure WriteString(f,s[])
+#	  every f.s ||:= !s
+#	  f.s ||:= "\n"
+#	  return
+#	end
+#
+############################################################################
+#
+#  Notes on the encoding
+#  ---------------------
+#
+#     Values are encoded as a sequence of one or more lines written to
+#  a plain text file.  The first or only line of a value begins with a
+#  single character that unambiguously indicates its type.  The
+#  remainder of the line, for some types, contains additional value
+#  information.  Then, for some types, additional lines follow
+#  consisting of additional object encodings that further specify the
+#  object.  The null value is a special case consisting of an empty
+#  line.
+#
+#     Each object other than &null is assigned an integer tag as it is
+#  encoded.  The tag is not, however, written to the output file.  On
+#  input, tags are assigned in the same order as objects are decoded, so
+#  each restored object is associated with the same integer tag as it
+#  was when being written.  In encoding, any recurrence of an object is
+#  represented by the original object's tag.  Tag references are
+#  represented as integers, and are easily recognized since no object's
+#  representation begins with a digit.
+#
+#     Where a structure contains elements, the encodings of the
+#  elements follow the structure's specification on following lines.
+#  Note that the form of the encoding contains the information needed to
+#  separate consecutive elements.
+#
+#     Here are some examples of values and their encodings:
+#
+#       x                     encode(x)
+#  -------------------------------------------------------
+#
+#       1                     N1
+#       2.0                   N2.0
+#       &null                 
+#       "\377"                "\377"
+#       '\376\377'            '\376\377'
+#       procedure main        p
+#                             "main"
+#       co-expression #1 (0)  C
+#       []                    L
+#                             N0
+#       set()                 "S"
+#                             N0
+#       table("a")            T
+#                             N0
+#                             "a"
+#       ["hi","there"]        L
+#                             N2
+#                             "hi"
+#                             "there"
+#
+#  A loop is illustrated by
+#
+#       L2 := []
+#       put(L2,L2)
+#
+#  for which
+#
+#       x                     encode(x)
+#  -------------------------------------------------------
+#
+#       L2                    L
+#                             N1
+#                             2
+#
+#  The "2" on the third line is a tag referring to the list L2.  The tag
+#  ordering specifies that an object is tagged *after* its describing
+#  objects, thus the list L2 has the tag 2 (the integer 1 has tag 1).
+#
+#     Of course, you don't have to know all this to use xencode and
+#  xdecode.
+#
+############################################################################
+#
+#  Links:  escape
+#
+############################################################################
+#
+#  See also:  object.icn, codeobj.icn
+#
+############################################################################
+
+invocable all
+
+link escape
+
+record xcode_rec(file,ioProc,done,nextTag)
+
+procedure xencode(x,file,writeProc)	#: write structure to file
+
+   /file := &output
+   return xencode_1(
+      xcode_rec(
+	 file,
+	 (\writeProc | write) \ 1,
+	 table(),
+	 0),
+      x)
+end
+
+procedure xencode_1(data,x)
+   local tp,wr,f,im
+   wr := data.ioProc
+   f := data.file
+   #
+   #  Special case for &null.
+   #
+   if /x then {
+      wr(f)
+      return f
+      }
+   #
+   #  If this object has already been output, just write its tag.
+   #
+   if tp := \data.done[\x] then {
+      wr(f,tp)
+      return f
+      }
+   #
+   #  Check to see if it's a "distinguished" that is represented by
+   #  a keyword (special files and csets).  If so, just use the keyword
+   #  in the output.
+   #
+   im := image(x)
+   if match("integer(", im) then im := string(x)
+   else if match("&",im) then {
+      wr(f,im)
+      data.done[x] := data.nextTag +:= 1
+      return f
+      }
+   #
+   #  Determine the type and handle accordingly.
+   #
+   tp := case type(x) of {
+     "cset" | "string": ""
+     "file" | "window": "f"
+     "integer" | "real": "N"
+     "co-expression": "C"
+     "procedure": "p"
+     "external": "E"
+     "list": "L"
+     "set": "S"
+     "table": "T"
+     default: "R"
+   }
+   case tp of {
+      #
+      #  String, cset, or numeric outputs its string followed by its
+      #  image.
+      #
+      "" | "N": wr(f,tp,im)
+      #
+      #  Procedure writes "p" followed (on subsequent line) by its name
+      #  as a string object.
+      #
+      "p": {
+	 wr(f,tp)
+	 im ? {
+	    while tab(find(" ") + 1)
+	    xencode_1(data,tab(0))
+	    }
+	 }
+      #
+      #  Co-expression, file, or external just outputs its letter.
+      #
+      !"CEf": wr(f,tp)
+      #
+      #  Structured type outputs its letter followed (on subsequent
+      #  lines) by additional data.  A record writes its type as a
+      #  string object; other type writes its size as an integer object.
+      #  Structure elements follow on subsequent lines (alternating keys
+      #  and values for tables).
+      #
+      default: {
+	 wr(f,tp)
+	 case tp of {
+	    !"LST": {
+	       im ? {
+		  tab(find("(") + 1)
+		  xencode_1(data,integer(tab(-1)))
+		  }
+	       if tp == "T" then xencode_1(data,x[[]])
+	       }
+	    default: xencode_1(data,type(x))
+	    }
+	 #
+	 #  Create the tag.  It's important that the tag is assigned
+	 #  *after* other other objects that describe this object (e.g.
+	 #  the length of a list) are output (and tagged), but *before*
+	 #  the structure elements; otherwise decoding would be
+	 #  difficult.
+	 #
+	 data.done[x] := data.nextTag +:= 1
+	 #
+	 #  Output the elements of the structure.
+	 #
+	 every xencode_1(data,
+	       !case tp of {"S": sort(x); "T": sort(x,3); default: x})
+	 }
+      }
+   #
+   #  Tag the object if it's not already tagged.
+   #
+   /data.done[x] := data.nextTag +:= 1
+   return f
+end
+
+procedure xdecode(file,readProc)	#: read structure from file
+
+   /file := &input
+
+   return xdecode_1(
+      xcode_rec(
+	 file,
+	 (\readProc | read) \ 1,
+	 []))
+end
+
+#  This procedure fails if it encounters bad data
+
+procedure xdecode_1(data)
+   local x,tp,sz, i
+   data.ioProc(data.file) ? {
+      if any(&digits) then {
+	 #
+	 #  It's a tag -- return its value from the object table.
+	 #
+	 return data.done[tab(0)]
+	 }
+      if tp := move(1) then {
+	 x := case tp of {
+	    "N": numeric(tab(0))
+	    "\"": escape(tab(-1))
+	    "'": cset(escape(tab(-1)))
+	    "p": proc(xdecode_1(data)) | fail
+	    "L": list(xdecode_1(data)) | fail
+	    "S": {sz := xdecode_1(data) | fail; set()}
+	    "T": {sz := xdecode_1(data) | fail; table(xdecode_1(data)) | fail}
+	    "R": proc(xdecode_1(data))() | fail
+	    "&": case tab(0) of {
+	       #
+	       #  Special csets.
+	       #
+	       "cset":		&cset
+	       "ascii":		&ascii
+	       "digits":	&digits
+	       "letters":	&letters
+	       "lcase":		&lcase
+	       "ucase":		&ucase
+	       #
+	       #  Special files.
+	       #
+	       "input":		&input
+	       "output":	&output
+	       "errout":	&errout
+	       default:		[] # so it won't crash if new keywords arise
+	       }
+            "f" | "C": []	# unique object for things that can't
+				# be restored.
+	    default: fail
+	    }
+	 put(data.done,x)
+	 case tp of {
+	    !"LR": every i := 1 to *x do
+              x[i] := xdecode_1(data) | fail
+	    "T": every 1 to sz do
+               insert(x,xdecode_1(data),xdecode_1(data)) | fail
+	    "S": every 1 to sz do
+               insert(x,xdecode_1(data)) | fail
+	    }
+	 return x
+	 }
+      else return
+      }
+
+end
+
+procedure xencoden(x, name, opt)
+   local output
+
+   /opt := "w"
+
+   output := open(name, opt) | stop("*** xencoden(): cannot open ", name)
+   xencode(x, output)
+   close(output)
+
+   return
+
+end
+
+procedure xdecoden(name)
+   local input, x
+
+   input := open(name) | stop("*** xdecoden(): cannot open ", name)
+   if x := xdecode(input) then {
+      close(input)
+      return x
+      }
+   else {
+      close(input)
+      fail
+      }
+
+end