mim/development/mim/vaxc/channel-type.mima

   1
   2 <PACKAGE "CHANNEL-TYPE">
   3
   4 <ENTRY CT-QUERY>
   5
   6 <USE "NEWSTRUC">
   7
   8 <NEWSTRUC SDTABLE VECTOR SD-NAME ATOM SD-INHERIT <OR FALSE ATOM <LIST [REST ATOM]>> SD-OPER <LIST [REST ATOM <OR MSUBR ATOM FALSE>]>>
   9
  10 <GDECL (CHANNEL-TYPES) <LIST [REST ATOM SDTABLE]>>
  11
  12 #WORD *21142502170*
  13                     <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>
  14                     <MAKTUP OPS6 TEMP14 ST7:LIST TL8 TEMP30 = OPS6>
  15                     <INTGO>
  16                     <NTHR 'CHANNEL-TYPES 1 = TEMP14 (RECORD-TYPE ATOM) (BRANCH-FALSE + TAG13)>
  17                     <TYPE? TEMP14 <TYPE-CODE FALSE> + TAG13>
  18                     <NTHR TEMP14 1 = TEMP14 (RECORD-TYPE GBIND)>
  19                     <TYPE? TEMP14 <TYPE-CODE UNBOUND> - PHRASE12>
  20                     <DEAD TEMP14>
  21 TAG13
  22                     <SET ST7 () (TYPE LIST)>
  23                     <SETG 'CHANNEL-TYPES ST7>
  24                     <JUMP + COND11>
  25 PHRASE12
  26                     <GVAL 'CHANNEL-TYPES = ST7>
  27 COND11
  28                     <SET TL8 ST7>
  29                     <EMPL? TL8 + TAG18>
  30                     <LOOP (SNAME4 VALUE) (TL8 VALUE)>
  31 TAG20
  32                     <NTHL TL8 1 = TEMP14>
  33                     <TYPE? TEMP14 <TYPE-CODE ATOM> - TAG21>
  34                     <VEQUAL? TEMP14 SNAME4 + TAG19>
  35                     <DEAD TEMP14>
  36 TAG21
  37                     <RESTL TL8 1 = TL8 (TYPE LIST)>
  38                     <EMPL? TL8 - TAG20>
  39 TAG18
  40                     <SET TL8 %<> (TYPE FALSE)>
  41 TAG19
  42                     <VEQUAL? TL8 0 + BOOL17>
  43                     <GEN-ASSIGNED? 'REDEFINE - BOOL23>
  44                     <GEN-LVAL 'REDEFINE = TEMP14>
  45                     <TYPE? TEMP14 <TYPE-CODE FALSE> - BOOL17>
  46                     <DEAD TEMP14>
  47 BOOL23
  48                     <FRAME '\1aERROR>
  49                     <PUSH SNAME4>
  50                     <PUSH 'ALREADY-DEFINED-ERRET-NON-FALSE-TO-REDEFINE!-ERRORS>
  51                     <PUSH 'NEW-CHANNEL-TYPE>
  52                     <CALL '\1aERROR 3 = TEMP14>
  53                     <TYPE? TEMP14 <TYPE-CODE FALSE> + PHRASE16>
  54 BOOL17
  55                     <PUSH SNAME4>
  56                     <PUSH INHERIT5>
  57                     <DEAD INHERIT5>
  58                     <SET TEMP30 0 (TYPE FIX)>
  59                     <SET TEMP14 OPS6>
  60                     <DEAD OPS6>
  61                     <LOOP (TEMP14 VALUE LENGTH) (TEMP30 VALUE)>
  62 TAG31
  63                     <INTGO>
  64                     <EMPUV? TEMP14 + TAG29>
  65                     <NTHUV TEMP14 1 = STACK>
  66                     <RESTUV TEMP14 1 = TEMP14 (TYPE VECTOR)>
  67                     <ADD TEMP30 1 = TEMP30 (TYPE FIX)>
  68                     <JUMP + TAG31>
  69 TAG29
  70                     <LIST TEMP30 = STACK (TYPE LIST)>
  71                     <DEAD TEMP30>
  72                     <UBLOCK <TYPE-CODE VECTOR> 3 = TEMP30>
  73                     <CHTYPE TEMP30 <TYPE-CODE SDTABLE> = OPS6>
  74                     <DEAD TEMP30>
  75                     <TYPE? TL8 <TYPE-CODE FALSE> + PHRASE34>
  76                     <RESTL TL8 1 = TEMP30 (TYPE LIST)>
  77                     <DEAD TL8>
  78                     <PUTL TEMP30 1 OPS6>
  79                     <DEAD TEMP30 OPS6>
  80                     <JUMP + COND33>
  81 PHRASE34
  82                     <CONS OPS6 ST7 = TEMP30>
  83                     <DEAD OPS6 ST7>
  84                     <CONS SNAME4 TEMP30 = TEMP30>
  85                     <SETG 'CHANNEL-TYPES TEMP30>
  86                     <DEAD TEMP30>
  87 COND33
  88                     <SET TEMP14 SNAME4>
  89                     <DEAD SNAME4>
  90 PHRASE16
  91                     <RETURN TEMP14>
  92                     <DEAD TEMP14>
  93                     <END \1aNEW-CHANNEL-TYPE>
  94
  95 #WORD *227604520*
  96                     <GFCN \1aADD-CHANNEL-OPS ("VALUE" ATOM ATOM "TUPLE" <TUPLE [REST ATOM <OR MSUBR ATOM FALSE>]>) STYPE4>
  97                     <MAKTUP OPS5:TUPLE TEMP9 = OPS5>
  98                     <INTGO>
  99                     <FRAME '\1aGET-CHANNEL-TYPE>
 100                     <PUSH STYPE4>
 101                     <CALL '\1aGET-CHANNEL-TYPE 1 = TEMP9>
 102                     <TYPE? TEMP9 <TYPE-CODE FALSE> + PHRASE7>
 103                     <DEAD TEMP9>
 104                     <SET TEMP9 OPS5>
 105                     <LOOP>
 106 AGAIN12
 107                     <INTGO>
 108                     <EMPUV? TEMP9 + EXIT10>
 109                     <FRAME '\1aSET-TYPE-FCN>
 110                     <PUSH STYPE4>
 111                     <NTHUV OPS5 1 = STACK (TYPE ATOM)>
 112                     <NTHUV OPS5 2 = STACK>
 113                     <CALL '\1aSET-TYPE-FCN 3>
 114                     <RESTUV TEMP9 2 = TEMP9 (TYPE VECTOR)>
 115                     <CHTYPE TEMP9 <TYPE-CODE VECTOR> = TEMP9>
 116                     <JUMP + AGAIN12>
 117 EXIT10
 118                     <RETURN STYPE4>
 119                     <DEAD STYPE4>
 120 PHRASE7
 121                     <FRAME '\1aNEW-CHANNEL-TYPE>
 122                     <PUSH STYPE4>
 123                     <PUSH %<>>
 124                     <SET TEMP9 2 (TYPE FIX)>
 125                     <LOOP (OPS5 VALUE LENGTH) (TEMP9 VALUE)>
 126 TAG20
 127                     <INTGO>
 128                     <EMPUV? OPS5 + TAG17>
 129                     <NTHUV OPS5 1 = STACK>
 130                     <RESTUV OPS5 1 = OPS5 (TYPE VECTOR)>
 131                     <ADD TEMP9 1 = TEMP9 (TYPE FIX)>
 132                     <JUMP + TAG20>
 133 TAG17
 134                     <CALL '\1aNEW-CHANNEL-TYPE TEMP9>
 135                     <DEAD TEMP9>
 136                     <RETURN STYPE4>
 137                     <DEAD STYPE4>
 138                     <END \1aADD-CHANNEL-OPS>
 139
 140 #WORD *14340316375*
 141                     <GFCN \1aSET-TYPE-FCN ("VALUE" <OR ATOM FALSE> ATOM ATOM <OR ATOM MSUBR FALSE>) STYPE4 OPER5 FCN6>
 142                     <TEMP SD7 TEMP11 TEMP19>
 143                     <INTGO>
 144                     <FRAME '\1aGET-CHANNEL-TYPE>
 145                     <PUSH STYPE4>
 146                     <DEAD STYPE4>
 147                     <CALL '\1aGET-CHANNEL-TYPE 1 = SD7>
 148                     <SET TEMP11 SD7>
 149                     <TYPE? TEMP11 <TYPE-CODE FALSE> + PHRASE10>
 150                     <NTHUV SD7 3 = TEMP11 (TYPE LIST)>
 151                     <EMPL? TEMP11 + TAG15>
 152                     <LOOP (OPER5 VALUE) (TEMP11 VALUE)>
 153 TAG17
 154                     <NTHL TEMP11 1 = TEMP19>
 155                     <TYPE? TEMP19 <TYPE-CODE ATOM> - TAG18>
 156                     <VEQUAL? TEMP19 OPER5 + TAG16>
 157                     <DEAD TEMP19>
 158 TAG18
 159                     <RESTL TEMP11 1 = TEMP11 (TYPE LIST)>
 160                     <EMPL? TEMP11 - TAG17>
 161 TAG15
 162                     <SET TEMP11 %<> (TYPE FALSE)>
 163 TAG16
 164                     <VEQUAL? TEMP11 0 + PHRASE14>
 165                     <RESTL TEMP11 1 = TEMP19 (TYPE LIST)>
 166                     <DEAD TEMP11>
 167                     <PUTL TEMP19 1 FCN6>
 168                     <DEAD TEMP19 FCN6>
 169                     <JUMP + COND13>
 170 PHRASE14
 171                     <NTHUV SD7 3 = TEMP19 (TYPE LIST)>
 172                     <CONS FCN6 TEMP19 = TEMP19>
 173                     <DEAD FCN6>
 174                     <CONS OPER5 TEMP19 = TEMP19>
 175                     <PUTUV SD7 3 TEMP19 (TYPE LIST)>
 176                     <DEAD SD7 TEMP19>
 177 COND13
 178                     <SET TEMP11 OPER5>
 179                     <DEAD OPER5>
 180 PHRASE10
 181                     <RETURN TEMP11>
 182                     <DEAD TEMP11>
 183                     <END \1aSET-TYPE-FCN>
 184
 185 #WORD *14454416161*
 186                     <GFCN \1aSET-TYPE-INHERIT ("VALUE" <OR FALSE SDTABLE> ATOM <OR ATOM FALSE <LIST [REST ATOM]>>) STYPE4 INHERIT5>
 187                     <TEMP SD6 TEMP10>
 188                     <INTGO>
 189                     <FRAME '\1aGET-CHANNEL-TYPE>
 190                     <PUSH STYPE4>
 191                     <DEAD STYPE4>
 192                     <CALL '\1aGET-CHANNEL-TYPE 1 = SD6>
 193                     <SET TEMP10 SD6>
 194                     <TYPE? TEMP10 <TYPE-CODE FALSE> + PHRASE9>
 195                     <PUTUV SD6 2 INHERIT5>
 196                     <DEAD INHERIT5>
 197                     <SET TEMP10 SD6>
 198                     <DEAD SD6>
 199 PHRASE9
 200                     <RETURN TEMP10>
 201                     <DEAD TEMP10>
 202                     <END \1aSET-TYPE-INHERIT>
 203
 204 #WORD *37413160131*
 205                     <GFCN \1aGET-CHANNEL-TYPE ("VALUE" <OR ATOM FALSE SDTABLE> ATOM) STYPE4>
 206                     <TEMP TEMP9 TL5>
 207                     <INTGO>
 208                     <NTHR 'CHANNEL-TYPES 1 = TEMP9 (RECORD-TYPE ATOM) (BRANCH-FALSE + PHRASE7)>
 209                     <TYPE? TEMP9 <TYPE-CODE FALSE> + PHRASE7>
 210                     <NTHR TEMP9 1 = TEMP9 (RECORD-TYPE GBIND)>
 211                     <TYPE? TEMP9 <TYPE-CODE UNBOUND> + PHRASE7>
 212                     <DEAD TEMP9>
 213                     <GVAL 'CHANNEL-TYPES = TL5>
 214                     <EMPL? TL5 + TAG10>
 215                     <LOOP (STYPE4 VALUE) (TL5 VALUE)>
 216 TAG12
 217                     <NTHL TL5 1 = TEMP9>
 218                     <TYPE? TEMP9 <TYPE-CODE ATOM> - TAG13>
 219                     <VEQUAL? TEMP9 STYPE4 + TAG11>
 220                     <DEAD TEMP9>
 221 TAG13
 222                     <RESTL TL5 1 = TL5 (TYPE LIST)>
 223                     <EMPL? TL5 - TAG12>
 224 TAG10
 225                     <SET TL5 %<> (TYPE FALSE)>
 226 TAG11
 227                     <VEQUAL? TL5 0 + PHRASE7>
 228                     <RESTL TL5 1 = TEMP9 (TYPE LIST)>
 229                     <DEAD TL5>
 230                     <NTHL TEMP9 1 = TEMP9>
 231                     <RETURN TEMP9>
 232                     <DEAD TEMP9>
 233 PHRASE7
 234                     <RETURN #FALSE ("NO SUCH CHANNEL TYPE")>
 235                     <END \1aGET-CHANNEL-TYPE>
 236
 237 #WORD *3250240033*
 238                     <GFCN \1aCT-QUERY ("VALUE" ANY ATOM ATOM "OPTIONAL" FIX) STYPE6 OPER7 DEPTH8>
 239                     <OPT-DISPATCH 2 %<> OPT4 OPT5>
 240 OPT4
 241                     <PUSH 0>
 242 OPT5
 243                     <TEMP SD10 TL11 TEMP23>
 244                     <INTGO>
 245                     <FRAME '\1aGET-CHANNEL-TYPE>
 246                     <PUSH STYPE6>
 247                     <CALL '\1aGET-CHANNEL-TYPE 1 = SD10>
 248                     <TYPE? SD10 <TYPE-CODE FALSE> + PHRASE15>
 249                     <NTHUV SD10 3 = TL11 (TYPE LIST)>
 250                     <EMPL? TL11 + TAG19>
 251                     <LOOP (OPER7 VALUE) (TL11 VALUE)>
 252 TAG21
 253                     <NTHL TL11 1 = TEMP23>
 254                     <TYPE? TEMP23 <TYPE-CODE ATOM> - TAG22>
 255                     <VEQUAL? TEMP23 OPER7 + TAG20>
 256                     <DEAD TEMP23>
 257 TAG22
 258                     <RESTL TL11 1 = TL11 (TYPE LIST)>
 259                     <EMPL? TL11 - TAG21>
 260 TAG19
 261                     <SET TL11 %<> (TYPE FALSE)>
 262 TAG20
 263                     <VEQUAL? TL11 0 + PHRASE18>
 264                     <RESTL TL11 1 = TEMP23 (TYPE LIST)>
 265                     <DEAD TL11>
 266                     <NTHL TEMP23 1 = SD10>
 267                     <DEAD TEMP23>
 268                     <JUMP + PHRASE54>
 269 PHRASE18
 270                     <NTHUV SD10 3 = TEMP23 (TYPE LIST)>
 271                     <EMPL? TEMP23 + TAG25>
 272                     <LOOP (TEMP23 VALUE)>
 273 TAG27
 274                     <NTHL TEMP23 1 = TL11>
 275                     <TYPE? TL11 <TYPE-CODE ATOM> - TAG28>
 276                     <VEQUAL? TL11 '* + TAG26>
 277                     <DEAD TL11>
 278 TAG28
 279                     <RESTL TEMP23 1 = TEMP23 (TYPE LIST)>
 280                     <EMPL? TEMP23 - TAG27>
 281 TAG25
 282                     <SET TL11 %<> (TYPE FALSE)>
 283                     <JUMP + TAG30>
 284 TAG26
 285                     <SET TL11 TEMP23>
 286                     <DEAD TEMP23>
 287 TAG30
 288                     <VEQUAL? TL11 0 + PHRASE24>
 289                     <RESTL TL11 1 = TEMP23 (TYPE LIST)>
 290                     <DEAD TL11>
 291                     <NTHL TEMP23 1 = SD10>
 292                     <DEAD TEMP23>
 293                     <JUMP + PHRASE54>
 294 PHRASE24
 295                     <NTHUV SD10 2 = TEMP23>
 296                     <DEAD SD10>
 297                     <TYPE? TEMP23 <TYPE-CODE FALSE> + PHRASE31>
 298                     <ADD DEPTH8 1 = DEPTH8 (TYPE FIX)>
 299                     <GRTR? DEPTH8 5 - PHRASE33 (TYPE FIX)>
 300                     <FRAME '\1aERROR>
 301                     <PUSH 'INHERITANCE-DEPTH-TOO-GREAT!-ERRORS>
 302                     <PUSH STYPE6>
 303                     <DEAD STYPE6>
 304                     <PUSH OPER7>
 305                     <PUSH 'CT-QUERY>
 306                     <CALL '\1aERROR 4>
 307 PHRASE33
 308                     <TYPE? TEMP23 <TYPE-CODE ATOM> - PHRASE36>
 309                     <FRAME '\1aCT-QUERY>
 310                     <PUSH TEMP23>
 311                     <DEAD TEMP23>
 312                     <PUSH OPER7>
 313                     <DEAD OPER7>
 314                     <PUSH DEPTH8>
 315                     <DEAD DEPTH8>
 316                     <CALL '\1aCT-QUERY 3 = SD10>
 317                     <JUMP + PHRASE54>
 318 PHRASE36
 319                     <SET TL11 %<> (TYPE FALSE)>
 320                     <LOOP>
 321 MAP40
 322                     <INTGO>
 323                     <EMPL? TEMP23 + MAPAP43>
 324                     <NTHL TEMP23 1 = SD10>
 325                     <FRAME '\1aCT-QUERY>
 326                     <PUSH SD10>
 327                     <DEAD SD10>
 328                     <PUSH OPER7>
 329                     <PUSH DEPTH8>
 330                     <CALL '\1aCT-QUERY 3 = SD10>
 331                     <SET TL11 SD10>
 332                     <TYPE? TL11 <TYPE-CODE FALSE> + PHRASE51>
 333                     <JUMP + PHRASE54>
 334 PHRASE51
 335                     <RESTL TEMP23 1 = TEMP23 (TYPE LIST)>
 336                     <JUMP + MAP40>
 337 MAPAP43
 338                     <SET SD10 TL11>
 339                     <DEAD TL11>
 340                     <JUMP + PHRASE54>
 341 PHRASE31
 342                     <SET SD10 #FALSE ("CHANNEL TYPE DOESN'T DEFINE OPERATION") (TYPE FALSE)>
 343 PHRASE54
 344                     <TYPE? SD10 <TYPE-CODE MSUBR> - PHRASE56>
 345                     <NTHUV SD10 2 = TEMP23>
 346                     <DEAD SD10>
 347                     <RETURN TEMP23>
 348                     <DEAD TEMP23>
 349 PHRASE56
 350                     <RETURN SD10>
 351                     <DEAD SD10>
 352 PHRASE15
 353                     <RETURN #FALSE ("NO SUCH CHANNEL TYPE")>
 354                     <END \1aCT-QUERY>
 355
 356 <ENDPACKAGE>