Machine-Independent MDL for TOPS-20 and VAX.

[pdp10-muddle.git] / mim / development / mim / vaxc / channel-type.mud

diff --git a/mim/development/mim/vaxc/channel-type.mud b/mim/development/mim/vaxc/channel-type.mud
new file mode 100644 (file)
index 0000000..8dc0e6e
--- /dev/null
+++ b/mim/development/mim/vaxc/channel-type.mud
@@ -0,0 +1,84 @@
+<PACKAGE "CHANNEL-TYPE">
+
+<ENTRY CT-QUERY>
+
+<USE "NEWSTRUC">
+
+<NEWSTRUC SDTABLE VECTOR
+         SD-NAME ATOM
+         SD-INHERIT <OR FALSE ATOM <LIST [REST ATOM]>>
+         SD-OPER <LIST [REST ATOM <OR MSUBR ATOM FALSE>]>>
+
+<GDECL (CHANNEL-TYPES) <LIST [REST ATOM SDTABLE]>>
+
+<DEFINE NEW-CHANNEL-TYPE (SNAME INHERIT
+                        "TUPLE" OPS
+                        "AUX" ST TL SD LOSER)
+       #DECL ((SNAME) ATOM (INHERIT) <OR ATOM FALSE <LIST [REST ATOM]>>
+              (OPS) <TUPLE [REST ATOM <OR MSUBR ATOM FALSE>]> (ST) LIST
+              (TL) <OR LIST FALSE> (LOSER) ATOM)
+       <COND (<NOT <GASSIGNED? CHANNEL-TYPES>>
+              <SETG CHANNEL-TYPES <SET ST ()>>)
+             (<SET ST ,CHANNEL-TYPES>)>
+       <COND (<OR <NOT <SET TL <MEMQ .SNAME .ST>>>
+                  <AND <ASSIGNED? REDEFINE> .REDEFINE>
+                  <ERROR .SNAME
+                         ALREADY-DEFINED-ERRET-NON-FALSE-TO-REDEFINE!-ERRORS
+                         NEW-CHANNEL-TYPE>>
+              <SET SD <CHTYPE [.SNAME .INHERIT <LIST !.OPS>] SDTABLE>>
+              <COND (.TL <2 .TL .SD>)
+                    (<SETG CHANNEL-TYPES (.SNAME .SD !.ST)>)>
+              .SNAME)>>
+
+<DEFINE SET-TYPE-FCN (STYPE OPER FCN "AUX" SD OL) 
+       #DECL ((STYPE) ATOM (OPER) ATOM (FCN) <OR ATOM MSUBR FALSE>
+              (OL) <OR LIST FALSE> (SD) <OR FALSE SDTABLE>)
+       <COND (<SET SD <GET-CHANNEL-TYPE .STYPE>>
+              <COND (<SET OL <MEMQ .OPER <SD-OPER .SD>>> <2 .OL .FCN>)
+                    (<SD-OPER .SD (.OPER .FCN !<SD-OPER .SD>)>)>
+              .OPER)>>
+
+<DEFINE SET-TYPE-INHERIT (STYPE INHERIT "AUX" SD LOSER) 
+   #DECL ((STYPE) ATOM (INHERIT) <OR ATOM FALSE <LIST [REST ATOM]>>
+         (SD) <OR SDTABLE FALSE> (LOSER) ATOM)
+   <COND
+    (<SET SD <GET-CHANNEL-TYPE .STYPE>>
+     <SD-INHERIT .SD .INHERIT>)>>
+
+<DEFINE GET-CHANNEL-TYPE (STYPE "AUX" TL)
+  #DECL ((STYPE) ATOM (TL) <OR FALSE LIST>)
+  <COND (<AND <GASSIGNED? CHANNEL-TYPES> <SET TL <MEMQ .STYPE ,CHANNEL-TYPES>>>
+        <2 .TL>)
+       (#FALSE ("NO SUCH CHANNEL TYPE"))>>
+
+<DEFINE CT-QUERY (STYPE OPER "OPTIONAL" (DEPTH 0) "AUX" SL SD TL INH RES) 
+   #DECL ((STYPE OPER) ATOM (TL SL) <OR LIST FALSE> (DEPTH) FIX
+         (SD) <OR SDTABLE FALSE>
+         (INH) <OR FALSE ATOM LIST>)
+   <COND
+    (<SET SD <GET-CHANNEL-TYPE .STYPE>>
+     <SET RES
+      <COND
+       (<SET TL <MEMQ .OPER <SD-OPER .SD>>> <2 .TL>)
+       (<SET TL <MEMQ * <SD-OPER .SD>>> <2 .TL>)
+       (<SET INH <SD-INHERIT .SD>>
+        <COND (<G? <SET DEPTH <+ .DEPTH 1>> 5>
+              <ERROR INHERITANCE-DEPTH-TOO-GREAT!-ERRORS
+                     .STYPE .OPER CT-QUERY>)>
+        <COND (<TYPE? .INH ATOM> <CT-QUERY .INH .OPER .DEPTH>)
+             (T
+              <MAPF <>
+                    <FUNCTION (ATM "AUX" FOO) 
+                            #DECL ((ATM) ATOM)
+                            <COND (<SET FOO
+                                        <CT-QUERY .ATM .OPER .DEPTH>>
+                                   <MAPLEAVE .FOO>)>>
+                    .INH>)>)
+      (T
+       #FALSE ("CHANNEL TYPE DOESN'T DEFINE OPERATION"))>>
+     <COND (<TYPE? .RES MSUBR> <2 .RES>)
+          (T .RES)>)
+    (#FALSE ("NO SUCH CHANNEL TYPE"))>>
+
+<ENDPACKAGE>
+