--- /dev/null
+
+<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]>>
+
+#WORD *21142502170*
+ <GFCN \1aNEW-CHANNEL-TYPE ("VALUE" <OR ATOM FALSE> ATOM <OR ATOM FALSE <LIST [REST ATOM]>> "TUPLE" <TUPLE [REST ATOM <OR MSUBR ATOM FALSE>]>) SNAME4 INHERIT5>
+ <MAKTUP OPS6 TEMP14 ST7:LIST TL8 TEMP30 = OPS6>
+ <INTGO>
+ <NTHR 'CHANNEL-TYPES 1 = TEMP14 (RECORD-TYPE ATOM) (BRANCH-FALSE + TAG13)>
+ <TYPE? TEMP14 <TYPE-CODE FALSE> + TAG13>
+ <NTHR TEMP14 1 = TEMP14 (RECORD-TYPE GBIND)>
+ <TYPE? TEMP14 <TYPE-CODE UNBOUND> - PHRASE12>
+ <DEAD TEMP14>
+TAG13
+ <SET ST7 () (TYPE LIST)>
+ <SETG 'CHANNEL-TYPES ST7>
+ <JUMP + COND11>
+PHRASE12
+ <GVAL 'CHANNEL-TYPES = ST7>
+COND11
+ <SET TL8 ST7>
+ <EMPL? TL8 + TAG18>
+ <LOOP (SNAME4 VALUE) (TL8 VALUE)>
+TAG20
+ <NTHL TL8 1 = TEMP14>
+ <TYPE? TEMP14 <TYPE-CODE ATOM> - TAG21>
+ <VEQUAL? TEMP14 SNAME4 + TAG19>
+ <DEAD TEMP14>
+TAG21
+ <RESTL TL8 1 = TL8 (TYPE LIST)>
+ <EMPL? TL8 - TAG20>
+TAG18
+ <SET TL8 %<> (TYPE FALSE)>
+TAG19
+ <VEQUAL? TL8 0 + BOOL17>
+ <GEN-ASSIGNED? 'REDEFINE - BOOL23>
+ <GEN-LVAL 'REDEFINE = TEMP14>
+ <TYPE? TEMP14 <TYPE-CODE FALSE> - BOOL17>
+ <DEAD TEMP14>
+BOOL23
+ <FRAME '\1aERROR>
+ <PUSH SNAME4>
+ <PUSH 'ALREADY-DEFINED-ERRET-NON-FALSE-TO-REDEFINE!-ERRORS>
+ <PUSH 'NEW-CHANNEL-TYPE>
+ <CALL '\1aERROR 3 = TEMP14>
+ <TYPE? TEMP14 <TYPE-CODE FALSE> + PHRASE16>
+BOOL17
+ <PUSH SNAME4>
+ <PUSH INHERIT5>
+ <DEAD INHERIT5>
+ <SET TEMP30 0 (TYPE FIX)>
+ <SET TEMP14 OPS6>
+ <DEAD OPS6>
+ <LOOP (TEMP14 VALUE LENGTH) (TEMP30 VALUE)>
+TAG31
+ <INTGO>
+ <EMPUV? TEMP14 + TAG29>
+ <NTHUV TEMP14 1 = STACK>
+ <RESTUV TEMP14 1 = TEMP14 (TYPE VECTOR)>
+ <ADD TEMP30 1 = TEMP30 (TYPE FIX)>
+ <JUMP + TAG31>
+TAG29
+ <LIST TEMP30 = STACK (TYPE LIST)>
+ <DEAD TEMP30>
+ <UBLOCK <TYPE-CODE VECTOR> 3 = TEMP30>
+ <CHTYPE TEMP30 <TYPE-CODE SDTABLE> = OPS6>
+ <DEAD TEMP30>
+ <TYPE? TL8 <TYPE-CODE FALSE> + PHRASE34>
+ <RESTL TL8 1 = TEMP30 (TYPE LIST)>
+ <DEAD TL8>
+ <PUTL TEMP30 1 OPS6>
+ <DEAD TEMP30 OPS6>
+ <JUMP + COND33>
+PHRASE34
+ <CONS OPS6 ST7 = TEMP30>
+ <DEAD OPS6 ST7>
+ <CONS SNAME4 TEMP30 = TEMP30>
+ <SETG 'CHANNEL-TYPES TEMP30>
+ <DEAD TEMP30>
+COND33
+ <SET TEMP14 SNAME4>
+ <DEAD SNAME4>
+PHRASE16
+ <RETURN TEMP14>
+ <DEAD TEMP14>
+ <END \1aNEW-CHANNEL-TYPE>
+
+#WORD *227604520*
+ <GFCN \1aADD-CHANNEL-OPS ("VALUE" ATOM ATOM "TUPLE" <TUPLE [REST ATOM <OR MSUBR ATOM FALSE>]>) STYPE4>
+ <MAKTUP OPS5:TUPLE TEMP9 = OPS5>
+ <INTGO>
+ <FRAME '\1aGET-CHANNEL-TYPE>
+ <PUSH STYPE4>
+ <CALL '\1aGET-CHANNEL-TYPE 1 = TEMP9>
+ <TYPE? TEMP9 <TYPE-CODE FALSE> + PHRASE7>
+ <DEAD TEMP9>
+ <SET TEMP9 OPS5>
+ <LOOP>
+AGAIN12
+ <INTGO>
+ <EMPUV? TEMP9 + EXIT10>
+ <FRAME '\1aSET-TYPE-FCN>
+ <PUSH STYPE4>
+ <NTHUV OPS5 1 = STACK (TYPE ATOM)>
+ <NTHUV OPS5 2 = STACK>
+ <CALL '\1aSET-TYPE-FCN 3>
+ <RESTUV TEMP9 2 = TEMP9 (TYPE VECTOR)>
+ <CHTYPE TEMP9 <TYPE-CODE VECTOR> = TEMP9>
+ <JUMP + AGAIN12>
+EXIT10
+ <RETURN STYPE4>
+ <DEAD STYPE4>
+PHRASE7
+ <FRAME '\1aNEW-CHANNEL-TYPE>
+ <PUSH STYPE4>
+ <PUSH %<>>
+ <SET TEMP9 2 (TYPE FIX)>
+ <LOOP (OPS5 VALUE LENGTH) (TEMP9 VALUE)>
+TAG20
+ <INTGO>
+ <EMPUV? OPS5 + TAG17>
+ <NTHUV OPS5 1 = STACK>
+ <RESTUV OPS5 1 = OPS5 (TYPE VECTOR)>
+ <ADD TEMP9 1 = TEMP9 (TYPE FIX)>
+ <JUMP + TAG20>
+TAG17
+ <CALL '\1aNEW-CHANNEL-TYPE TEMP9>
+ <DEAD TEMP9>
+ <RETURN STYPE4>
+ <DEAD STYPE4>
+ <END \1aADD-CHANNEL-OPS>
+
+#WORD *14340316375*
+ <GFCN \1aSET-TYPE-FCN ("VALUE" <OR ATOM FALSE> ATOM ATOM <OR ATOM MSUBR FALSE>) STYPE4 OPER5 FCN6>
+ <TEMP SD7 TEMP11 TEMP19>
+ <INTGO>
+ <FRAME '\1aGET-CHANNEL-TYPE>
+ <PUSH STYPE4>
+ <DEAD STYPE4>
+ <CALL '\1aGET-CHANNEL-TYPE 1 = SD7>
+ <SET TEMP11 SD7>
+ <TYPE? TEMP11 <TYPE-CODE FALSE> + PHRASE10>
+ <NTHUV SD7 3 = TEMP11 (TYPE LIST)>
+ <EMPL? TEMP11 + TAG15>
+ <LOOP (OPER5 VALUE) (TEMP11 VALUE)>
+TAG17
+ <NTHL TEMP11 1 = TEMP19>
+ <TYPE? TEMP19 <TYPE-CODE ATOM> - TAG18>
+ <VEQUAL? TEMP19 OPER5 + TAG16>
+ <DEAD TEMP19>
+TAG18
+ <RESTL TEMP11 1 = TEMP11 (TYPE LIST)>
+ <EMPL? TEMP11 - TAG17>
+TAG15
+ <SET TEMP11 %<> (TYPE FALSE)>
+TAG16
+ <VEQUAL? TEMP11 0 + PHRASE14>
+ <RESTL TEMP11 1 = TEMP19 (TYPE LIST)>
+ <DEAD TEMP11>
+ <PUTL TEMP19 1 FCN6>
+ <DEAD TEMP19 FCN6>
+ <JUMP + COND13>
+PHRASE14
+ <NTHUV SD7 3 = TEMP19 (TYPE LIST)>
+ <CONS FCN6 TEMP19 = TEMP19>
+ <DEAD FCN6>
+ <CONS OPER5 TEMP19 = TEMP19>
+ <PUTUV SD7 3 TEMP19 (TYPE LIST)>
+ <DEAD SD7 TEMP19>
+COND13
+ <SET TEMP11 OPER5>
+ <DEAD OPER5>
+PHRASE10
+ <RETURN TEMP11>
+ <DEAD TEMP11>
+ <END \1aSET-TYPE-FCN>
+
+#WORD *14454416161*
+ <GFCN \1aSET-TYPE-INHERIT ("VALUE" <OR FALSE SDTABLE> ATOM <OR ATOM FALSE <LIST [REST ATOM]>>) STYPE4 INHERIT5>
+ <TEMP SD6 TEMP10>
+ <INTGO>
+ <FRAME '\1aGET-CHANNEL-TYPE>
+ <PUSH STYPE4>
+ <DEAD STYPE4>
+ <CALL '\1aGET-CHANNEL-TYPE 1 = SD6>
+ <SET TEMP10 SD6>
+ <TYPE? TEMP10 <TYPE-CODE FALSE> + PHRASE9>
+ <PUTUV SD6 2 INHERIT5>
+ <DEAD INHERIT5>
+ <SET TEMP10 SD6>
+ <DEAD SD6>
+PHRASE9
+ <RETURN TEMP10>
+ <DEAD TEMP10>
+ <END \1aSET-TYPE-INHERIT>
+
+#WORD *37413160131*
+ <GFCN \1aGET-CHANNEL-TYPE ("VALUE" <OR ATOM FALSE SDTABLE> ATOM) STYPE4>
+ <TEMP TEMP9 TL5>
+ <INTGO>
+ <NTHR 'CHANNEL-TYPES 1 = TEMP9 (RECORD-TYPE ATOM) (BRANCH-FALSE + PHRASE7)>
+ <TYPE? TEMP9 <TYPE-CODE FALSE> + PHRASE7>
+ <NTHR TEMP9 1 = TEMP9 (RECORD-TYPE GBIND)>
+ <TYPE? TEMP9 <TYPE-CODE UNBOUND> + PHRASE7>
+ <DEAD TEMP9>
+ <GVAL 'CHANNEL-TYPES = TL5>
+ <EMPL? TL5 + TAG10>
+ <LOOP (STYPE4 VALUE) (TL5 VALUE)>
+TAG12
+ <NTHL TL5 1 = TEMP9>
+ <TYPE? TEMP9 <TYPE-CODE ATOM> - TAG13>
+ <VEQUAL? TEMP9 STYPE4 + TAG11>
+ <DEAD TEMP9>
+TAG13
+ <RESTL TL5 1 = TL5 (TYPE LIST)>
+ <EMPL? TL5 - TAG12>
+TAG10
+ <SET TL5 %<> (TYPE FALSE)>
+TAG11
+ <VEQUAL? TL5 0 + PHRASE7>
+ <RESTL TL5 1 = TEMP9 (TYPE LIST)>
+ <DEAD TL5>
+ <NTHL TEMP9 1 = TEMP9>
+ <RETURN TEMP9>
+ <DEAD TEMP9>
+PHRASE7
+ <RETURN #FALSE ("NO SUCH CHANNEL TYPE")>
+ <END \1aGET-CHANNEL-TYPE>
+
+#WORD *3250240033*
+ <GFCN \1aCT-QUERY ("VALUE" ANY ATOM ATOM "OPTIONAL" FIX) STYPE6 OPER7 DEPTH8>
+ <OPT-DISPATCH 2 %<> OPT4 OPT5>
+OPT4
+ <PUSH 0>
+OPT5
+ <TEMP SD10 TL11 TEMP23>
+ <INTGO>
+ <FRAME '\1aGET-CHANNEL-TYPE>
+ <PUSH STYPE6>
+ <CALL '\1aGET-CHANNEL-TYPE 1 = SD10>
+ <TYPE? SD10 <TYPE-CODE FALSE> + PHRASE15>
+ <NTHUV SD10 3 = TL11 (TYPE LIST)>
+ <EMPL? TL11 + TAG19>
+ <LOOP (OPER7 VALUE) (TL11 VALUE)>
+TAG21
+ <NTHL TL11 1 = TEMP23>
+ <TYPE? TEMP23 <TYPE-CODE ATOM> - TAG22>
+ <VEQUAL? TEMP23 OPER7 + TAG20>
+ <DEAD TEMP23>
+TAG22
+ <RESTL TL11 1 = TL11 (TYPE LIST)>
+ <EMPL? TL11 - TAG21>
+TAG19
+ <SET TL11 %<> (TYPE FALSE)>
+TAG20
+ <VEQUAL? TL11 0 + PHRASE18>
+ <RESTL TL11 1 = TEMP23 (TYPE LIST)>
+ <DEAD TL11>
+ <NTHL TEMP23 1 = SD10>
+ <DEAD TEMP23>
+ <JUMP + PHRASE54>
+PHRASE18
+ <NTHUV SD10 3 = TEMP23 (TYPE LIST)>
+ <EMPL? TEMP23 + TAG25>
+ <LOOP (TEMP23 VALUE)>
+TAG27
+ <NTHL TEMP23 1 = TL11>
+ <TYPE? TL11 <TYPE-CODE ATOM> - TAG28>
+ <VEQUAL? TL11 '* + TAG26>
+ <DEAD TL11>
+TAG28
+ <RESTL TEMP23 1 = TEMP23 (TYPE LIST)>
+ <EMPL? TEMP23 - TAG27>
+TAG25
+ <SET TL11 %<> (TYPE FALSE)>
+ <JUMP + TAG30>
+TAG26
+ <SET TL11 TEMP23>
+ <DEAD TEMP23>
+TAG30
+ <VEQUAL? TL11 0 + PHRASE24>
+ <RESTL TL11 1 = TEMP23 (TYPE LIST)>
+ <DEAD TL11>
+ <NTHL TEMP23 1 = SD10>
+ <DEAD TEMP23>
+ <JUMP + PHRASE54>
+PHRASE24
+ <NTHUV SD10 2 = TEMP23>
+ <DEAD SD10>
+ <TYPE? TEMP23 <TYPE-CODE FALSE> + PHRASE31>
+ <ADD DEPTH8 1 = DEPTH8 (TYPE FIX)>
+ <GRTR? DEPTH8 5 - PHRASE33 (TYPE FIX)>
+ <FRAME '\1aERROR>
+ <PUSH 'INHERITANCE-DEPTH-TOO-GREAT!-ERRORS>
+ <PUSH STYPE6>
+ <DEAD STYPE6>
+ <PUSH OPER7>
+ <PUSH 'CT-QUERY>
+ <CALL '\1aERROR 4>
+PHRASE33
+ <TYPE? TEMP23 <TYPE-CODE ATOM> - PHRASE36>
+ <FRAME '\1aCT-QUERY>
+ <PUSH TEMP23>
+ <DEAD TEMP23>
+ <PUSH OPER7>
+ <DEAD OPER7>
+ <PUSH DEPTH8>
+ <DEAD DEPTH8>
+ <CALL '\1aCT-QUERY 3 = SD10>
+ <JUMP + PHRASE54>
+PHRASE36
+ <SET TL11 %<> (TYPE FALSE)>
+ <LOOP>
+MAP40
+ <INTGO>
+ <EMPL? TEMP23 + MAPAP43>
+ <NTHL TEMP23 1 = SD10>
+ <FRAME '\1aCT-QUERY>
+ <PUSH SD10>
+ <DEAD SD10>
+ <PUSH OPER7>
+ <PUSH DEPTH8>
+ <CALL '\1aCT-QUERY 3 = SD10>
+ <SET TL11 SD10>
+ <TYPE? TL11 <TYPE-CODE FALSE> + PHRASE51>
+ <JUMP + PHRASE54>
+PHRASE51
+ <RESTL TEMP23 1 = TEMP23 (TYPE LIST)>
+ <JUMP + MAP40>
+MAPAP43
+ <SET SD10 TL11>
+ <DEAD TL11>
+ <JUMP + PHRASE54>
+PHRASE31
+ <SET SD10 #FALSE ("CHANNEL TYPE DOESN'T DEFINE OPERATION") (TYPE FALSE)>
+PHRASE54
+ <TYPE? SD10 <TYPE-CODE MSUBR> - PHRASE56>
+ <NTHUV SD10 2 = TEMP23>
+ <DEAD SD10>
+ <RETURN TEMP23>
+ <DEAD TEMP23>
+PHRASE56
+ <RETURN SD10>
+ <DEAD SD10>
+PHRASE15
+ <RETURN #FALSE ("NO SUCH CHANNEL TYPE")>
+ <END \1aCT-QUERY>
+
+<ENDPACKAGE>
projects / pdp10-muddle.git / blobdiff