<mdl.int>/main.mid.350

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