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

diff --git a/mim/development/mim/vaxc/channel-type.mima b/mim/development/mim/vaxc/channel-type.mima
new file mode 100644
index 0000000..ac9ea8a
--- /dev/null
+++ b/mim/development/mim/vaxc/channel-type.mima
@@ -0,0 +1,356 @@
+
+<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 NEW-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 'ERROR>
+		    <PUSH SNAME4>
+		    <PUSH 'ALREADY-DEFINED-ERRET-NON-FALSE-TO-REDEFINE!-ERRORS>
+		    <PUSH 'NEW-CHANNEL-TYPE>
+		    <CALL 'ERROR 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 NEW-CHANNEL-TYPE>
+
+#WORD *227604520*
+		    <GFCN ADD-CHANNEL-OPS ("VALUE" ATOM ATOM "TUPLE" <TUPLE [REST ATOM <OR MSUBR ATOM FALSE>]>) STYPE4>
+		    <MAKTUP OPS5:TUPLE TEMP9 = OPS5>
+		    <INTGO>
+		    <FRAME 'GET-CHANNEL-TYPE>
+		    <PUSH STYPE4>
+		    <CALL 'GET-CHANNEL-TYPE 1 = TEMP9>
+		    <TYPE? TEMP9 <TYPE-CODE FALSE> + PHRASE7>
+		    <DEAD TEMP9>
+		    <SET TEMP9 OPS5>
+		    <LOOP>
+AGAIN12
+		    <INTGO>
+		    <EMPUV? TEMP9 + EXIT10>
+		    <FRAME 'SET-TYPE-FCN>
+		    <PUSH STYPE4>
+		    <NTHUV OPS5 1 = STACK (TYPE ATOM)>
+		    <NTHUV OPS5 2 = STACK>
+		    <CALL 'SET-TYPE-FCN 3>
+		    <RESTUV TEMP9 2 = TEMP9 (TYPE VECTOR)>
+		    <CHTYPE TEMP9 <TYPE-CODE VECTOR> = TEMP9>
+		    <JUMP + AGAIN12>
+EXIT10
+		    <RETURN STYPE4>
+		    <DEAD STYPE4>
+PHRASE7
+		    <FRAME 'NEW-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 'NEW-CHANNEL-TYPE TEMP9>
+		    <DEAD TEMP9>
+		    <RETURN STYPE4>
+		    <DEAD STYPE4>
+		    <END ADD-CHANNEL-OPS>
+
+#WORD *14340316375*
+		    <GFCN SET-TYPE-FCN ("VALUE" <OR ATOM FALSE> ATOM ATOM <OR ATOM MSUBR FALSE>) STYPE4 OPER5 FCN6>
+		    <TEMP SD7 TEMP11 TEMP19>
+		    <INTGO>
+		    <FRAME 'GET-CHANNEL-TYPE>
+		    <PUSH STYPE4>
+		    <DEAD STYPE4>
+		    <CALL 'GET-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 SET-TYPE-FCN>
+
+#WORD *14454416161*
+		    <GFCN SET-TYPE-INHERIT ("VALUE" <OR FALSE SDTABLE> ATOM <OR ATOM FALSE <LIST [REST ATOM]>>) STYPE4 INHERIT5>
+		    <TEMP SD6 TEMP10>
+		    <INTGO>
+		    <FRAME 'GET-CHANNEL-TYPE>
+		    <PUSH STYPE4>
+		    <DEAD STYPE4>
+		    <CALL 'GET-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 SET-TYPE-INHERIT>
+
+#WORD *37413160131*
+		    <GFCN GET-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 GET-CHANNEL-TYPE>
+
+#WORD *3250240033*
+		    <GFCN CT-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 'GET-CHANNEL-TYPE>
+		    <PUSH STYPE6>
+		    <CALL 'GET-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 'ERROR>
+		    <PUSH 'INHERITANCE-DEPTH-TOO-GREAT!-ERRORS>
+		    <PUSH STYPE6>
+		    <DEAD STYPE6>
+		    <PUSH OPER7>
+		    <PUSH 'CT-QUERY>
+		    <CALL 'ERROR 4>
+PHRASE33
+		    <TYPE? TEMP23 <TYPE-CODE ATOM> - PHRASE36>
+		    <FRAME 'CT-QUERY>
+		    <PUSH TEMP23>
+		    <DEAD TEMP23>
+		    <PUSH OPER7>
+		    <DEAD OPER7>
+		    <PUSH DEPTH8>
+		    <DEAD DEPTH8>
+		    <CALL 'CT-QUERY 3 = SD10>
+		    <JUMP + PHRASE54>
+PHRASE36
+		    <SET TL11 %<> (TYPE FALSE)>
+		    <LOOP>
+MAP40
+		    <INTGO>
+		    <EMPL? TEMP23 + MAPAP43>
+		    <NTHL TEMP23 1 = SD10>
+		    <FRAME 'CT-QUERY>
+		    <PUSH SD10>
+		    <DEAD SD10>
+		    <PUSH OPER7>
+		    <PUSH DEPTH8>
+		    <CALL 'CT-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 CT-QUERY>
+
+<ENDPACKAGE>