<mdl.int>/main.353

   1 TITLE MAIN LOOP AND GLOBALLY REFERENCED SUBROUTINES
   2
   3 RELOCA
   4
   5 .SYMTAB 3337.
   6
   7 .GLOBAL TBINIT,PIDSTO,PROCID,PTIME,GCPDL,PBASE,TYPTOP,RERR,FRMSTK,EMERGE
   8 .GLOBAL PDLBUF,INTINT,START,SWAP,ICR,SPBASE,TPBASE,TPBAS,CURPRI,CHFINI,MKTBS
   9 .GLOBAL TOPLEVEL,INTOBL,INITIA,ERROBL,MAINPR,RESFUN,STATUS,TYPVEC,ROOT,TTICHN,TTOCHN
  10 .GLOBAL TTYOPE,MOPEN,MCLOSE,MIOT,ILVAL,MESS,ERROR,CHFRM,IGVAL,TYPBOT,ASOVEC
  11 .GLOBAL PRINT,PRIN1,PRINC,MUDSTR,VECBOT,CSTACK,IFALSE,TYPLOO,RCALL,SWAPIN,CTMPLT
  12 .GLOBAL IDPROC,CHFSWP,ILOC,MAKACT,BNDV,SPECSTORE,BINDID,IGLOC,MTYO,MSGTYP,CAFRE1,CPOPJ
  13 .GLOBAL EVATYP,EVTYPE,APLTYP,APTYPE,PRNTYP,PRTYPE,AGC,SGSNAM,NAPT,APLQ,STRTO6
  14 .GLOBAL 6TOCHS,TYPFND,STBL,CHNL0,N.CHNS,CLOSAL,%LOGOUT,%SSNAM,%RSNAM,%KILLM,SAT
  15 .GLOBAL MAKINF,%VALRET,COMPERR,IPUT,IGET,TMATCH,INITIZ,IPCINI,%UNAM,%JNAM,%RUNAM,%RJNAM,%RXUNA,%RXJNA,%VALFI
  16 .GLOBAL NOTTY,DEMFLG,CFRAME,CARGS,CFUNCT,CITYPE,CTYPEQ,CPTYPE,CTYPEP,CUTYPE,
  17 .GLOBAL CCHUTY,RTFALS,PGINT,PURCLN,CTYPEC,CTYPEW,IDVAL1,CALLTY,MESSAG,INITFL,WHOAMI
  18 .GLOBAL %SLEEP,%HANG,%TOPLQ,ONINT,CHUNW,CURFCN,BUFRIN,TD.LNT,TD.GET,TD.AGC,TD.PUT,MPOPJ
  19 .GLOBAL PURVEC,PLOAD,SSPECS,OUTRNG,CVTYPE,FSTART,CKVRS,CPRTYC,PVSTOR,SPSTOR
  20 .GLOBAL TYPIC,CISET,LSTUF,IMPURI,REALTV
  21 .INSRT MUDDLE >
  22
  23 ;MAIN LOOP AND STARTUP
  24
  25 START:  MOVEI   0,0                     ; SET NO HACKS
  26         JUMPE   0,START1
  27         TLNE    0,-1                    ; SEE IF CHANNEL
  28         JRST    START1
  29         MOVE    P,GCPDL
  30         MOVE    A,0
  31         PUSH    P,A
  32         PUSHJ   P,CKVRS                 ; CHECK VERSION NUMBERS
  33         POP     P,A
  34         JRST    FSTART                  ; GO RESTORE
  35 START1: MOVEM   0,WHOAMI                ; HACK FOR TS FOO linked to TS MUDDLE
  36         MOVE    PVP,MAINPR              ; MAKE SURE WE START IN THE MAIN PROCESS
  37         JUMPE   0,INITIZ                ; MIGHT BE RESTART
  38         MOVE    P,PSTO+1(PVP)           ; SET UP FOR BOOTSTRAP HACK
  39         MOVE    TP,TPSTO+1(PVP)
  40 INITIZ: MOVE    PVP,MAINPR
  41         SKIPN   P                       ; IF NO CURRENT P
  42         MOVE    P,PSTO+1(PVP)           ; PDL TO GET OFF THE GROUND
  43         SKIPN   TP                      ; SAME FOR TP
  44         MOVE    TP,TPSTO+1(PVP)         ; GET A TP TO WORK WITH
  45         SETZB   R,M                     ; RESET RSUBR AC'S
  46         PUSHJ   P,%RUNAM
  47          JFCL
  48         PUSHJ   P,%RJNAM
  49         PUSHJ   P,TTYOPE                ;OPEN THE TTY
  50         MOVEI   B,MUDSTR
  51         SKIPE   WHOAMI          ; SKIP IF THIS IS MUDDLE
  52         JRST    NODEMT          ; ELSE NO MESSAGE
  53         SKIPE   DEMFLG          ; SKIP IF NOT DEMON
  54         JRST    NODEMT
  55         SKIPN   NOTTY                   ; IF NO TTY, IGNORE
  56         PUSHJ   P,MSGTYP                ;TYPE OUT TO USER
  57
  58 NODEMT: XCT     MESSAG                  ;MAYBE PRINT A MESSAGE
  59         PUSHJ   P,INTINT                ;INITIALIZE INTERRUPT HANDLER
  60         XCT     IPCINI
  61         PUSHJ   P,PURCLN                ; CLEAN UP PURE SHARED AREA
  62 RESTART:                                ;RESTART A PROCESS
  63 STP:    MOVEI   C,0
  64         MOVE    PVP,PVSTOR+1
  65         MOVE    B,TBINIT+1(PVP)         ;POINT INTO STACK AT START
  66         PUSHJ   P,CHUNW                 ; LEAVE WHILE DOING UNWIND CHECK
  67         XMOVEI  E,TOPLEV
  68         MOVEI   A,TFALSE                ; IN CASE FALLS OFF PROCESS
  69         MOVEI   B,0
  70         MOVEM   E,-1(TB)
  71         JRST    CONTIN
  72
  73         IMQUOTE TOPLEVEL
  74 TOPLEVEL:
  75         MCALL   0,LISTEN
  76         JRST    TOPLEVEL
  77 \f
  78
  79 IMFUNCTION LISTEN,SUBR
  80
  81         ENTRY
  82         PUSH    P,[0]           ;FLAG: DON'T PRINT ERROR MSG
  83         JRST    ER1
  84
  85 ; USER SUPPLIED ERROR HANDLER, TEMPORARY KLUDGE
  86         IMQUOTE ERROR
  87
  88 ERROR:  MOVE    B,IMQUOTE ERROR
  89         PUSHJ   P,IGVAL         ; GET VALUE
  90         GETYP   C,A
  91         CAIN    C,TSUBR         ; CHECK FOR NO CHANGE
  92         CAIE    B,RERR1         ; SKIP IF NOT CHANGED
  93         JRST    .+2
  94         JRST    RERR1           ; GO TO THE DEFAULT
  95         PUSH    TP,A            ; SAVE VALUE
  96         PUSH    TP,B
  97         MOVE    C,AB            ; SAVE AB
  98         MOVEI   D,1             ; AND COUNTER
  99 USER1:  PUSH    TP,(C)          ; PUSH THEM
 100         PUSH    TP,1(C)
 101         ADD     C,[2,,2]        ; BUMP
 102         ADDI    D,1
 103         JUMPL   C,USER1
 104         ACALL   D,APPLY         ; EVAL USERS ERROR
 105         JRST    FINIS
 106
 107
 108
 109 IMFUNCTION ERROR%,SUBR,ERROR
 110
 111 RERR1:  ENTRY
 112         PUSH    TP,$TATOM
 113         PUSH    TP,MQUOTE ERROR,ERROR,INTRUP
 114         PUSHJ   P,FRMSTK        ; PUT ERROR'S FRAME ON STACK
 115         MOVEI   D,2
 116         MOVE    C,AB
 117 RERR2:  JUMPGE  C,RERR22
 118         PUSH    TP,(C)
 119         PUSH    TP,1(C)
 120         ADD     C,[2,,2]
 121         AOJA    D,RERR2
 122 RERR22: ACALL   D,EMERGENCY
 123         JRST    RERR
 124
 125 IMQUOTE ERROR
 126 RERR:   ENTRY
 127         PUSH    P,[-1]          ;PRINT ERROR FLAG
 128
 129 ER1:    MOVE    B,IMQUOTE INCHAN
 130         PUSHJ   P,ILVAL         ; CHECK INPUT CHANNEL IS SOME KIND OF TTY
 131         GETYP   A,A
 132         CAIE    A,TCHAN         ; SKIP IF IT IS A CHANNEL
 133         JRST    ER2             ; NO, MUST REBIND
 134         CAMN    B,TTICHN+1
 135         JRST    NOTINC
 136 ER2:    MOVE    B,IMQUOTE INCHAN
 137         MOVEI   C,TTICHN        ; POINT TO VALU
 138         PUSHJ   P,PUSH6         ; PUSH THE BINDING
 139         MOVE    B,TTICHN+1      ; GET IN CHAN
 140 NOTINC: SKIPN   DEMFLG          ; SKIP IF DEMON
 141         SKIPE   NOTTY
 142         JRST    NOECHO
 143         PUSH    TP,$TCHAN
 144         PUSH    TP,B
 145         PUSH    TP,$TATOM
 146         PUSH    TP,IMQUOTE T
 147         MCALL   2,TTYECH        ; ECHO INPUT
 148 NOECHO: MOVE    B,IMQUOTE OUTCHAN
 149         PUSHJ   P,ILVAL         ; GET THE VALUE
 150         GETYP   A,A
 151         CAIE    A,TCHAN         ; SKIP IF OK CHANNEL
 152         JRST    ER3             ; NOT CHANNEL, MUST REBIND
 153         CAMN    B,TTOCHN+1
 154         JRST    NOTOUT
 155 ER3:    MOVE    B,IMQUOTE OUTCHAN
 156         MOVEI   C,TTOCHN
 157         PUSHJ   P,PUSH6         ; PUSH THE BINDINGS
 158 NOTOUT: MOVE    B,IMQUOTE OBLIST
 159         PUSHJ   P,ILVAL ; GET THE VALUE OF OBLIST
 160         PUSHJ   P,OBCHK         ; IS IT A WINNER ?
 161         SKIPA   A,$TATOM        ; NO, SKIP AND CONTINUE
 162         JRST    NOTOBL          ; YES, DO NOT DO REBINDING
 163         MOVE    B,IMQUOTE OBLIST
 164         PUSHJ   P,IGLOC
 165         GETYP   0,A
 166         CAIN    0,TUNBOU
 167         JRST    MAKOB           ; NO GLOBAL OBLIST, MAKE ONE
 168         MOVEI   C,(B)           ; COPY ADDRESS
 169         MOVE    A,(C)           ; GET THE GVAL
 170         MOVE    B,(C)+1
 171         PUSHJ   P,OBCHK         ; IS IT A WINNER ?
 172         JRST    MAKOB           ; NO, GO MAKE A NEW ONE
 173         MOVE    B,IMQUOTE OBLIST
 174         PUSHJ   P,PUSH6
 175
 176 NOTOBL: PUSH    TP,[TATOM,,-1]  ;FOR BINDING
 177         PUSH    TP,IMQUOTE LER,[LERR ]INTRUP
 178         PUSHJ   P,MAKACT
 179         HRLI    A,TFRAME        ; CORRCT TYPE
 180         PUSH    TP,A
 181         PUSH    TP,B
 182         PUSH    TP,[0]
 183         PUSH    TP,[0]
 184         MOVE    A,PVSTOR+1              ; GET PROCESS
 185         ADD     A,[PROCID,,PROCID]      ; POINT TO ID (ALSO LEVEL)
 186         PUSH    TP,BNDV
 187         PUSH    TP,A
 188         MOVE    A,PROCID(PVP)
 189         ADDI    A,1             ; BUMP ERROR LEVEL
 190         PUSH    TP,A
 191         PUSH    TP,PROCID+1(PVP)
 192         PUSH    P,A
 193
 194         MOVE    B,IMQUOTE READ-TABLE
 195         PUSHJ   P,IGVAL
 196         PUSH    TP,[TATOM,,-1]
 197         PUSH    TP,IMQUOTE READ-TABLE
 198         GETYP   C,A             ; TO GVAL OF READ-TABLE ON ERROR AND
 199         CAIE    C,TVEC  ; TOP ERRET'S
 200         JRST    .+4
 201         PUSH    TP,A
 202         PUSH    TP,B
 203         JRST    .+3
 204         PUSH    TP,$TUNBOUND
 205         PUSH    TP,[-1]
 206         PUSH    TP,[0]
 207         PUSH    TP,[0]
 208
 209         PUSHJ   P,SPECBIND      ;BIND THE CRETANS
 210         MOVE    A,-1(P)         ;RESTORE SWITHC
 211         JUMPE   A,NOERR         ;IF 0, DONT PRINT ERROR MESS
 212         PUSH    TP,$TATOM
 213         PUSH    TP,EQUOTE *ERROR*
 214         MCALL   0,TERPRI
 215         MCALL   1,PRINC ;PRINT THE MESSAGE
 216 NOERR:  MOVE    C,AB            ;GET A COPY OF AB
 217
 218 ERRLP:  JUMPGE  C,LEVPRT        ;IF NONE, RE-ENTER READ-EVAL-PRINT LOOP
 219         PUSH    TP,$TAB
 220         PUSH    TP,C
 221         MOVEI   B,PRIN1
 222         GETYP   A,(C)           ; GET  ARGS TYPE
 223         CAIE    A,TATOM
 224         JRST    ERROK
 225         MOVE    A,1(C)          ; GET ATOM
 226         HRRO    A,2(A)
 227         CAME    A,[-1,,ERROBL+1]
 228         CAMN    A,ERROBL+1      ; DONT SKIP IF IN ERROR OBLIST
 229         MOVEI   B,PRINC         ; DONT PRINT TRAILER
 230 ERROK:  PUSH    P,B             ; SAVE ROUTINE POINTER
 231         PUSH    TP,(C)
 232         PUSH    TP,1(C)
 233         MCALL   0,TERPRI        ; CRLF
 234         POP     P,B             ; GET ROUTINE BACK
 235         .MCALL  1,(B)
 236         POP     TP,C
 237         SUB     TP,[1,,1]
 238         ADD     C,[2,,2]        ;BUMP SAVED AB
 239         JRST    ERRLP           ;AND CONTINUE
 240
 241
 242 LEVPRT: XCT     INITFL          ;LOAD MUDDLE INIT FILE IF FIRST TIME
 243         MCALL   0,TERPRI
 244         PUSH    TP,$TATOM
 245         PUSH    TP,EQUOTE [LISTENING-AT-LEVEL ]
 246         MCALL   1,PRINC         ;PRINT LEVEL
 247         PUSH    TP,$TFIX        ;READY TO PRINT LEVEL
 248         HRRZ    A,(P)           ;GET LEVEL
 249         SUB     P,[2,,2]        ;AND POP STACK
 250         PUSH    TP,A
 251         MCALL   1,PRIN1         ;PRINT WITHOUT SPACES ETC.
 252         PUSH    TP,$TATOM       ;NOW PROCESS
 253         PUSH    TP,EQUOTE [ PROCESS ]
 254         MCALL   1,PRINC         ;DONT SLASHIFY SPACES
 255         MOVE    PVP,PVSTOR+1
 256         PUSH    TP,PROCID(PVP)  ;NOW ID
 257         PUSH    TP,PROCID+1(PVP)
 258         MCALL   1,PRIN1
 259         SKIPN   C,CURPRI
 260         JRST    MAINLP
 261         PUSH    TP,$TFIX
 262         PUSH    TP,C
 263         PUSH    TP,$TATOM
 264         PUSH    TP,EQUOTE [ INT-LEVEL ]
 265         MCALL   1,PRINC
 266         MCALL   1,PRIN1
 267         JRST    MAINLP          ; FALL INTO MAIN LOOP
 268
 269 \f;ROUTINES FOR ERROR-LISTEN
 270
 271 OBCHK:  GETYP   0,A
 272         CAIN    0,TOBLS
 273         JRST    CPOPJ1          ; WIN FOR SINGLE OBLIST
 274         CAIE    0,TLIST         ; IF LIST, MAKE SURE EACH IS AN OBLIST
 275         JRST    CPOPJ           ; ELSE, LOSE
 276
 277         JUMPE   B,CPOPJ         ; NIL ,LOSE
 278         PUSH    TP,A
 279         PUSH    TP,B
 280         PUSH    P,[0]           ;FLAG FOR DEFAULT CHECKING
 281         MOVEI   0,1000          ; VERY BIG NUMBER FOR CIRCULARITY TEST
 282
 283 OBCHK0: INTGO
 284         SOJE    0,OBLOSE        ; CIRCULARITY TEST
 285         HRRZ    B,(TP)          ; GET LIST POINTER
 286         GETYP   A,(B)
 287         CAIE    A,TOBLS         ; SKIP IF WINNER
 288         JRST    DEFCHK          ; CHECK FOR SPECIAL ATOM DEFAULT
 289         HRRZ    B,(B)
 290         MOVEM   B,(TP)
 291         JUMPN   B,OBCHK0
 292 OBWIN:  AOS     (P)-1
 293 OBLOSE: SUB     TP,[2,,2]
 294         SUB     P,[1,,1]
 295         POPJ    P,
 296
 297 DEFCHK: SKIPN   (P)             ; BEEN HERE BEFORE ?
 298         CAIE    A,TATOM         ; OR, NOT AN ATOM ?
 299         JRST    OBLOSE          ; YES, LOSE
 300         MOVE    A,(B)+1
 301         CAME    A,MQUOTE DEFAULT
 302         JRST    OBLOSE          ; LOSE
 303         SETOM   (P)             ; SET FLAG
 304         HRRZ    B,(B)           ; CHECK FOR END OF LIST
 305         MOVEM   B,(TP)
 306         JUMPN   B,OBCHK0                ; NOT THE END, CONTINUE LOOKING
 307         JRST    OBLOSE          ; LOSE FOR DEFAULT AT THE END
 308
 309
 310
 311 PUSH6:  PUSH    TP,[TATOM,,-1]
 312         PUSH    TP,B
 313         PUSH    TP,(C)
 314         PUSH    TP,1(C)
 315         PUSH    TP,[0]
 316         PUSH    TP,[0]
 317         POPJ    P,
 318
 319
 320 MAKOB:  PUSH    TP,INITIAL
 321         PUSH    TP,INITIAL+1
 322         PUSH    TP,ROOT
 323         PUSH    TP,ROOT+1
 324         MCALL   2,LIST
 325         PUSH    TP,$TATOM
 326         PUSH    TP,IMQUOTE OBLIST
 327         PUSH    TP,A
 328         PUSH    TP,B
 329         MCALL   2,SETG
 330         PUSH    TP,[TATOM,,-1]
 331         PUSH    TP,IMQUOTE OBLIST
 332         PUSH    TP,A
 333         PUSH    TP,B
 334         PUSH    TP,[0]
 335         PUSH    TP,[0]
 336         JRST    NOTOBL
 337 \f
 338
 339 ;THIS IS IT FOLKS...THE MAIN LOOP.  READ, EVAL, PRINT
 340
 341 MAINLP: MOVE    A,$TATOM        ;KLUDGE BY NDR LIKE ERROR TO LET LOOSER REDEFINE
 342         MOVE    B,IMQUOTE REP
 343         PUSHJ   P,ILVAL         ;GET ITS LVAL TO SEE IF REDEFINED
 344         GETYP   C,A
 345         CAIE    C,TUNBOUND
 346         JRST    REPCHK
 347         MOVE    A,$TATOM        ;SEE IF IT HAS GVAL SINCE NO LVAL
 348         MOVE    B,IMQUOTE REP
 349         PUSHJ   P,IGVAL
 350         GETYP   C,A
 351         CAIN    C,TUNBOUN
 352         JRST    IREPER
 353 REPCHK: CAIN    C,TSUBR
 354         CAIE    B,REPER
 355         JRST    .+2
 356         JRST    IREPER
 357 REREPE: PUSH    TP,A
 358         PUSH    TP,B
 359         GETYP   A,-1(TP)
 360         PUSHJ   P,APLQ
 361         JRST    ERRREP
 362         MCALL   1,APPLY         ;LOOSER HAS REDEFINED SO CALL HIS
 363         JRST    MAINLP
 364 IREPER: PUSH    P,[0]           ;INDICATE FALL THROUGH
 365         JRST    REPERF
 366
 367 ERRREP: PUSH    TP,[TATOM,,-1]
 368         PUSH    TP,IMQUOTE REP
 369         PUSH    TP,$TSUBR
 370         PUSH    TP,[REPER]
 371         PUSH    TP,[0]
 372         PUSH    TP,[0]
 373         PUSHJ   P,SPECBIN
 374         PUSH    TP,$TATOM
 375         PUSH    TP,EQUOTE NON-APPLICABLE-REP
 376         PUSH    TP,-11(TP)
 377         PUSH    TP,-11(TP)
 378         MCALL   2,ERROR
 379         SUB     TP,[6,,6]
 380         PUSHJ   P,SSPECS
 381         JRST    REREPE
 382
 383
 384 IMFUNCTION REPER,SUBR,REP
 385 REPER:  ENTRY   0
 386         PUSH    P,[1]           ;INDICATE DIRECT CALL
 387 REPERF: MCALL   0,TERPRI
 388         MCALL   0,READ
 389         PUSH    TP,A
 390         PUSH    TP,B
 391         MOVE    B,IMQUOTE L-INS
 392         PUSHJ   P,ILVAL         ; ASSIGNED?
 393         GETYP   0,A
 394         CAIN    0,TLIST
 395
 396         PUSHJ   P,LSTTOF                ; PUT LAST AS FIRST
 397         MCALL   0,TERPRI
 398         MCALL   1,EVAL
 399         MOVE    C,IMQUOTE LAST-OUT
 400         PUSHJ   P,CISET
 401         PUSH    TP,A
 402         PUSH    TP,B
 403         MOVE    B,IMQUOTE L-OUTS
 404         PUSHJ   P,ILVAL         ; ASSIGNED?
 405         GETYP   0,A
 406         CAIN    0,TLIST
 407
 408         CAME    B,(TP)          ; DONT STUFF IT INTO ITSELF
 409         JRST    STUFIT          ; STUFF IT IN
 410         GETYP   0,-1(TP)
 411         CAIE    0,TLIST         ; IF A LIST THE L-OUTS
 412 STUFIT: PUSHJ   P,LSTTOF                ; PUT LAST AS FIRST
 413         MCALL   1,PRIN1
 414         POP     P,C             ;FLAG FOR FALL THROUGH OR CALL
 415         JUMPN   C,FINIS         ;IN CASE LOOSER CALLED REP
 416         JRST    MAINLP
 417
 418 LSTTOF: SKIPN   A,B
 419         POPJ    P,
 420
 421         HRRZ    C,(A)
 422         JUMPE   C,LSTTO2
 423         MOVEI   D,(C)           ; SAVE PTR TO 2ND ELEMENT
 424         MOVEI   0,-1            ; LET THE LOSER LOSE (HA HA HA)
 425
 426 LSTTO1: HRRZ    C,(C)           ; START SCAN
 427         JUMPE   C,GOTIT
 428         HRRZ    A,(A)
 429         SOJG    0,LSTTO1
 430
 431 GOTIT:  HRRZ    C,(A)
 432         HLLZS   (A)
 433         CAIE    D,(C)           ; AVOID CIRCULARITY
 434         HRRM    D,(C)
 435         HRRM    C,(B)
 436         MOVE    D,1(B)
 437         MOVEM   D,1(C)
 438         GETYP   D,(B)
 439         PUTYP   D,(C)
 440
 441 LSTTO2: MOVSI   A,TLIST
 442         MOVE    C,-1(TP)
 443         MOVE    D,(TP)
 444         JRST    LSTUF
 445 \f
 446 ;FUNCTION TO RETRY A PREVIOUS FUNCTION CALL
 447
 448 MFUNCTION RETRY,SUBR
 449
 450         ENTRY
 451         JUMPGE  AB,RETRY1       ; USE MOST RECENT
 452         CAMGE   AB,[-2,,0]
 453         JRST    TMA
 454         GETYP   A,(AB)          ; CHECK TYPE
 455         CAIE    A,TFRAME
 456         JRST    WTYP1
 457         MOVEI   B,(AB)          ; POINT TO ARG
 458         JRST    RETRY2
 459 RETRY1: MOVE    B,IMQUOTE LER,[LERR ]INTRUP
 460         PUSHJ   P,ILOC          ; LOCATIVE TO FRAME
 461 RETRY2: PUSHJ   P,CHFSWP        ; CHECK VALIDITY AND SWAP IF NECESSARY
 462         HRRZ    0,OTBSAV(B)     ; CHECK FOR TOP
 463         JUMPE   0,RESTAR        ; YES RE-ENTER TOP LEVEL
 464         PUSH    TP,$TTB
 465         PUSH    TP,B            ; SAVE FRAME
 466         MOVE    B,OTBSAV(B)     ; GET PRVIOUS FOR UNBIND HACK
 467         MOVEI   C,-1(TP)
 468         PUSHJ   P,CHUNW         ; CHECK ANY UNWINDING
 469         CAME    SP,SPSAV(TB)    ; UNBINDING NEEDED?
 470         PUSHJ   P,SPECSTORE
 471         MOVE    P,PSAV(TB)      ; GET OTHER STUFF
 472         MOVE    AB,ABSAV(B)
 473         HLRE    A,AB            ; COMPUTE # OF ARGS
 474         MOVNI   A,-FRAMLN(A)    ; MAKE TP POINT PAST FRAME
 475         HRLI    A,(A)
 476         MOVE    C,TPSAV(TB)     ; COMPUTE TP
 477         ADD     C,A
 478         MOVE    TP,C
 479         MOVE    TB,B            ; FIX UP TB
 480         HRRZ    C,FSAV(TB)      ; GET FUNCTION
 481         CAIL    C,HIBOT
 482         JRST    (C)             ; GO
 483         GETYP   0,(C)           ; RSUBR OR ENTRY?
 484         CAIE    0,TATOM
 485         CAIN    0,TRSUBR
 486         JRST    RETRNT
 487         MOVS    R,(C)           ; SET UP R
 488         HRRI    R,(C)
 489         MOVEI   C,0
 490         JRST    RETRN3
 491
 492 RETRNT: CAIE    0,TRSUBR
 493         JRST    RETRN1
 494         MOVE    R,1(C)
 495 RETRN4: HRRZ    C,2(C)          ; OFFSET
 496 RETRN3: SKIPL   M,1(R)
 497         JRST    RETRN5
 498 RETRN7: ADDI    C,(M)
 499         JRST    (C)
 500
 501 RETRN5: MOVEI   D,(M)           ; TOTAL OFFSET
 502         MOVSS   M
 503         ADD     M,PURVEC+1
 504         SKIPL   M,1(M)
 505         JRST    RETRN6
 506         ADDI    M,(D)
 507         JRST    RETRN7
 508
 509 RETRN6: HLRZ    A,1(R)
 510         PUSH    P,D
 511         PUSH    P,C
 512         PUSHJ   P,PLOAD
 513         JRST    RETRER          ; LOSER
 514         POP     P,C
 515         POP     P,D
 516         MOVE    M,B
 517         JRST    RETRN7
 518
 519 RETRN1: HRL     C,(C)           ; FIX LH
 520         MOVE    B,1(C)
 521         PUSH    TP,$TVEC
 522         PUSH    TP,C
 523         PUSHJ   P,IGVAL
 524         GETYP   0,A
 525         MOVE    C,(TP)
 526         SUB     TP,[2,,2]
 527         CAIE    0,TRSUBR
 528         JRST    RETRN2
 529         MOVE    R,B
 530         JRST    RETRN4
 531
 532 RETRN2: ERRUUO  EQUOTE CANT-RETRY-ENTRY-GONE
 533
 534 RETRER: ERRUUO  EQUOTE PURE-LOAD-FAILURE
 535
 536 \f
 537 ;FUNCTION TO DO ERROR RETURN
 538
 539 IMFUNCTION ERRET,SUBR
 540
 541         ENTRY
 542         HLRE    A,AB            ; -2*# OF ARGS
 543         JUMPGE  A,STP           ; RESTART PROCESS
 544         ASH     A,-1            ; -# OF ARGS
 545         AOJE    A,ERRET2        ; NO FRAME SUPPLIED
 546         AOJL    A,TMA
 547         ADD     AB,[2,,2]
 548         PUSHJ   P,OKFRT
 549         JRST    WTYP2
 550         SUB     AB,[2,,2]
 551         PUSHJ   P,CHPROC        ; POINT TO FRAME SLOT
 552         JRST    ERRET3
 553 ERRET2: MOVE    B,IMQUOTE LER,[LERR ]INTRUP
 554         PUSHJ   P,ILVAL         ; GET ITS VALUE
 555 ERRET3: PUSH    TP,A
 556         PUSH    TP,B
 557         MOVEI   B,-1(TP)
 558         PUSHJ   P,CHFSWP        ; CHECK VALIDITY AND SWAP IF NECESSARY
 559         HRRZ    0,OTBSAV(B)     ; TOP LEVEL?
 560         JUMPE   0,TOPLOS
 561         PUSHJ   P,CHUNW         ; ANY UNWINDING
 562         JRST    CHFINIS
 563
 564
 565 ; FUNCTION TO RETURN LAST ERROR FRAME OR PREVIOUS FRAME
 566
 567 IMFUNCTION      FRAME,SUBR
 568         ENTRY
 569         SETZB   A,B
 570         JUMPGE  AB,FRM1         ; DEFAULT CASE
 571         CAMG    AB,[-3,,0]      ; SKIP IF OK ARGS
 572         JRST    TMA
 573         PUSHJ   P,OKFRT         ; A FRAME OR SIMILAR THING?
 574         JRST    WTYP1
 575
 576 FRM1:   PUSHJ   P,CFRAME        ; GO TO INTERNAL
 577         JRST    FINIS
 578
 579 CFRAME: JUMPN   A,FRM2          ; ARG SUPPLIED?
 580         MOVE    B,IMQUOTE LER,[LERR ]INTRUP
 581         PUSHJ   P,ILVAL
 582         JRST    FRM3
 583 FRM2:   PUSHJ   P,CHPROC        ; CHECK FOR PROCESS
 584         PUSH    TP,A
 585         PUSH    TP,B
 586         MOVEI   B,-1(TP)        ; POINT TO SLOT
 587         PUSHJ   P,CHFRM         ; CHECK IT
 588         MOVE    C,(TP)          ; GET FRAME BACK
 589         MOVE    B,OTBSAV(C)     ;GET PREVIOUS FRAME
 590         SUB     TP,[2,,2]
 591         TRNN    B,-1            ; SKIP IF OK
 592         JRST    TOPLOSE
 593
 594 FRM3:   JUMPN   B,FRM4  ; JUMP IF WINNER
 595         MOVE    B,IMQUOTE THIS-PROCESS
 596         PUSHJ   P,ILVAL         ; GET PROCESS OF INTEREST
 597         GETYP   A,A             ; CHECK IT
 598         CAIN    A,TUNBOU
 599         MOVE    B,PVSTOR+1      ; USE CURRENT
 600         MOVEI   A,PVLNT*2+1(B)  ; POINT TO DOPE WORDS
 601         MOVE    B,TBINIT+1(B)   ; AND BASE FRAME
 602 FRM4:   HLL     B,OTBSAV(B)     ;TIME
 603         HRLI    A,TFRAME
 604         POPJ    P,
 605
 606 OKFRT:  AOS     (P)             ;ASSUME WINNAGE
 607         GETYP   0,(AB)
 608         MOVE    A,(AB)
 609         MOVE    B,1(AB)
 610         CAIE    0,TFRAME
 611         CAIN    0,TENV
 612         POPJ    P,
 613         CAIE    0,TPVP
 614         CAIN    0,TACT
 615         POPJ    P,
 616         SOS     (P)
 617         POPJ    P,
 618
 619 CHPROC: GETYP   0,A             ; TYPE
 620         CAIE    0,TPVP
 621         POPJ    P,              ; OK
 622         MOVEI   A,PVLNT*2+1(B)
 623         CAMN    B,PVSTOR+1      ; THIS PROCESS?
 624         JRST    CHPRO1
 625         MOVE    B,TBSTO+1(B)
 626         JRST    FRM4
 627
 628 CHPRO1: MOVE    B,OTBSAV(TB)
 629         JRST    FRM4
 630
 631 ; FUNCTION TO RETURN ARGS TUPLE FOR A FRAME
 632
 633 MFUNCTION       ARGS,SUBR
 634         ENTRY   1
 635         PUSHJ   P,OKFRT         ; CHECK FRAME TYPE
 636         JRST    WTYP1
 637         PUSHJ   P,CARGS
 638         JRST    FINIS
 639
 640 CARGS:  PUSHJ   P,CHPROC
 641         PUSH    TP,A
 642         PUSH    TP,B
 643         MOVEI   B,-1(TP)        ; POINT TO FRAME SLOT
 644         PUSHJ   P,CHFRM         ; AND CHECK FOR VALIDITY
 645         MOVE    C,(TP)          ; FRAME BACK
 646         MOVSI   A,TARGS
 647 CARGS1: GETYP   0,FSAV(C)       ; IS THIS A FUNNY ONE
 648         CAIE    0,TCBLK         ; SKIP IF FUNNY
 649         JRST    .+3             ; NO NORMAL
 650         MOVE    C,OTBSAV(C)     ; ASSOCIATE WITH PREVIOUS FRAME
 651         JRST    CARGS1
 652         HLR     A,OTBSAV(C)     ; TIME IT AND
 653         MOVE    B,ABSAV(C)      ; GET POINTER
 654         SUB     TP,[2,,2]       ; FLUSH CRAP
 655         POPJ    P,
 656
 657 ; FUNCTION TO RETURN FUNCTION ASSOCIATED WITH A FRAME
 658
 659 MFUNCTION FUNCT,SUBR
 660         ENTRY   1       ; FRAME ARGUMENT
 661         PUSHJ   P,OKFRT         ; CHECK TYPE
 662         JRST    WTYP1
 663         PUSHJ   P,CFUNCT
 664         JRST    FINIS
 665
 666 CFUNCT: PUSHJ   P,CHPROC
 667         PUSH    TP,A
 668         PUSH    TP,B
 669         MOVEI   B,-1(TP)
 670         PUSHJ   P,CHFRM         ; CHECK IT
 671         MOVE    C,(TP)          ; RESTORE FRAME
 672         HRRZ    A,FSAV(C)       ;FUNCTION POINTER
 673         CAIL    A,HIBOT
 674         SKIPA   B,@-1(A)        ;NO, GET SUBR'S NAME POINTER
 675         MOVE    B,(A)+3         ;YES, GET RSUBR'S NAME ENTRY
 676         MOVSI   A,TATOM
 677         SUB     TP,[2,,2]
 678         POPJ    P,
 679
 680 BADFRAME:
 681         ERRUUO  EQUOTE FRAME-NO-LONGER-EXISTS
 682
 683
 684 TOPLOSE:
 685         ERRUUO  EQUOTE TOP-LEVEL-FRAME
 686
 687
 688 \f
 689 \f
 690 ; ROUTINE TO HANG INDEFINITELY WITH INTERRUPTS ENABLED
 691
 692 MFUNCTION       HANG,SUBR
 693
 694         ENTRY
 695
 696         JUMPGE  AB,HANG1        ; NO PREDICATE
 697         CAMGE   AB,[-3,,]
 698         JRST    TMA
 699         PUSH    TP,(AB)
 700         PUSH    TP,1(AB)
 701         PUSHJ   P,CHKPRD
 702 REHANG: MOVE    A,[PUSHJ P,CHKPRH]
 703         MOVEM   A,ONINT         ; CHECK PREDICATE AFTER ANY INTERRUPT
 704 HANG1:  ENABLE                  ;LET OURSELVES BE INTERRUPTED OUT
 705         PUSHJ   P,%HANG
 706         DISABLE                 ;PREVENT INTERRUPTS AT RANDOM TIMES
 707         SETZM   ONINT
 708         MOVE    A,$TATOM
 709         MOVE    B,IMQUOTE T
 710         JRST    FINIS
 711
 712
 713 ; ROUTINE TO SLEEP FOR POSITIVE NUMBER OF SECONDS WITH INTERRUPTS ENABLED
 714 ; ARGUMENT SHOULD BE OF TYPE FIX OR FLOAT AND NON-NEGATIVE
 715
 716 MFUNCTION       SLEEP,SUBR
 717
 718         ENTRY
 719
 720         JUMPGE  AB,TFA
 721         CAML    AB,[-3,,]
 722         JRST    SLEEP1
 723         CAMGE   AB,[-5,,]
 724         JRST    TMA
 725         PUSH    TP,2(AB)
 726         PUSH    TP,3(AB)
 727         PUSHJ   P,CHKPRD
 728 SLEEP1: GETYP   0,(AB)
 729         CAIE    0,TFIX
 730         JRST    .+5
 731         MOVE    B,1(AB)
 732         JUMPL   B,OUTRNG        ;ARG SHOULDNT BE NEGATIVE
 733         IMULI   B,30.           ;CONVERT TO # OF THIRTIETHS OF A SECOND
 734         JRST    SLEEPR          ;GO SLEEP
 735         CAIE    0,TFLOAT        ;IF IT WASNT FIX MAKE SURE IT IS FLOAT
 736         JRST    WTYP1           ;WRONG TYPE ARG
 737         MOVE    B,1(AB)
 738         FMPR    B,[30.0]        ;CONVERT TO FLOATING # OF THIRTIETHS OF A SECOND
 739         MULI    B,400           ;KLUDGE TO FIX IT
 740         TSC     B,B
 741         ASH     C,(B)-243
 742         MOVE    B,C             ;MOVE THE FIXED NUMBER INTO B
 743         JUMPL   B,OUTRNG        ;CHECK TO SEE THAT WE HAVE POSITIVE NUMBER
 744 SLEEPR: MOVE    A,B
 745 RESLEE: MOVE    B,[PUSHJ P,CHKPRS]
 746         CAMGE   AB,[-3,,]
 747         MOVEM   B,ONINT
 748         ENABLE
 749         PUSHJ   P,%SLEEP
 750         DISABLE
 751         SETZM   ONINT
 752         MOVE    A,$TATOM
 753         MOVE    B,IMQUOTE T
 754         JRST    FINIS
 755
 756 CHKPRH: PUSH    P,B
 757         MOVEI   B,HANGP
 758         JRST    .+3
 759
 760 CHKPRS: PUSH    P,B
 761         MOVEI   B,SLEEPP
 762         HRRM    B,LCKINT
 763         SETZM   ONINT           ; TURN OFF FEATURE FOR NOW
 764         POP     P,B
 765         POPJ    P,
 766
 767 HANGP:  SKIPA   B,[REHANG]
 768 SLEEPP: MOVEI   B,RESLEE
 769         PUSH    P,B
 770 CHKPRD: PUSH    P,A
 771         DISABLE
 772         PUSH    TP,(TB)
 773         PUSH    TP,1(TB)
 774         MCALL   1,EVAL
 775         GETYP   0,A
 776         CAIE    0,TFALSE
 777         JRST    FINIS
 778         POP     P,A
 779         POPJ    P,
 780
 781 MFUNCTION       VALRET,SUBR
 782 ; SUBR TO VALRET A STRING TO SUPERIOR ITS PROCESS
 783
 784         ENTRY   1
 785         GETYP   A,(AB)          ; GET TYPE OF ARGUMENT
 786         CAIN    A,TFIX          ; FIX?
 787          JRST   VALRT1
 788         CAIE    A,TCHSTR        ; IS IT A CHR STRING?
 789         JRST    WTYP1           ; NO...ERROR WRONG TYPE
 790         PUSHJ   P,CSTACK        ; COPY THE CHR STRING TO THE STACK
 791                                         ; CSTACK IS IN ATOMHK
 792         MOVEI   B,0             ; ASCIZ TERMINATOR
 793         EXCH    B,(P)           ; STORE AND RETRIEVE COUNT
 794
 795 ; CALCULATE THE BEGINNING ADDR OF THE STRING
 796         MOVEI   A,-1(P)         ; GET ADDR OF TOP OF STACK
 797         SUBI    A,-1(B)         ; GET STARTING ADDR
 798         PUSHJ   P,%VALRE        ; PASS UP TO MONITOR
 799         JRST    IFALSE          ; IF HE RETURNS, RETURN FALSE
 800
 801 VALRT1: MOVE    A,1(AB)
 802         PUSHJ   P,%VALFI
 803         JRST    IFALSE
 804
 805 MFUNCTION       LOGOUT,SUBR
 806
 807 ; SUBR TO DO A .LOGOUT (VALID ONLY AT TOP LEVEL)
 808         ENTRY   0
 809         PUSHJ   P,%TOPLQ        ; SKIP IF AT TOP LEVEL
 810         JRST    IFALSE
 811         PUSHJ   P,CLOSAL
 812         PUSHJ   P,%LOGOUT       ; TRY TO FLUSH
 813         JRST    IFALSE          ; COULDN'T DO IT...RETURN FALSE
 814
 815 ; FUNCTS TO GET UNAME AND JNAME
 816
 817 ; GET XUNAME (REAL UNAME)
 818 MFUNCTION XUNAME,SUBR
 819
 820         ENTRY   0
 821
 822         PUSHJ   P,%RXUNA
 823          JRST   RSUJNM
 824         JRST    FINIS           ; 10X ROUTINES SKIP
 825
 826 MFUNCTION UNAME,SUBR
 827
 828         ENTRY   0
 829
 830         PUSHJ   P,%RUNAM
 831          JRST   RSUJNM
 832         JRST    FINIS
 833
 834 ; REAL JNAME
 835 MFUNCTION XJNAME,SUBR
 836
 837         ENTRY   0
 838
 839         PUSHJ   P,%RXJNA
 840         JRST    RSUJNM
 841
 842 MFUNCTION JNAME,SUBR
 843
 844         ENTRY   0
 845
 846         PUSHJ   P,%RJNAM
 847         JRST    RSUJNM
 848
 849 ; FUNCTION TO SET AND READ GLOBAL SNAME
 850
 851 MFUNCTION SNAME,SUBR
 852
 853         ENTRY
 854
 855         JUMPGE  AB,SNAME1
 856         CAMG    AB,[-3,,]
 857         JRST    TMA
 858         GETYP   A,(AB)          ; ARG MUST BE STRING
 859         CAIE    A,TCHSTR
 860         JRST    WTYP1
 861         PUSH    TP,$TATOM
 862         PUSH    TP,IMQUOTE SNM
 863         PUSH    TP,(AB)
 864         PUSH    TP,1(AB)
 865         MCALL   2,SETG
 866         JRST    FINIS
 867
 868 SNAME1: MOVE    B,IMQUOTE SNM
 869         PUSHJ   P,IDVAL1
 870         GETYP   0,A
 871         CAIN    0,TCHSTR
 872         JRST    FINIS
 873         MOVE    A,$TCHSTR
 874         MOVE    B,CHQUOTE
 875         JRST    FINIS
 876
 877 RSUJNM: PUSHJ   P,6TOCHS        ; CONVERT IT
 878         JRST    FINIS
 879
 880
 881 SGSNAM: MOVE    B,IMQUOTE SNM
 882         PUSHJ   P,IDVAL1
 883         GETYP   0,A
 884         CAIE    0,TCHSTR
 885         JRST    SGSN1
 886
 887         PUSH    TP,A
 888         PUSH    TP,B
 889         PUSHJ   P,STRTO6
 890         POP     P,A
 891         SUB     TP,[2,,2]
 892         JRST    .+2
 893
 894 SGSN1:  MOVEI   A,0
 895         PUSHJ   P,%SSNAM        ; SET SNAME IN SYSTEM
 896         POPJ    P,
 897
 898 \f
 899
 900 ;THIS SUBROUTINE ALLOCATES A NEW PROCESS
 901 ;TAKES TP-STACK SIZE (2*WORDS) IN A AND P-STACK SIZE (WORDS) IN B
 902 ;IS CALLED BY PUSHJ P,. RETURNS IN A AND B A NEW PROCESS.
 903
 904 ICR:    PUSH    P,A
 905         PUSH    P,B
 906         MOVEI   A,PVLNT         ;SETUP CALL TO VECTOR FOR PVP
 907         PUSHJ   P,IVECT         ;GOBBLE A VECTOR
 908         HRLI    C,PVBASE        ;SETUP A BLT POINTER
 909         HRRI    C,(B)           ;GET INTO ADDRESS
 910         BLT     C,PVLNT*2-1(B)  ;COPY A PROTOTYPE INTO NEW PVP
 911         MOVSI   C,400000+SPVP+.VECT.    ;SET SPECIAL TYPE
 912         MOVEM   C,PVLNT*2(B)    ;CLOBBER IT IN
 913         PUSH    TP,A            ;SAVE THE RESULTS OF VECTOR
 914         PUSH    TP,B
 915
 916         PUSH    TP,$TFIX        ;GET A UNIFORM VECTOR
 917         POP     P,B
 918         PUSH    TP,B
 919         MCALL   1,UVECTOR
 920         ADD     B,[PDLBUF-2,,-1]        ;FUDGE WITH BUFFER
 921         MOVE    C,(TP)          ;REGOBBLE PROCESS POINTER
 922         MOVEM   B,PSTO+1(C)     ;STORE IN ALL HOMES
 923         MOVEM   B,PBASE+1(C)
 924
 925
 926         POP     P,A             ;PREPARE TO CREATE A TEMPORARY PDL
 927         PUSHJ   P,IVECT         ;GET THE TEMP PDL
 928         ADD     B,[PDLBUF,,0]   ;PDL GROWTH HACK
 929         MOVE    C,(TP)          ;RE-GOBBLE NEW PVP
 930         SUB     B,[1,,1]        ;FIX FOR STACK
 931         MOVEM   B,TPBASE+1(C)
 932
 933 ;SETUP INITIAL BINDING
 934
 935         PUSH    B,$TBIND
 936         MOVEM   B,SPBASE+1(C)   ;SAVE AS BASE OF SP
 937         MOVEM   B,SPSTO+1(C)    ;AND CURRENT THEREOF
 938         MOVEM   B,CURFCN+1(C)   ; AND AS CURRENT FCN FOR SPEC/UNSPEC LOGIC
 939         PUSH    B,IMQUOTE THIS-PROCESS
 940         PUSH    B,$TPVP ;GIVE IT PROCESS AS VALUE
 941         PUSH    B,C
 942         ADD     B,[2,,2]        ;FINISH FRAME
 943         MOVEM   B,TPSTO+1(C)    ;MAKE THIS THE CURRENT STACK POINTER
 944         MOVEM   C,PVPSTO+1(C)   ;SAVE THE NEW PVP ITSELF
 945         AOS     A,IDPROC                ;GOBBLE A UNIQUE PROCESS I.D.
 946         MOVEM   A,PROCID+1(C)   ;SAVE THAT ALSO
 947         AOS     A,PTIME         ; GET A UNIQUE BINDING ID
 948         MOVEM   A,BINDID+1(C)
 949
 950         MOVSI   A,TPVP          ;CLOBBER THE TYPE
 951         MOVE    B,(TP)          ;AND POINTER TO PROCESS
 952         SUB     TP,[2,,2]
 953         POPJ    P,
 954
 955 ;MINI ROUTINE TO CALL VECTOR WITH COUNT IN A
 956
 957 IVECT:  PUSH    TP,$TFIX
 958         PUSH    TP,A
 959         MCALL   1,VECTOR        ;GOBBLE THE VECTOR
 960         POPJ    P,
 961
 962
 963 ;SUBROUTINE TO SWAP A PROCESS IN
 964 ;CALLED WITH JSP A,SWAP AND NEW PVP IN B
 965
 966 SWAP:                           ;FIRST STORE ALL THE ACS
 967
 968         MOVE    PVP,PVSTOR+1
 969         MOVE    SP,$TSP         ; STORE SPSAVE
 970         MOVEM   SP,SPSTO(PVP)
 971         MOVE    SP,SPSTOR+1
 972         IRP     A,,[SP,AB,TB,TP,P,M,R,FRM]
 973         MOVEM   A,A!STO+1(PVP)
 974         TERMIN
 975
 976         SETOM   1(TP)           ; FENCE POST MAIN STACK
 977         MOVEM   TP,TPSAV(TB)    ; CORRECT FRAME
 978         SETZM   PSAV(TB)        ; CLEAN UP CURRENT FRAME
 979         SETZM   SPSAV(TB)
 980         SETZM   PCSAV(TB)
 981
 982         MOVE    E,PVP   ;RETURN OLD PROCESS IN E
 983         MOVE    PVP,D   ;AND MAKE NEW ONE BE D
 984         MOVEM   PVP,PVSTOR+1
 985
 986 SWAPIN:
 987         ;NOW RESTORE NEW PROCESSES AC'S
 988
 989         MOVE    PVP,PVSTOR+1
 990         IRP     A,,[AB,TB,SP,TP,P,M,R,FRM]
 991         MOVE    A,A!STO+1(PVP)
 992         TERMIN
 993
 994         SETZM   SPSTO(PVP)
 995         MOVEM   SP,SPSTOR+1
 996         JRST    (C)             ;AND RETURN
 997
 998
 999 \f
1000
1001 ;SUBRS ASSOCIATED WITH TYPES
1002
1003 ;TYPE (ITYPE) ARE FUNCTIONS TO RETURN THE ATOMIC NAME OF THE
1004 ;TYPE OF A GOODIE.  TYPE TAKES ITS ARGS ON AP AND RETURNS IN A AND B.
1005 ;ITYPE TAKES ITS ARGS IN A AND B AND RETURNS IN SAME (B=0) FOR INVALID
1006 ;TYPECODE.
1007 MFUNCTION TYPE,SUBR
1008
1009         ENTRY   1
1010         GETYP   A,(AB)          ;TYPE INTO A
1011 TYPE1:  PUSHJ   P,ITYPE         ;GO TO INTERNAL
1012         JUMPN   B,FINIS         ;GOOD RETURN
1013 TYPERR: ERRUUO  EQUOTE TYPE-UNDEFINED
1014
1015 CITYPE: GETYP   A,A             ; GET TYPE FOR COMPILER CALL
1016 ITYPE:  LSH     A,1             ;TIMES 2
1017         HRLS    A               ;TO BOTH SIDES
1018         ADD     A,TYPVEC+1      ;GET ACTUAL LOCATION
1019         JUMPGE  A,TYPERR        ;LOST, TYPE OUT OF BOUNDS
1020         MOVE    B,1(A)          ;PICKUP TYPE
1021         HLLZ    A,(A)
1022         POPJ    P,
1023
1024 ; PREDICATE -- IS OBJECT OF TYPE SPECIFIED
1025
1026 MFUNCTION %TYPEQ,SUBR,[TYPE?]
1027
1028         ENTRY
1029
1030         MOVE    D,AB            ; GET ARGS
1031         ADD     D,[2,,2]
1032         JUMPGE  D,TFA
1033         MOVE    A,(AB)
1034         HLRE    C,D
1035         MOVMS   C
1036         ASH     C,-1            ; FUDGE
1037         PUSHJ   P,ITYPQ         ; GO INTERNAL
1038         JFCL
1039         JRST    FINIS
1040
1041 ITYPQ:  GETYP   A,A             ; OBJECT
1042         PUSHJ   P,ITYPE
1043 TYPEQ0: SOJL    C,CIFALS
1044         GETYP   0,(D)
1045         CAIE    0,TATOM         ; Type name must be an atom
1046         JRST    WRONGT
1047         CAMN    B,1(D)          ; Same as the OBJECT?
1048         JRST    CPOPJ1          ; Yes, return type name
1049         ADD     D,[2,,2]
1050         JRST    TYPEQ0          ; No, continue comparing
1051
1052 CIFALS: MOVEI   B,0
1053         MOVSI   A,TFALSE
1054         POPJ    P,
1055
1056 CTYPEQ: SOJE    A,CIFALS        ; TREAT NO ARGS AS FALSE
1057         MOVEI   D,1(A)          ; FIND BASE OF ARGS
1058         ASH     D,1
1059         HRLI    D,(D)
1060         SUBM    TP,D            ; D POINTS TO BASE
1061         MOVE    E,D             ; SAVE FOR TP RESTORE
1062         ADD     D,[3,,3]        ; FUDGE
1063         MOVEI   C,(A)           ; NUMBER OF TYPES
1064         MOVE    A,-2(D)
1065         PUSHJ   P,ITYPQ
1066         JFCL            ; IGNORE SKIP FOR NOW
1067         MOVE    TP,E            ; SET TP BACK
1068         JUMPL   B,CPOPJ1        ; SKIP
1069         POPJ    P,
1070 \f
1071 ; Entries to get type codes for types for fixing up RSUBRs and assembling
1072
1073 MFUNCTION %TYPEC,SUBR,[TYPE-C]
1074
1075         ENTRY
1076
1077         JUMPGE  AB,TFA
1078         GETYP   0,(AB)
1079         CAIE    0,TATOM
1080         JRST    WTYP1
1081         MOVE    B,1(AB)
1082         CAMGE   AB,[-3,,0]      ; skip if only type name given
1083         JRST    GTPTYP
1084         MOVE    C,IMQUOTE ANY
1085
1086 TYPEC1: PUSHJ   P,CTYPEC        ; go to internal
1087         JRST    FINIS
1088
1089 GTPTYP: CAMGE   AB,[-5,,0]
1090         JRST    TMA
1091         GETYP   0,2(AB)
1092         CAIE    0,TATOM
1093         JRST    WTYP2
1094         MOVE    C,3(AB)
1095         JRST    TYPEC1
1096
1097 CTYPEC: PUSH    P,C             ; save primtype checker
1098         PUSHJ   P,TYPFND        ; search type vector
1099         JRST    CTPEC2          ; create the poor loser
1100         POP     P,B
1101         CAMN    B,IMQUOTE ANY
1102         JRST    CTPEC1
1103         CAMN    B,IMQUOTE TEMPLATE
1104         JRST    TCHK
1105         PUSH    P,D
1106         HRRZ    A,(A)
1107         ANDI    A,SATMSK
1108         PUSH    P,A
1109         PUSHJ   P,TYPLOO
1110         HRRZ    0,(A)
1111         ANDI    0,SATMSK
1112         CAME    0,(P)
1113         JRST    TYPDIF
1114         MOVE    D,-1(P)
1115         SUB     P,[2,,2]
1116 CTPEC1: MOVEI   B,(D)
1117         MOVSI   A,TTYPEC
1118         POPJ    P,
1119 TCHK:   PUSH    P,D             ; SAVE TYPE
1120         MOVE    A,D             ; GO TO SAT
1121         PUSHJ   P,SAT
1122         CAIG    A,NUMSAT        ; SKIP IF A TEMPLATE
1123         JRST    TYPDIF
1124         POP     P,D             ; RESTORE TYPE
1125         JRST    CTPEC1
1126
1127 CTPEC2: POP     P,C             ; GET BACK PRIMTYPE
1128         SUBM    M,(P)
1129         PUSH    TP,$TATOM
1130         PUSH    TP,B
1131         CAMN    C,IMQUOTE ANY
1132         JRST    CTPEC3
1133         PUSH    TP,$TATOM
1134         PUSH    TP,C
1135         MCALL   2,NEWTYPE               ; CREATE THE POOR GUY
1136         MOVE    C,IMQUOTE ANY
1137         SUBM    M,(P)           ; UNRELATIVIZE
1138         JRST    CTYPEC
1139
1140 CTPEC3: HRRZ    0,FSAV(TB)
1141         CAIE    0,%TYPEC
1142         CAIN    0,%TYPEW
1143         JRST    TYPERR
1144
1145         MCALL   1,%TYPEC
1146         JRST    MPOPJ
1147
1148 MFUNCTION %TYPEW,SUBR,[TYPE-W]
1149
1150         ENTRY
1151
1152         JUMPGE  AB,TFA
1153         GETYP   0,(AB)
1154         CAIE    0,TATOM
1155         JRST    WTYP1
1156         MOVEI   D,0
1157         MOVE    C,IMQUOTE ANY
1158         MOVE    B,1(AB)
1159         CAMGE   AB,[-3,,0]
1160         JRST    CTYPW1
1161
1162 CTYPW3: PUSHJ   P,CTYPEW
1163         JRST    FINIS
1164
1165 CTYPW1: GETYP   0,2(AB)
1166         CAIE    0,TATOM
1167         JRST    WTYP2
1168         CAMGE   AB,[-5,,0]      ; JUMP IF RH IS GIVEN
1169         JRST    CTYPW2
1170 CTYPW5: MOVE    C,3(AB)
1171         JRST    CTYPW3
1172
1173 CTYPW2: CAMGE   AB,[-7,,0]
1174         JRST    TMA
1175         GETYP   0,4(AB)
1176         CAIE    0,TFIX
1177         JRST    WRONGT
1178         MOVE    D,5(AB)
1179         JRST    CTYPW5
1180
1181 CTYPEW: PUSH    P,D
1182         PUSHJ   P,CTYPEC        ; GET CODE IN B
1183         POP     P,B
1184         HRLI    B,(D)
1185         MOVSI   A,TTYPEW
1186         POPJ    P,
1187
1188 MFUNCTION %VTYPE,SUBR,[VALID-TYPE?]
1189
1190         ENTRY   1
1191
1192         GETYP   0,(AB)
1193         CAIE    0,TATOM
1194         JRST    WTYP1
1195         MOVE    B,1(AB)
1196
1197         PUSHJ   P,CVTYPE
1198         JFCL
1199         JRST    FINIS
1200
1201 CVTYPE: PUSHJ   P,TYPFND                ; LOOK IT UP
1202         JRST    PFALS
1203
1204         MOVEI   B,(D)
1205         MOVSI   A,TTYPEC
1206         JRST    CPOPJ1
1207
1208 PFALS:  MOVEI   B,0
1209         MOVSI   A,TFALSE
1210         POPJ    P,
1211 \f
1212 ;PRIMTTYPE  RETURNS THE TYPE ATOM OF A PRIMITIVE TYPE IN A CLASS
1213
1214 STBL:   REPEAT NUMSAT,SETZ MQUOTE INTERNAL-TYPE
1215
1216 LOC STBL
1217
1218 IRP A,,[[1WORD,WORD],[2WORD,LIST],[NWORD,UVECTOR],[2NWORD,VECTOR],[STORE,STORAGE]
1219 [ARGS,TUPLE],[FRAME,FRAME],[ATOM,ATOM],[LOCID,LOCD],[CHSTR,STRING],[OFFS,OFFSET,1]
1220 [PVP,PROCESS,1],[ASOC,ASOC,1],[LOCA,LOCA],[LOCS,LOCS],[LOCU,LOCU],[LOCV,LOCV]
1221 [LOCL,LOCL],[LOCN,LOCAS],[LOCT,LOCT,1],[LOCR,LOCR],[LOCB,LOCB,1],[BYTE,BYTES,1]]
1222 IRP B,C,[A]
1223 LOC STBL+S!B
1224 IRP X,Y,[C]
1225 IFSE [Y],SETZ IMQUOTE X
1226 IFSN [Y],SETZ MQUOTE X
1227 .ISTOP
1228 TERMIN
1229 .ISTOP
1230
1231 TERMIN
1232 TERMIN
1233
1234 LOC STBL+NUMSAT+1
1235
1236
1237 MFUNCTION TYPEPRIM,SUBR
1238
1239         ENTRY   1
1240         GETYP   A,(AB)
1241         CAIE    A,TATOM
1242         JRST    NOTATOM
1243         MOVE    B,1(AB)
1244         PUSHJ   P,CTYPEP
1245         JRST    FINIS
1246
1247 CTYPEP: PUSHJ   P,TYPLOO        ; CONVERT ATOM TO CODE
1248         HRRZ    A,(A)           ; SAT TO A
1249         ANDI    A,SATMSK
1250         JRST    PTYP1
1251
1252 MFUNCTION PTSATC,SUBR,[PRIMTYPE-C]
1253
1254         ENTRY   1
1255
1256         GETYP   A,(AB)
1257         CAIE    A,TATOM
1258         JRST    WTYP1
1259         MOVE    B,1(AB)
1260         PUSHJ   P,CPRTYC
1261         JRST    FINIS
1262
1263 CPRTYC: PUSHJ   P,TYPLOO
1264         MOVE    B,(A)
1265         ANDI    B,SATMSK
1266         MOVSI   A,TSATC
1267         POPJ    P,
1268
1269
1270 IMFUNCTION PRIMTYPE,SUBR
1271
1272         ENTRY   1
1273
1274         MOVE    A,(AB)          ;GET TYPE
1275         PUSHJ   P,CPTYPE
1276         JRST    FINIS
1277
1278 CPTYPE: GETYP   A,A
1279         PUSHJ   P,SAT           ;GET SAT
1280 PTYP1:  JUMPE   A,TYPERR
1281         MOVE    B,IMQUOTE TEMPLATE
1282         CAIG    A,NUMSAT        ; IF BIG SAT, THEN TEMPLATE
1283         MOVE    B,@STBL(A)
1284         MOVSI   A,TATOM
1285         POPJ    P,
1286 \f
1287
1288 ; RSUBR MAKES A VECTOR INTO AN OBJECT OF TYPE RSUBR, ALSO SLIGHTLY MUNGING IT
1289
1290 IMFUNCTION RSUBR,SUBR
1291         ENTRY   1
1292
1293         GETYP   A,(AB)
1294         CAIE    A,TVEC          ; MUST BE VECTOR
1295         JRST    WTYP1
1296         MOVE    B,1(AB)         ; GET IT
1297         GETYP   A,(B)           ; CHECK 1ST ELEMENTS TYPE
1298         CAIN    A,TPCODE        ; PURE CODE
1299         JRST    .+3
1300         CAIE    A,TCODE
1301         JRST    NRSUBR
1302         HLRM    B,(B)           ; CLOBEER SPECIAL COUNT FIELD
1303         MOVSI   A,TRSUBR
1304         JRST    FINIS
1305
1306 NRSUBR: ERRUUO  EQUOTE FIRST-ELEMENT-OF-VECTOR-NOT-CODE
1307
1308 ; ROUTINE TO GENERATE ENTRYY OTHER THAN FIRST TO RSUBRR
1309
1310 IMFUNCTION MENTRY,SUBR,[RSUBR-ENTRY]
1311
1312         ENTRY   2
1313
1314         GETYP   0,(AB)          ; TYPE OF ARG
1315         CAIE    0,TVEC          ; BETTER BE VECTOR
1316         JRST    WTYP1
1317         GETYP   0,2(AB)
1318         CAIE    0,TFIX
1319         JRST    WTYP2
1320         MOVE    B,1(AB)         ; GET VECTOR
1321         CAML    B,[-3,,0]
1322         JRST    BENTRY
1323         GETYP   0,(B)           ; FIRST ELEMENT
1324         CAIE    0,TRSUBR
1325         JRST    MENTR1
1326 MENTR2: GETYP   0,2(B)
1327         CAIE    0,TATOM
1328         JRST    BENTRY
1329         MOVE    C,3(AB)
1330         HRRM    C,2(B)          ; OFFSET INTO VECTOR
1331         HLRM    B,(B)
1332         MOVSI   A,TENTER
1333         JRST    FINIS
1334
1335 MENTR1: CAIE    0,TATOM
1336         JRST    BENTRY
1337         MOVE    B,1(B)          ; GET ATOM
1338         PUSHJ   P,IGVAL         ; GET VAL
1339         GETYP   0,A
1340         CAIE    0,TRSUBR
1341         JRST    BENTRY
1342         MOVE    C,1(AB)         ; RESTORE B
1343         MOVEM   A,(C)
1344         MOVEM   B,1(C)
1345         MOVE    B,C
1346         JRST    MENTR2
1347
1348 BENTRY: ERRUUO  EQUOTE BAD-VECTOR
1349
1350 ; SUBR TO GET ENTRIES OFFSET
1351
1352 MFUNCTION LENTRY,SUBR,[ENTRY-LOC]
1353
1354         ENTRY   1
1355
1356         GETYP   0,(AB)
1357         CAIE    0,TENTER
1358         JRST    WTYP1
1359         MOVE    B,1(AB)
1360         HRRZ    B,2(B)
1361         MOVSI   A,TFIX
1362         JRST    FINIS
1363
1364 ; RETURN FALSE
1365
1366 RTFALS: MOVSI   A,TFALSE
1367         MOVEI   B,0
1368         POPJ    P,
1369
1370 ;SUBROUTINE CALL FOR RSUBRs
1371 RCALL:  SUBM    M,(P)           ;CALCULATE PC's OFFSET IN THE RSUBR
1372         HRLI    0,400000        ; DONT LOSE IN MULTI SEG MODE
1373
1374         PUSHJ   P,@0            ;GO TO THE PROPER SUBROUTINE
1375         SUBM    M,(P)           ;RECONSTITUTE THE RSUBR's PC
1376         POPJ    P,
1377
1378
1379
1380 ;CHTYPE TAKES TWO ARGUMENTS.  ANY GOODIE AND A AN ATOMIC TYPE NAME
1381 ;IT CHECKS THE STORAGE ALLOCATION TYPES OF THE TWO ARE THE SAME AND
1382 ;IF THEY ARE CHANGES THE TYPE OF THE FIRST TO THAT NAME D IN THE SECOND
1383
1384 MFUNCTION CHTYPE,SUBR
1385
1386         ENTRY   2
1387         GETYP   A,2(AB)         ;FIRST CHECK THAT ARG 2 IS AN ATOM
1388         CAIE    A,TATOM
1389         JRST    NOTATOM
1390         MOVE    B,3(AB)         ;AND TYPE NAME
1391         PUSHJ   P,TYPLOO                ;GO LOOKUP TYPE
1392 TFOUND: HRRZ    B,(A)           ;GOBBLE THE SAT
1393         TRNE    B,CHBIT         ; SKIP IF CHTYPABLE
1394         JRST    CANTCH
1395         TRNE    B,TMPLBT        ; TEMPLAT
1396         HRLI    B,-1
1397         AND     B,[-1,,SATMSK]
1398         GETYP   A,(AB)          ;NOW GET TYPE TO HACK
1399         PUSHJ   P,SAT           ;FIND OUT ITS SAT
1400         JUMPE   A,TYPERR        ;COMPLAIN
1401         CAILE   A,NUMSAT
1402         JRST    CHTMPL          ; JUMP IF TEMPLATE DATA
1403         CAIE    A,(B)           ;DO THEY AGREE?
1404         JRST    TYPDIF          ;NO, COMPLAIN
1405 CHTMP1: MOVSI   A,(D)           ;GET NEW TYPE
1406         HRR     A,(AB)          ; FOR DEFERRED GOODIES
1407         JUMPL   B,CHMATC        ; CHECK IT
1408         MOVE    B,1(AB)         ;AND VALUE
1409         JRST    FINIS
1410
1411 CHTMPL: MOVE    E,1(AB)         ; GET ARG
1412         HLRZ    A,(E)
1413         ANDI    A,SATMSK
1414         MOVE    0,3(AB)         ; SEE IF TO "TEMPLATE"
1415         CAMN    0,IMQUOTE TEMPLATE
1416         JRST    CHTMP1
1417         TLNN    E,-1            ; SKIP IF RESTED
1418         CAIE    A,(B)
1419         JRST    TYPDIF
1420         JRST    CHTMP1
1421
1422 CHMATC: PUSH    TP,A
1423         PUSH    TP,1(AB)        ; SAVE GOODIE
1424         MOVSI   A,TATOM
1425         MOVE    B,3(AB)
1426         MOVSI   C,TATOM
1427         MOVE    D,IMQUOTE DECL
1428         PUSHJ   P,IGET          ; FIND THE DECL
1429         PUSH    TP,A
1430         PUSH    TP,B
1431         MOVE    C,(AB)
1432         MOVE    D,1(AB)         ; NOW GGO TO MATCH
1433         PUSHJ   P,TMATCH
1434         JRST    CHMAT1
1435         SUB     TP,[2,,2]
1436 CHMAT2: POP     TP,B
1437         POP     TP,A
1438         JRST    FINIS
1439
1440 CHMAT1: POP     TP,B
1441         POP     TP,A
1442         MOVE    C,-1(TP)
1443         MOVE    D,(TP)
1444         PUSHJ   P,TMATCH
1445         JRST    TMPLVI
1446         JRST    CHMAT2
1447
1448 TYPLOO: PUSHJ   P,TYPFND
1449         ERRUUO  EQUOTE BAD-TYPE-NAME
1450         POPJ    P,
1451
1452 TYPFND: HLRE    A,B             ; FIND DOPE WORDS
1453         SUBM    B,A             ; A POINTS TO IT
1454         HRRE    D,(A)           ; TYPE-CODE TO D
1455         JUMPE   D,CPOPJ
1456         ANDI    D,TYPMSK        ; FLUSH FUNNY BITS
1457         MOVEI   A,(D)
1458         ASH     A,1
1459         HRLI    A,(A)
1460         ADD     A,TYPVEC+1
1461 CPOPJ1: AOS     (P)
1462         POPJ    P,
1463
1464
1465 REPEAT 0,[
1466         MOVE    A,TYPVEC+1      ;GOBBLE DOWN TYPE VECTOR
1467         MOVEI   D,0             ;INITIALIZE TYPE COUNTER
1468 TLOOK:  CAMN    B,1(A)          ;CHECK THIS ONE
1469         JRST    CPOPJ1
1470         ADDI    D,1             ;BUMP COUNTER
1471         AOBJP   A,.+2           ;COUTN DOWN ON VECTOR
1472         AOBJN   A,TLOOK
1473         POPJ    P,
1474 CPOPJ1: AOS     (P)
1475         POPJ    P,
1476 ]
1477
1478 TYPDIF: ERRUUO  EQUOTE STORAGE-TYPES-DIFFER
1479
1480
1481 TMPLVI: ERRUUO  EQUOTE DECL-VIOLATION
1482 \f
1483
1484 ; FUNCTION TO ADD A NEW TYPE TO THE WORLD WITH GIVEN PRIMITIVE TYPE
1485
1486 MFUNCTION NEWTYPE,SUBR
1487
1488         ENTRY
1489
1490         HLRZ    0,AB            ; CHEC # OF ARGS
1491         CAILE   0,-4            ; AT LEAST 2
1492         JRST    TFA
1493         CAIGE   0,-6
1494         JRST    TMA             ; NOT MORE THAN 3
1495         GETYP   A,(AB)          ; GET 1ST ARGS TYPE (SHOULD BE ATOM)
1496         GETYP   C,2(AB)         ; SAME WITH SECOND
1497         CAIN    A,TATOM         ; CHECK
1498         CAIE    C,TATOM
1499         JRST    NOTATOM
1500
1501         MOVE    B,3(AB)         ; GET PRIM TYPE NAME
1502         PUSHJ   P,TYPLOO        ; LOOK IT UP
1503         HRRZ    A,(A)           ; GOBBLE SAT
1504         ANDI    A,SATMSK
1505         HRLI    A,TATOM         ; MAKE NEW TYPE
1506         PUSH    P,A             ; AND SAVE
1507         MOVE    B,1(AB)         ; SEE IF PREV EXISTED
1508         PUSHJ   P,TYPFND
1509         JRST    NEWTOK          ; DID NOT EXIST BEFORE
1510         MOVEI   B,2(A)          ; FOR POSSIBLE TMPLAT BIT
1511         HRRZ    A,(A)           ; GET SAT
1512         HRRZ    0,(P)           ; AND PROPOSED
1513         ANDI    A,SATMSK
1514         ANDI    0,SATMSK
1515         CAIN    0,(A)           ; SKIP IF LOSER
1516         JRST    NEWTFN          ; O.K.
1517
1518         ERRUUO  EQUOTE TYPE-ALREADY-EXISTS
1519
1520 NEWTOK: POP     P,A
1521         MOVE    B,1(AB)         ; NEWTYPE NAME
1522         PUSHJ   P,INSNT         ; MUNG IN NEW TYPE
1523
1524 NEWTFN: CAML    AB,[-5,,]       ; SKIP IF TEMPLAT SUPPLIED
1525         JRST    NEWTF1
1526         MOVEI   0,TMPLBT        ; GET THE BIT
1527         IORM    0,-2(B)         ; INTO WORD
1528         MOVE    A,(AB)          ; GET TYPE NAME
1529         MOVE    B,1(AB)
1530         MOVSI   C,TATOM
1531         MOVE    D,IMQUOTE DECL
1532         PUSH    TP,4(AB)        ; GET TEMLAT
1533         PUSH    TP,5(AB)
1534         PUSHJ   P,IPUT
1535 NEWTF1: MOVE    A,(AB)
1536         MOVE    B,1(AB)         ; RETURN NAME
1537         JRST    FINIS
1538
1539 ; SET  UP GROWTH FIELDS
1540
1541 IGROWT: SKIPA   A,[111100,,(C)]
1542 IGROWB: MOVE    A,[001100,,(C)]
1543         HLRE    B,C
1544         SUB     C,B             ; POINT TO DOPE WORD
1545         MOVE    B,TYPIC ; INDICATED GROW BLOCK
1546         DPB     B,A
1547         POPJ    P,
1548
1549 INSNT:  PUSH    TP,A
1550         PUSH    TP,B            ; SAVE NAME OF NEWTYPE
1551         MOVE    C,TYPBOT+1      ; CHECK GROWTH NEED
1552         CAMGE   C,TYPVEC+1
1553         JRST    ADDIT           ; STILL ROOM
1554 GAGN:   PUSHJ   P,IGROWB        ; SETUP BOTTOM GROWTH
1555         SKIPE   C,EVATYP+1
1556         PUSHJ   P,IGROWT        ; SET UP TOP GROWTH
1557         SKIPE   C,APLTYP+1
1558         PUSHJ   P,IGROWT
1559         SKIPE   C,PRNTYP+1
1560         PUSHJ   P,IGROWT
1561         MOVE    C,[11.,,5]      ; SET UP INDICATOR FOR AGC
1562         PUSHJ   P,AGC           ; GROW THE WORLD
1563         AOJL    A,GAGN          ; BAD AGC LOSSAGE
1564         MOVE    0,[-101,,-100]
1565         ADDM    0,TYPBOT+1      ; FIX UP POINTER
1566
1567 ADDIT:  MOVE    C,TYPVEC+1
1568         SUB     C,[2,,2]        ; ALLOCATE ROOM
1569         MOVEM   C,TYPVEC+1
1570         HLRE    B,C             ; PREPARE TO BLT
1571         SUBM    C,B             ; C POINTS DOPE WORD END
1572         HRLI    C,2(C)          ; GET BLT AC READY
1573         BLT     C,-3(B)
1574         POP     TP,-1(B)        ; CLOBBER IT IN
1575         POP     TP,-2(B)
1576         HLRE    C,TYPVEC+1      ; GET CODE
1577         MOVNS   C
1578         ASH     C,-1
1579         SUBI    C,1
1580         MOVE    D,-1(B)         ; B HAS POINTER TO TYPE VECTOR DOPE WORDS
1581         MOVEI   0,(D)
1582         CAIG    0,HIBOT         ; IS ATOM PURE?
1583          JRST   ADDNOI          ; NO, SO NO HACKING REQUIRED
1584         PUSH    P,C
1585         MOVE    B,D
1586         PUSHJ   P,IMPURIF       ; DO IMPURE OF ATOM
1587         MOVE    C,TYPVEC+1
1588         HLRE    B,C
1589         SUBM    C,B             ; RESTORE B
1590         POP     P,C
1591         MOVE    D,-1(B)         ; RESTORE D
1592 ADDNOI: HLRE    A,D
1593         SUBM    D,A
1594         TLO     C,400000
1595         HRRM    C,(A)           ; INTO "GROWTH" FIELD
1596         POPJ    P,
1597
1598 \f
1599 ; Interface to interpreter for setting up tables associated with
1600 ;       template data structures.
1601 ;       A/      <\b-name of type>\b-
1602 ;       B/      <\b-length ins>\b-
1603 ;       C/      <\b-uvector of garbage collector code or 0>
1604 ;       D/      <\b-uvector of GETTERs>\b-
1605 ;       E/      <\b-uvector of PUTTERs>\b-
1606
1607 CTMPLT: SUBM    M,(P)           ; could possibly gc during this stuff
1608         PUSH    TP,$TATOM       ; save name of type
1609         PUSH    TP,A
1610         PUSH    P,B             ; save length instr
1611         HLRE    A,TD.LNT+1      ; check for template slots left?
1612         HRRZ    B,TD.LNT+1
1613         SUB     B,A             ; point to dope words
1614         HLRZ    B,1(B)          ; get real length
1615         ADDI    A,-2(B)
1616         JUMPG   A,GOODRM        ; jump if ok
1617
1618         PUSH    TP,$TUVEC       ; save getters and putters
1619         PUSH    TP,C
1620         PUSH    TP,$TUVEC       ; save getters and putters
1621         PUSH    TP,D
1622         PUSH    TP,$TUVEC
1623         PUSH    TP,E
1624         MOVEI   A,10-2(B)       ; grow it 10 by copying remember d.w. length
1625         PUSH    P,A             ; save new length
1626         PUSHJ   P,CAFRE1        ; get frozen uvector
1627         ADD     B,[10,,10]      ; rest it down some
1628         HRL     C,TD.LNT+1      ; prepare to BLT in
1629         MOVEM   B,TD.LNT+1      ; and save as new length vector
1630         HRRI    C,(B)           ; destination
1631         ADD     B,(P)           ; final destination address
1632         BLT     C,-12(B)
1633         MOVE    A,(P)           ; length for new getters
1634         PUSHJ   P,CAFRE1
1635         HRL     C,TD.GET+1      ; get old for copy
1636         MOVEM   B,TD.GET+1
1637         PUSHJ   P,DOBLTS        ; go fixup new uvector
1638         MOVE    A,(P)           ; finally putters
1639         PUSHJ   P,CAFRE1
1640         HRL     C,TD.PUT+1
1641         MOVEM   B,TD.PUT+1
1642         PUSHJ   P,DOBLTS        ; go fixup new uvector
1643         MOVE    A,(P)           ; finally putters
1644         PUSHJ   P,CAFRE1
1645         HRL     C,TD.AGC+1
1646         MOVEM   B,TD.AGC+1
1647         PUSHJ   P,DOBLTS        ; go fixup new uvector
1648         SUB     P,[1,,1]        ; flush stack craft
1649         MOVE    E,(TP)
1650         MOVE    D,-2(TP)
1651         MOVE    C,-4(TP)                        ;GET TD.AGC
1652         SUB     TP,[6,,6]
1653
1654 GOODRM: MOVE    B,TD.LNT+1      ; move down to fit new guy
1655         SUB     B,[1,,1]        ; will always win due to prev checks
1656         MOVEM   B,TD.LNT+1
1657         HRLI    B,1(B)
1658         HLRE    A,TD.LNT+1
1659         MOVNS   A
1660         ADDI    A,-1(B)         ; A/ final destination
1661         BLT     B,-1(A)
1662         POP     P,(A)           ; new length ins munged in
1663         HLRE    A,TD.LNT+1
1664         MOVNS   A               ; A/ offset for other guys
1665         PUSH    P,A             ; save it
1666         ADD     A,TD.GET+1      ; point for storing uvs of ins
1667         MOVEM   D,-1(A)
1668         MOVE    A,(P)
1669         ADD     A,TD.PUT+1
1670         MOVEM   E,-1(A)         ; store putter also
1671         MOVE    A,(P)
1672         ADD     A,TD.AGC+1
1673         MOVEM   C,-1(A)         ; store putter also
1674         POP     P,A             ; compute primtype
1675         ADDI    A,NUMSAT
1676         PUSH    P,A
1677         MOVE    B,(TP)          ; ready to mung type vector
1678         SUB     TP,[2,,2]
1679         PUSHJ   P,TYPFND        ; CHECK TO SEE WHETHER TEMPLATE EXISTS
1680         JRST    NOTEM
1681         POP     P,C             ; GET SAT
1682         HRRM    C,(A)
1683         JRST    MPOPJ
1684 NOTEM:  POP     P,A             ; RESTORE SAT
1685         HRLI    A,TATOM         ; GET TYPE
1686         PUSHJ   P,INSNT         ; INSERT INTO VECTOR
1687         JRST    MPOPJ
1688
1689 ; this routine copies GET and PUT vectors into new ones
1690
1691 DOBLTS: HRRI    C,(B)
1692         ADD     B,-1(P)
1693         BLT     C,-11(B)        ; zap those guys in
1694         MOVEI   A,TUVEC         ; mung in uniform type
1695         PUTYP   A,(B)
1696         MOVEI   C,-7(B)         ; zero out remainder of uvector
1697         HRLI    C,-10(B)
1698         SETZM   -1(C)
1699         BLT     C,-1(B)
1700         POPJ    P,
1701 \f
1702
1703 ; FUNCTIONS TO SET UP EVALUATION AND APPLICATION RULES FOR DATA TYPES
1704
1705 MFUNCTION EVALTYPE,SUBR
1706
1707         ENTRY
1708
1709         PUSHJ   P,CHKARG        ; VERIFY WINNAGE IN ARGS
1710         MOVEI   A,EVATYP        ; POINT TO TABLE
1711         MOVEI   E,EVTYPE        ; POINT TO PURE VERSION
1712         MOVEI   0,EVAL
1713 TBLCAL: PUSHJ   P,TBLSET        ; SETUP TABLE ENTRY
1714         JRST    FINIS
1715
1716 MFUNCTION APPLYTYPE,SUBR
1717
1718         ENTRY
1719
1720         PUSHJ   P,CHKARG
1721         MOVEI   A,APLTYP        ; POINT TO APPLY TABLE
1722         MOVEI   E,APTYPE        ; PURE TABLE
1723         MOVEI   0,APPLY
1724         JRST    TBLCAL
1725
1726
1727 MFUNCTION PRINTTYPE,SUBR
1728
1729         ENTRY
1730
1731         PUSHJ   P,CHKARG
1732         MOVEI   A,PRNTYP        ; POINT TO APPLY TABLE
1733         MOVEI   E,PRTYPE        ; PURE TABLE
1734         MOVEI   0,PRINT
1735         JRST    TBLCAL
1736
1737 ; CHECK ARGS AND SETUP FOR TABLE HACKER
1738
1739 CHKARG: JUMPGE  AB,TFA
1740         CAMGE   AB,[-5,,]
1741         JRST    TMA
1742         GETYP   A,(AB)          ; 1ST MUST BE TYPE NAME
1743         CAIE    A,TATOM
1744         JRST    WTYP1
1745         MOVE    B,1(AB)         ; GET ATOM
1746         PUSHJ   P,TYPLOO        ; VERIFY THAT IT IS A TYPE
1747         PUSH    P,D             ; SAVE TYPE NO.
1748         MOVEI   D,-1            ; INDICATE FUNNYNESS
1749         CAML    AB,[-3,,]       ; SKIP IF 2 OR MORE
1750         JRST    TY1AR
1751         HRRZ    A,(A)           ; GET SAT
1752         ANDI    A,SATMSK
1753         PUSH    P,A
1754         GETYP   A,2(AB)         ; GET 2D TYPE
1755         CAIE    A,TATOM         ; EITHER TYPE OR APPLICABLE
1756         JRST    TRYAPL          ; TRY APPLICABLE
1757         MOVE    B,3(AB)         ; VERIFY IT IS A TYPE
1758         PUSHJ   P,TYPLOO
1759         HRRZ    A,(A)           ; GET SAT
1760         ANDI    A,SATMSK
1761         POP     P,C             ; RESTORE SAVED SAT
1762         CAIE    A,(C)           ; SKIP IF A WINNER
1763         JRST    TYPDIF          ; REPORT ERROR
1764 TY1AR:  POP     P,C             ; GET SAVED TYPE
1765         MOVEI   B,0             ; TELL THAT WE ARE A TYPE
1766         POPJ    P,
1767
1768 TRYAPL: PUSHJ   P,APLQ          ; IS THIS APPLICABLE
1769         JRST    NAPT
1770         SUB     P,[1,,1]
1771         MOVE    B,2(AB)         ; RETURN SAME
1772         MOVE    D,3(AB)
1773         POP     P,C
1774         POPJ    P,
1775
1776 \f
1777 ; HERE TO PUT ENTRY IN APPROPRIATE TABLE
1778
1779 TBLSET: PUSH    TP,B
1780         PUSH    TP,D            ; SAVE VALUE
1781         PUSH    TP,$TFIX
1782         PUSH    TP,A
1783         PUSH    P,C             ; SAVE TYPE BEING HACKED
1784         PUSH    P,E
1785         SKIPE   B,1(A)          ; SKIP IF VECTOR DOESN'T EXIST YET
1786         JRST    TBL.OK
1787         MOVE    B,-2(TP)        ; CHECK FOR RETURN IT HACK
1788         SKIPN   -3(TP)
1789         CAIE    B,-1
1790         JRST    .+2
1791         JRST    RETPM2
1792         HLRE    A,TYPBOT+1      ; GET CURRENT TABLE LNTH
1793         MOVNS   A
1794         ASH     A,-1
1795         PUSH    P,0
1796         PUSHJ   P,IVECT         ; GET VECTOR
1797         POP     P,0
1798         MOVE    C,(TP)          ; POINT TO RETURN POINT
1799         MOVEM   B,1(C)          ; SAVE VECTOR
1800
1801 TBL.OK: POP     P,E
1802         POP     P,C             ; RESTORE TYPE
1803         SUB     TP,[2,,2]
1804         POP     TP,D
1805         POP     TP,A
1806         JUMPN   A,TBLOK1        ; JUMP IF FUNCTION ETC. SUPPLIED
1807         CAIN    D,-1
1808         JRST    TBLOK1
1809         CAILE   D,NUMPRI        ; SKIP IF ORIGINAL TYPE
1810         MOVNI   E,(D)           ; CAUSE E TO ENDUP 0
1811         ADDI    E,(D)           ; POINT TO PURE SLOT
1812 TBLOK1: ADDI    C,(C)           ; POINT TO VECTOR SLOT
1813         ADDI    C,(B)
1814         CAIN    D,-1
1815         JRST    RETCUR
1816         JUMPN   A,OK.SET        ; OK TO CLOBBER
1817         ADDI    B,(D)           ; POINT TO TARGET TYPE'S SLOT
1818         ADDI    B,(D)           ; POINT TO TARGET TYPE'S SLOT
1819         SKIPN   A,(B)           ; SKIP IF WINNER
1820         SKIPE   1(B)            ; SKIP IF LOSER
1821         SKIPA   D,1(B)          ; SETUP D
1822         JRST    CH.PTB          ; CHECK PURE TABLE
1823
1824 OK.SET: CAIN    0,(D)           ; SKIP ON RESET
1825         SETZB   A,D
1826         MOVEM   A,(C)           ; STORE
1827         MOVEM   D,1(C)
1828 RETAR1: MOVE    A,(AB)          ; RET TYPE
1829         MOVE    B,1(AB)
1830         JRST    FINIS
1831
1832 CH.PTB: MOVEI   A,0
1833         MOVE    D,[SETZ NAPT]
1834         JUMPE   E,OK.SET
1835         MOVE    D,(E)
1836         JRST    OK.SET
1837
1838 RETPM2: SUB     TP,[4,,4]
1839         SUB     P,[2,,2]
1840         ASH     C,1
1841         SOJA    E,RETPM4
1842
1843 RETCUR: SKIPN   A,(C)
1844         SKIPE   1(C)
1845         SKIPA   B,1(C)
1846         JRST    RETPRM
1847
1848         JUMPN   A,CPOPJ
1849 RETPM1: MOVEI   A,0
1850         JUMPL   B,RTFALS
1851         CAMN    B,1(E)
1852         JRST    .+3
1853         ADDI    A,2
1854         AOJA    E,.-3
1855
1856 RETPM3: ADD     A,TYPVEC+1
1857         MOVE    B,3(A)
1858         MOVE    A,2(A)
1859         POPJ    P,
1860
1861 RETPRM: SUBI    C,(B)           ; UNDO BADNESS
1862 RETPM4: CAIG    C,NUMPRI*2
1863         SKIPG   1(E)
1864         JRST    RTFALS
1865
1866         MOVEI   A,-2(C)
1867         JRST    RETPM3
1868
1869 CALLTY: MOVE    A,TYPVEC
1870         MOVE    B,TYPVEC+1
1871         POPJ    P,
1872
1873 MFUNCTION ALLTYPES,SUBR
1874
1875         ENTRY   0
1876
1877         MOVE    A,TYPVEC
1878         MOVE    B,TYPVEC+1
1879         JRST    FINIS
1880
1881 ;\f
1882
1883 ;FUNCTION TO RETURN TYPE OF ELEMENTS IN A UVECTOR
1884
1885 MFUNCTION UTYPE,SUBR
1886
1887         ENTRY   1
1888
1889         GETYP   A,(AB)          ;GET U VECTOR
1890         PUSHJ   P,SAT
1891         CAIE    A,SNWORD
1892         JRST    WTYP1
1893         MOVE    B,1(AB)         ; GET UVECTOR
1894         PUSHJ   P,CUTYPE
1895         JRST    FINIS
1896
1897 CUTYPE: HLRE    A,B             ;GET -LENGTH
1898         HRRZS   B
1899         SUB     B,A             ;POINT TO TYPE WORD
1900         GETYP   A,(B)
1901         JRST    ITYPE           ; GET NAME OF TYPE
1902
1903 ; FUNCTION TO CHANGE UNIFORM TYPE OF A VECTOR
1904
1905 MFUNCTION CHUTYPE,SUBR
1906
1907         ENTRY   2
1908
1909         GETYP   A,2(AB)         ;GET 2D TYPE
1910         CAIE    A,TATOM
1911         JRST    NOTATO
1912         GETYP   A,(AB)          ; CALL WITH UVECTOR?
1913         PUSHJ   P,SAT
1914         CAIE    A,SNWORD
1915         JRST    WTYP1
1916         MOVE    A,1(AB)         ; GET UV POINTER
1917         MOVE    B,3(AB)         ;GET ATOM
1918         PUSHJ   P,CCHUTY
1919         MOVE    A,(AB)          ; RETURN UVECTOR
1920         MOVE    B,1(AB)
1921         JRST    FINIS
1922
1923 CCHUTY: PUSH    TP,$TUVEC
1924         PUSH    TP,A
1925         PUSHJ   P,TYPLOO        ;LOOK IT UP
1926         HRRZ    B,(A)           ;GET SAT
1927         TRNE    B,CHBIT
1928         JRST    CANTCH
1929         ANDI    B,SATMSK
1930         SKIPGE  MKTBS(B)
1931         JRST    CANTCH
1932         HLRE    C,(TP)          ;-LENGTH
1933         HRRZ    E,(TP)
1934         SUB     E,C             ;POINT TO TYPE
1935         GETYP   A,(E)           ;GET TYPE
1936         JUMPE   A,WIN0          ;ALLOW TYPE "LOSE" TO CHANGE TO ANYTHING
1937         PUSHJ   P,SAT           ;GET SAT
1938         JUMPE   A,TYPERR
1939         CAIE    A,(B)           ;COMPARE
1940         JRST    TYPDIF
1941 WIN0:   ADDI    D,.VECT.
1942         HRLM    D,(E)           ;CLOBBER NEW ONE
1943         POP     TP,B
1944         POP     TP,A
1945         POPJ    P,
1946
1947 CANTCH: PUSH    TP,$TATOM
1948         PUSH    TP,EQUOTE CANT-CHTYPE-INTO
1949         PUSH    TP,2(AB)
1950         PUSH    TP,3(AB)
1951         MOVEI   A,2
1952         JRST    CALER
1953
1954 NOTATOM:
1955         PUSH    TP,$TATOM
1956         PUSH    TP,EQUOTE NON-ATOMIC-ARGUMENT
1957         PUSH    TP,(AB)
1958         PUSH    TP,1(AB)
1959         MOVEI   A,2
1960         JRST    CALER
1961
1962
1963 \f
1964 ; SUBROUTINE TO LEAVE MUDDLE CLOSING ALL CHANNELS ON THE WAY
1965
1966 MFUNCTION QUIT,SUBR
1967
1968         ENTRY   0
1969
1970
1971         PUSHJ   P,CLOSAL        ; DO THE CLOSES
1972         PUSHJ   P,%KILLM
1973         JRST    IFALSE          ; JUST IN CASE
1974
1975 CLOSAL: MOVEI   B,CHNL0+2       ; POINT TO 1ST (NOT INCLUDING TTY I/O)
1976         MOVE    PVP,PVSTOR+1
1977         MOVE    TVP,REALTV+1(PVP)
1978         SUBI    B,(TVP)
1979         HRLS    B
1980         ADD     B,TVP
1981         PUSH    TP,$TVEC
1982         PUSH    TP,B
1983         PUSH    P,[N.CHNS-1]    ; MAX NO. OF CHANS
1984
1985 CLOSA1: MOVE    B,(TP)
1986         ADD     B,[2,,2]
1987         MOVEM   B,(TP)
1988         HLLZS   -2(B)
1989         SKIPN   C,-1(B)         ; THIS ONE OPEN?
1990         JRST    CLOSA4          ; NO
1991         CAME    C,TTICHN+1
1992         CAMN    C,TTOCHN+1
1993         JRST    CLOSA4
1994         PUSH    TP,-2(B)        ; PUSH IT
1995         PUSH    TP,-1(B)
1996         MCALL   1,FCLOSE                ; CLOSE IT
1997 CLOSA4: SOSLE   (P)             ; COUNT DOWN
1998         JRST    CLOSA1
1999
2000
2001         SUB     TP,[2,,2]
2002         SUB     P,[1,,1]
2003
2004 CLOSA3: SKIPN   B,CHNL0+1
2005         POPJ    P,
2006         PUSH    TP,(B)
2007         HLLZS   (TP)
2008         PUSH    TP,1(B)
2009         HRRZ    B,(B)
2010         MOVEM   B,CHNL0+1
2011         MCALL   1,FCLOSE
2012         JRST    CLOSA3
2013 \f
2014
2015 IMPURE
2016
2017 WHOAMI: 0               ; SYAYS WHETHER I AM REALLY A MUDDLE OR SOME HACK
2018
2019
2020 ;GARBAGE COLLECTORS PDLS
2021
2022
2023 GCPDL:  -GCPLNT,,GCPDL
2024
2025         BLOCK   GCPLNT
2026
2027
2028 PURE
2029
2030 MUDSTR: ASCII /MUDDLE \7f\7f\7f/
2031 STRNG:  -1
2032         -1
2033         -1
2034         ASCIZ / IN OPERATION./
2035
2036 ;MARKED PDLS FOR GC PROCESS
2037
2038 VECTGO
2039 ; DUMMY FRAME FOR INITIALIZER CALLS
2040
2041         TENTRY,,LISTEN
2042         0
2043         .-3
2044         0
2045         0
2046         -ITPLNT,,TPBAS-1
2047         0
2048
2049 TPBAS:  BLOCK   ITPLNT+PDLBUF
2050         GENERAL
2051         ITPLNT+2+PDLBUF+7,,0
2052
2053
2054 VECRET
2055
2056
2057 $TMATO: TATOM,,-1
2058
2059 END
2060 \f