Initial upstream version 9.4.3upstream/9.4.3

1 files changed, 48 insertions, 0 deletions

diff --git a/ipl/procs/hetero.icn b/ipl/procs/hetero.icn
new file mode 100644
index 0000000..85a6609
--- /dev/null
+++ b/ipl/procs/hetero.icn
@@ -0,0 +1,48 @@
+############################################################################
+#
+#	File:     hetero.icn
+#
+#	Subject:  Procedures to test structure typing
+#
+#	Author:   Ralph E. Griswold
+#
+#	Date:     April 19, 1996
+#
+############################################################################
+#
+#   This file is in the public domain.
+#
+############################################################################
+#
+#
+#
+############################################################################
+
+procedure stypes(X, ref)		#: types of structure elements
+   local op, types, t, k
+
+   op := proc("!", 1)
+   t := type(X)
+   op := if (t == "table") & (ref === 1) then "key" 
+
+   if (t == "table") & (ref === 2) then {
+      types := set()
+      every k := key(X) do
+         insert(types, type(k) || ":" ||  type(X[k]))
+      return sort(types)
+      }
+
+   else if t == ("list" | "record" | "table" | "set") then {
+      types := set()
+      every insert(types, type(op(X)))
+      return sort(types)
+      }
+   else stop("*** invalid type to stypes()")
+
+end
+
+procedure homogeneous(X, ref)
+
+   if *stypes(X, ref) = 1 then return else fail
+
+end