X-Git-Url: https://jxself.org/git/?p=pdp10-muddle.git;a=blobdiff_plain;f=mim%2Fdevelopment%2Fmim%2Fvaxc%2Fchannel-type.mud;fp=mim%2Fdevelopment%2Fmim%2Fvaxc%2Fchannel-type.mud;h=8dc0e6ef3ea7474b448c6c1db488e250d58edd65;hp=0000000000000000000000000000000000000000;hb=d73ace3f3292e320b461b8fcd2e9f5dc5d9684d7;hpb=d530283ea60fb0ddcc28e9c5bd072456afe06e07

diff --git a/mim/development/mim/vaxc/channel-type.mud b/mim/development/mim/vaxc/channel-type.mud
new file mode 100644
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>
+