<mdl.int>/main.mid.351

   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         PUSH    TP,(AB)
 698         PUSH    TP,1(AB)
 699         PUSHJ   P,CHKPRD
 700 REHANG: MOVE    A,[PUSHJ P,CHKPRH]
 701         MOVEM   A,ONINT         ; CHECK PREDICATE AFTER ANY INTERRUPT
 702 HANG1:  ENABLE                  ;LET OURSELVES BE INTERRUPTED OUT
 703         PUSHJ   P,%HANG
 704         DISABLE                 ;PREVENT INTERRUPTS AT RANDOM TIMES
 705         SETZM   ONINT
 706         MOVE    A,$TATOM
 707         MOVE    B,IMQUOTE T
 708         JRST    FINIS
 709
 710
 711 ; ROUTINE TO SLEEP FOR POSITIVE NUMBER OF SECONDS WITH INTERRUPTS ENABLED
 712 ; ARGUMENT SHOULD BE OF TYPE FIX OR FLOAT AND NON-NEGATIVE
 713
 714 MFUNCTION       SLEEP,SUBR
 715
 716         ENTRY
 717
 718         JUMPGE  AB,TFA
 719         CAML    AB,[-3,,]
 720         JRST    SLEEP1
 721         CAMGE   AB,[-5,,]
 722         JRST    TMA
 723         PUSH    TP,2(AB)
 724         PUSH    TP,3(AB)
 725         PUSHJ   P,CHKPRD
 726 SLEEP1: GETYP   0,(AB)
 727         CAIE    0,TFIX
 728         JRST    .+5
 729         MOVE    B,1(AB)
 730         JUMPL   B,OUTRNG        ;ARG SHOULDNT BE NEGATIVE
 731         IMULI   B,30.           ;CONVERT TO # OF THIRTIETHS OF A SECOND
 732         JRST    SLEEPR          ;GO SLEEP
 733         CAIE    0,TFLOAT        ;IF IT WASNT FIX MAKE SURE IT IS FLOAT
 734         JRST    WTYP1           ;WRONG TYPE ARG
 735         MOVE    B,1(AB)
 736         FMPR    B,[30.0]        ;CONVERT TO FLOATING # OF THIRTIETHS OF A SECOND
 737         MULI    B,400           ;KLUDGE TO FIX IT
 738         TSC     B,B
 739         ASH     C,(B)-243
 740         MOVE    B,C             ;MOVE THE FIXED NUMBER INTO B
 741         JUMPL   B,OUTRNG        ;CHECK TO SEE THAT WE HAVE POSITIVE NUMBER
 742 SLEEPR: MOVE    A,B
 743 RESLEE: MOVE    B,[PUSHJ P,CHKPRS]
 744         CAMGE   AB,[-3,,]
 745         MOVEM   B,ONINT
 746         ENABLE
 747         PUSHJ   P,%SLEEP
 748         DISABLE
 749         SETZM   ONINT
 750         MOVE    A,$TATOM
 751         MOVE    B,IMQUOTE T
 752         JRST    FINIS
 753
 754 CHKPRH: PUSH    P,B
 755         MOVEI   B,HANGP
 756         JRST    .+3
 757
 758 CHKPRS: PUSH    P,B
 759         MOVEI   B,SLEEPP
 760         HRRM    B,LCKINT
 761         SETZM   ONINT           ; TURN OFF FEATURE FOR NOW
 762         POP     P,B
 763         POPJ    P,
 764
 765 HANGP:  SKIPA   B,[REHANG]
 766 SLEEPP: MOVEI   B,RESLEE
 767         PUSH    P,B
 768 CHKPRD: PUSH    P,A
 769         DISABLE
 770         PUSH    TP,(TB)
 771         PUSH    TP,1(TB)
 772         MCALL   1,EVAL
 773         GETYP   0,A
 774         CAIE    0,TFALSE
 775         JRST    FINIS
 776         POP     P,A
 777         POPJ    P,
 778
 779 MFUNCTION       VALRET,SUBR
 780 ; SUBR TO VALRET A STRING TO SUPERIOR ITS PROCESS
 781
 782         ENTRY   1
 783         GETYP   A,(AB)          ; GET TYPE OF ARGUMENT
 784         CAIN    A,TFIX          ; FIX?
 785          JRST   VALRT1
 786         CAIE    A,TCHSTR        ; IS IT A CHR STRING?
 787         JRST    WTYP1           ; NO...ERROR WRONG TYPE
 788         PUSHJ   P,CSTACK        ; COPY THE CHR STRING TO THE STACK
 789                                         ; CSTACK IS IN ATOMHK
 790         MOVEI   B,0             ; ASCIZ TERMINATOR
 791         EXCH    B,(P)           ; STORE AND RETRIEVE COUNT
 792
 793 ; CALCULATE THE BEGINNING ADDR OF THE STRING
 794         MOVEI   A,-1(P)         ; GET ADDR OF TOP OF STACK
 795         SUBI    A,-1(B)         ; GET STARTING ADDR
 796         PUSHJ   P,%VALRE        ; PASS UP TO MONITOR
 797         JRST    IFALSE          ; IF HE RETURNS, RETURN FALSE
 798
 799 VALRT1: MOVE    A,1(AB)
 800         PUSHJ   P,%VALFI
 801         JRST    IFALSE
 802
 803 MFUNCTION       LOGOUT,SUBR
 804
 805 ; SUBR TO DO A .LOGOUT (VALID ONLY AT TOP LEVEL)
 806         ENTRY   0
 807         PUSHJ   P,%TOPLQ        ; SKIP IF AT TOP LEVEL
 808         JRST    IFALSE
 809         PUSHJ   P,CLOSAL
 810         PUSHJ   P,%LOGOUT       ; TRY TO FLUSH
 811         JRST    IFALSE          ; COULDN'T DO IT...RETURN FALSE
 812
 813 ; FUNCTS TO GET UNAME AND JNAME
 814
 815 ; GET XUNAME (REAL UNAME)
 816 MFUNCTION XUNAME,SUBR
 817
 818         ENTRY   0
 819
 820         PUSHJ   P,%RXUNA
 821          JRST   RSUJNM
 822         JRST    FINIS           ; 10X ROUTINES SKIP
 823
 824 MFUNCTION UNAME,SUBR
 825
 826         ENTRY   0
 827
 828         PUSHJ   P,%RUNAM
 829          JRST   RSUJNM
 830         JRST    FINIS
 831
 832 ; REAL JNAME
 833 MFUNCTION XJNAME,SUBR
 834
 835         ENTRY   0
 836
 837         PUSHJ   P,%RXJNA
 838         JRST    RSUJNM
 839
 840 MFUNCTION JNAME,SUBR
 841
 842         ENTRY   0
 843
 844         PUSHJ   P,%RJNAM
 845         JRST    RSUJNM
 846
 847 ; FUNCTION TO SET AND READ GLOBAL SNAME
 848
 849 MFUNCTION SNAME,SUBR
 850
 851         ENTRY
 852
 853         JUMPGE  AB,SNAME1
 854         CAMG    AB,[-3,,]
 855         JRST    TMA
 856         GETYP   A,(AB)          ; ARG MUST BE STRING
 857         CAIE    A,TCHSTR
 858         JRST    WTYP1
 859         PUSH    TP,$TATOM
 860         PUSH    TP,IMQUOTE SNM
 861         PUSH    TP,(AB)
 862         PUSH    TP,1(AB)
 863         MCALL   2,SETG
 864         JRST    FINIS
 865
 866 SNAME1: MOVE    B,IMQUOTE SNM
 867         PUSHJ   P,IDVAL1
 868         GETYP   0,A
 869         CAIN    0,TCHSTR
 870         JRST    FINIS
 871         MOVE    A,$TCHSTR
 872         MOVE    B,CHQUOTE
 873         JRST    FINIS
 874
 875 RSUJNM: PUSHJ   P,6TOCHS        ; CONVERT IT
 876         JRST    FINIS
 877
 878
 879 SGSNAM: MOVE    B,IMQUOTE SNM
 880         PUSHJ   P,IDVAL1
 881         GETYP   0,A
 882         CAIE    0,TCHSTR
 883         JRST    SGSN1
 884
 885         PUSH    TP,A
 886         PUSH    TP,B
 887         PUSHJ   P,STRTO6
 888         POP     P,A
 889         SUB     TP,[2,,2]
 890         JRST    .+2
 891
 892 SGSN1:  MOVEI   A,0
 893         PUSHJ   P,%SSNAM        ; SET SNAME IN SYSTEM
 894         POPJ    P,
 895
 896 \f
 897
 898 ;THIS SUBROUTINE ALLOCATES A NEW PROCESS
 899 ;TAKES TP-STACK SIZE (2*WORDS) IN A AND P-STACK SIZE (WORDS) IN B
 900 ;IS CALLED BY PUSHJ P,. RETURNS IN A AND B A NEW PROCESS.
 901
 902 ICR:    PUSH    P,A
 903         PUSH    P,B
 904         MOVEI   A,PVLNT         ;SETUP CALL TO VECTOR FOR PVP
 905         PUSHJ   P,IVECT         ;GOBBLE A VECTOR
 906         HRLI    C,PVBASE        ;SETUP A BLT POINTER
 907         HRRI    C,(B)           ;GET INTO ADDRESS
 908         BLT     C,PVLNT*2-1(B)  ;COPY A PROTOTYPE INTO NEW PVP
 909         MOVSI   C,400000+SPVP+.VECT.    ;SET SPECIAL TYPE
 910         MOVEM   C,PVLNT*2(B)    ;CLOBBER IT IN
 911         PUSH    TP,A            ;SAVE THE RESULTS OF VECTOR
 912         PUSH    TP,B
 913
 914         PUSH    TP,$TFIX        ;GET A UNIFORM VECTOR
 915         POP     P,B
 916         PUSH    TP,B
 917         MCALL   1,UVECTOR
 918         ADD     B,[PDLBUF-2,,-1]        ;FUDGE WITH BUFFER
 919         MOVE    C,(TP)          ;REGOBBLE PROCESS POINTER
 920         MOVEM   B,PSTO+1(C)     ;STORE IN ALL HOMES
 921         MOVEM   B,PBASE+1(C)
 922
 923
 924         POP     P,A             ;PREPARE TO CREATE A TEMPORARY PDL
 925         PUSHJ   P,IVECT         ;GET THE TEMP PDL
 926         ADD     B,[PDLBUF,,0]   ;PDL GROWTH HACK
 927         MOVE    C,(TP)          ;RE-GOBBLE NEW PVP
 928         SUB     B,[1,,1]        ;FIX FOR STACK
 929         MOVEM   B,TPBASE+1(C)
 930
 931 ;SETUP INITIAL BINDING
 932
 933         PUSH    B,$TBIND
 934         MOVEM   B,SPBASE+1(C)   ;SAVE AS BASE OF SP
 935         MOVEM   B,SPSTO+1(C)    ;AND CURRENT THEREOF
 936         MOVEM   B,CURFCN+1(C)   ; AND AS CURRENT FCN FOR SPEC/UNSPEC LOGIC
 937         PUSH    B,IMQUOTE THIS-PROCESS
 938         PUSH    B,$TPVP ;GIVE IT PROCESS AS VALUE
 939         PUSH    B,C
 940         ADD     B,[2,,2]        ;FINISH FRAME
 941         MOVEM   B,TPSTO+1(C)    ;MAKE THIS THE CURRENT STACK POINTER
 942         MOVEM   C,PVPSTO+1(C)   ;SAVE THE NEW PVP ITSELF
 943         AOS     A,IDPROC                ;GOBBLE A UNIQUE PROCESS I.D.
 944         MOVEM   A,PROCID+1(C)   ;SAVE THAT ALSO
 945         AOS     A,PTIME         ; GET A UNIQUE BINDING ID
 946         MOVEM   A,BINDID+1(C)
 947
 948         MOVSI   A,TPVP          ;CLOBBER THE TYPE
 949         MOVE    B,(TP)          ;AND POINTER TO PROCESS
 950         SUB     TP,[2,,2]
 951         POPJ    P,
 952
 953 ;MINI ROUTINE TO CALL VECTOR WITH COUNT IN A
 954
 955 IVECT:  PUSH    TP,$TFIX
 956         PUSH    TP,A
 957         MCALL   1,VECTOR        ;GOBBLE THE VECTOR
 958         POPJ    P,
 959
 960
 961 ;SUBROUTINE TO SWAP A PROCESS IN
 962 ;CALLED WITH JSP A,SWAP AND NEW PVP IN B
 963
 964 SWAP:                           ;FIRST STORE ALL THE ACS
 965
 966         MOVE    PVP,PVSTOR+1
 967         MOVE    SP,$TSP         ; STORE SPSAVE
 968         MOVEM   SP,SPSTO(PVP)
 969         MOVE    SP,SPSTOR+1
 970         IRP     A,,[SP,AB,TB,TP,P,M,R,FRM]
 971         MOVEM   A,A!STO+1(PVP)
 972         TERMIN
 973
 974         SETOM   1(TP)           ; FENCE POST MAIN STACK
 975         MOVEM   TP,TPSAV(TB)    ; CORRECT FRAME
 976         SETZM   PSAV(TB)        ; CLEAN UP CURRENT FRAME
 977         SETZM   SPSAV(TB)
 978         SETZM   PCSAV(TB)
 979
 980         MOVE    E,PVP   ;RETURN OLD PROCESS IN E
 981         MOVE    PVP,D   ;AND MAKE NEW ONE BE D
 982         MOVEM   PVP,PVSTOR+1
 983
 984 SWAPIN:
 985         ;NOW RESTORE NEW PROCESSES AC'S
 986
 987         MOVE    PVP,PVSTOR+1
 988         IRP     A,,[AB,TB,SP,TP,P,M,R,FRM]
 989         MOVE    A,A!STO+1(PVP)
 990         TERMIN
 991
 992         SETZM   SPSTO(PVP)
 993         MOVEM   SP,SPSTOR+1
 994         JRST    (C)             ;AND RETURN
 995
 996
 997 \f
 998
 999 ;SUBRS ASSOCIATED WITH TYPES
1000
1001 ;TYPE (ITYPE) ARE FUNCTIONS TO RETURN THE ATOMIC NAME OF THE
1002 ;TYPE OF A GOODIE.  TYPE TAKES ITS ARGS ON AP AND RETURNS IN A AND B.
1003 ;ITYPE TAKES ITS ARGS IN A AND B AND RETURNS IN SAME (B=0) FOR INVALID
1004 ;TYPECODE.
1005 MFUNCTION TYPE,SUBR
1006
1007         ENTRY   1
1008         GETYP   A,(AB)          ;TYPE INTO A
1009 TYPE1:  PUSHJ   P,ITYPE         ;GO TO INTERNAL
1010         JUMPN   B,FINIS         ;GOOD RETURN
1011 TYPERR: ERRUUO  EQUOTE TYPE-UNDEFINED
1012
1013 CITYPE: GETYP   A,A             ; GET TYPE FOR COMPILER CALL
1014 ITYPE:  LSH     A,1             ;TIMES 2
1015         HRLS    A               ;TO BOTH SIDES
1016         ADD     A,TYPVEC+1      ;GET ACTUAL LOCATION
1017         JUMPGE  A,TYPERR        ;LOST, TYPE OUT OF BOUNDS
1018         MOVE    B,1(A)          ;PICKUP TYPE
1019         HLLZ    A,(A)
1020         POPJ    P,
1021
1022 ; PREDICATE -- IS OBJECT OF TYPE SPECIFIED
1023
1024 MFUNCTION %TYPEQ,SUBR,[TYPE?]
1025
1026         ENTRY
1027
1028         MOVE    D,AB            ; GET ARGS
1029         ADD     D,[2,,2]
1030         JUMPGE  D,TFA
1031         MOVE    A,(AB)
1032         HLRE    C,D
1033         MOVMS   C
1034         ASH     C,-1            ; FUDGE
1035         PUSHJ   P,ITYPQ         ; GO INTERNAL
1036         JFCL
1037         JRST    FINIS
1038
1039 ITYPQ:  GETYP   A,A             ; OBJECT
1040         PUSHJ   P,ITYPE
1041 TYPEQ0: SOJL    C,CIFALS
1042         GETYP   0,(D)
1043         CAIE    0,TATOM         ; Type name must be an atom
1044         JRST    WRONGT
1045         CAMN    B,1(D)          ; Same as the OBJECT?
1046         JRST    CPOPJ1          ; Yes, return type name
1047         ADD     D,[2,,2]
1048         JRST    TYPEQ0          ; No, continue comparing
1049
1050 CIFALS: MOVEI   B,0
1051         MOVSI   A,TFALSE
1052         POPJ    P,
1053
1054 CTYPEQ: SOJE    A,CIFALS        ; TREAT NO ARGS AS FALSE
1055         MOVEI   D,1(A)          ; FIND BASE OF ARGS
1056         ASH     D,1
1057         HRLI    D,(D)
1058         SUBM    TP,D            ; D POINTS TO BASE
1059         MOVE    E,D             ; SAVE FOR TP RESTORE
1060         ADD     D,[3,,3]        ; FUDGE
1061         MOVEI   C,(A)           ; NUMBER OF TYPES
1062         MOVE    A,-2(D)
1063         PUSHJ   P,ITYPQ
1064         JFCL            ; IGNORE SKIP FOR NOW
1065         MOVE    TP,E            ; SET TP BACK
1066         JUMPL   B,CPOPJ1        ; SKIP
1067         POPJ    P,
1068 \f
1069 ; Entries to get type codes for types for fixing up RSUBRs and assembling
1070
1071 MFUNCTION %TYPEC,SUBR,[TYPE-C]
1072
1073         ENTRY
1074
1075         JUMPGE  AB,TFA
1076         GETYP   0,(AB)
1077         CAIE    0,TATOM
1078         JRST    WTYP1
1079         MOVE    B,1(AB)
1080         CAMGE   AB,[-3,,0]      ; skip if only type name given
1081         JRST    GTPTYP
1082         MOVE    C,IMQUOTE ANY
1083
1084 TYPEC1: PUSHJ   P,CTYPEC        ; go to internal
1085         JRST    FINIS
1086
1087 GTPTYP: CAMGE   AB,[-5,,0]
1088         JRST    TMA
1089         GETYP   0,2(AB)
1090         CAIE    0,TATOM
1091         JRST    WTYP2
1092         MOVE    C,3(AB)
1093         JRST    TYPEC1
1094
1095 CTYPEC: PUSH    P,C             ; save primtype checker
1096         PUSHJ   P,TYPFND        ; search type vector
1097         JRST    CTPEC2          ; create the poor loser
1098         POP     P,B
1099         CAMN    B,IMQUOTE ANY
1100         JRST    CTPEC1
1101         CAMN    B,IMQUOTE TEMPLATE
1102         JRST    TCHK
1103         PUSH    P,D
1104         HRRZ    A,(A)
1105         ANDI    A,SATMSK
1106         PUSH    P,A
1107         PUSHJ   P,TYPLOO
1108         HRRZ    0,(A)
1109         ANDI    0,SATMSK
1110         CAME    0,(P)
1111         JRST    TYPDIF
1112         MOVE    D,-1(P)
1113         SUB     P,[2,,2]
1114 CTPEC1: MOVEI   B,(D)
1115         MOVSI   A,TTYPEC
1116         POPJ    P,
1117 TCHK:   PUSH    P,D             ; SAVE TYPE
1118         MOVE    A,D             ; GO TO SAT
1119         PUSHJ   P,SAT
1120         CAIG    A,NUMSAT        ; SKIP IF A TEMPLATE
1121         JRST    TYPDIF
1122         POP     P,D             ; RESTORE TYPE
1123         JRST    CTPEC1
1124
1125 CTPEC2: POP     P,C             ; GET BACK PRIMTYPE
1126         SUBM    M,(P)
1127         PUSH    TP,$TATOM
1128         PUSH    TP,B
1129         CAMN    C,IMQUOTE ANY
1130         JRST    CTPEC3
1131         PUSH    TP,$TATOM
1132         PUSH    TP,C
1133         MCALL   2,NEWTYPE               ; CREATE THE POOR GUY
1134         MOVE    C,IMQUOTE ANY
1135         SUBM    M,(P)           ; UNRELATIVIZE
1136         JRST    CTYPEC
1137
1138 CTPEC3: HRRZ    0,FSAV(TB)
1139         CAIE    0,%TYPEC
1140         CAIN    0,%TYPEW
1141         JRST    TYPERR
1142
1143         MCALL   1,%TYPEC
1144         JRST    MPOPJ
1145
1146 MFUNCTION %TYPEW,SUBR,[TYPE-W]
1147
1148         ENTRY
1149
1150         JUMPGE  AB,TFA
1151         GETYP   0,(AB)
1152         CAIE    0,TATOM
1153         JRST    WTYP1
1154         MOVEI   D,0
1155         MOVE    C,IMQUOTE ANY
1156         MOVE    B,1(AB)
1157         CAMGE   AB,[-3,,0]
1158         JRST    CTYPW1
1159
1160 CTYPW3: PUSHJ   P,CTYPEW
1161         JRST    FINIS
1162
1163 CTYPW1: GETYP   0,2(AB)
1164         CAIE    0,TATOM
1165         JRST    WTYP2
1166         CAMGE   AB,[-5,,0]      ; JUMP IF RH IS GIVEN
1167         JRST    CTYPW2
1168 CTYPW5: MOVE    C,3(AB)
1169         JRST    CTYPW3
1170
1171 CTYPW2: CAMGE   AB,[-7,,0]
1172         JRST    TMA
1173         GETYP   0,4(AB)
1174         CAIE    0,TFIX
1175         JRST    WRONGT
1176         MOVE    D,5(AB)
1177         JRST    CTYPW5
1178
1179 CTYPEW: PUSH    P,D
1180         PUSHJ   P,CTYPEC        ; GET CODE IN B
1181         POP     P,B
1182         HRLI    B,(D)
1183         MOVSI   A,TTYPEW
1184         POPJ    P,
1185
1186 MFUNCTION %VTYPE,SUBR,[VALID-TYPE?]
1187
1188         ENTRY   1
1189
1190         GETYP   0,(AB)
1191         CAIE    0,TATOM
1192         JRST    WTYP1
1193         MOVE    B,1(AB)
1194
1195         PUSHJ   P,CVTYPE
1196         JFCL
1197         JRST    FINIS
1198
1199 CVTYPE: PUSHJ   P,TYPFND                ; LOOK IT UP
1200         JRST    PFALS
1201
1202         MOVEI   B,(D)
1203         MOVSI   A,TTYPEC
1204         JRST    CPOPJ1
1205
1206 PFALS:  MOVEI   B,0
1207         MOVSI   A,TFALSE
1208         POPJ    P,
1209 \f
1210 ;PRIMTTYPE  RETURNS THE TYPE ATOM OF A PRIMITIVE TYPE IN A CLASS
1211
1212 STBL:   REPEAT NUMSAT,SETZ MQUOTE INTERNAL-TYPE
1213
1214 LOC STBL
1215
1216 IRP A,,[[1WORD,WORD],[2WORD,LIST],[NWORD,UVECTOR],[2NWORD,VECTOR],[STORE,STORAGE]
1217 [ARGS,TUPLE],[FRAME,FRAME],[ATOM,ATOM],[LOCID,LOCD],[CHSTR,STRING],[OFFS,OFFSET,1]
1218 [PVP,PROCESS,1],[ASOC,ASOC,1],[LOCA,LOCA],[LOCS,LOCS],[LOCU,LOCU],[LOCV,LOCV]
1219 [LOCL,LOCL],[LOCN,LOCAS],[LOCT,LOCT,1],[LOCR,LOCR],[LOCB,LOCB,1],[BYTE,BYTES,1]]
1220 IRP B,C,[A]
1221 LOC STBL+S!B
1222 IRP X,Y,[C]
1223 IFSE [Y],SETZ IMQUOTE X
1224 IFSN [Y],SETZ MQUOTE X
1225 .ISTOP
1226 TERMIN
1227 .ISTOP
1228
1229 TERMIN
1230 TERMIN
1231
1232 LOC STBL+NUMSAT+1
1233
1234
1235 MFUNCTION TYPEPRIM,SUBR
1236
1237         ENTRY   1
1238         GETYP   A,(AB)
1239         CAIE    A,TATOM
1240         JRST    NOTATOM
1241         MOVE    B,1(AB)
1242         PUSHJ   P,CTYPEP
1243         JRST    FINIS
1244
1245 CTYPEP: PUSHJ   P,TYPLOO        ; CONVERT ATOM TO CODE
1246         HRRZ    A,(A)           ; SAT TO A
1247         ANDI    A,SATMSK
1248         JRST    PTYP1
1249
1250 MFUNCTION PTSATC,SUBR,[PRIMTYPE-C]
1251
1252         ENTRY   1
1253
1254         GETYP   A,(AB)
1255         CAIE    A,TATOM
1256         JRST    WTYP1
1257         MOVE    B,1(AB)
1258         PUSHJ   P,CPRTYC
1259         JRST    FINIS
1260
1261 CPRTYC: PUSHJ   P,TYPLOO
1262         MOVE    B,(A)
1263         ANDI    B,SATMSK
1264         MOVSI   A,TSATC
1265         POPJ    P,
1266
1267
1268 IMFUNCTION PRIMTYPE,SUBR
1269
1270         ENTRY   1
1271
1272         MOVE    A,(AB)          ;GET TYPE
1273         PUSHJ   P,CPTYPE
1274         JRST    FINIS
1275
1276 CPTYPE: GETYP   A,A
1277         PUSHJ   P,SAT           ;GET SAT
1278 PTYP1:  JUMPE   A,TYPERR
1279         MOVE    B,IMQUOTE TEMPLATE
1280         CAIG    A,NUMSAT        ; IF BIG SAT, THEN TEMPLATE
1281         MOVE    B,@STBL(A)
1282         MOVSI   A,TATOM
1283         POPJ    P,
1284 \f
1285
1286 ; RSUBR MAKES A VECTOR INTO AN OBJECT OF TYPE RSUBR, ALSO SLIGHTLY MUNGING IT
1287
1288 IMFUNCTION RSUBR,SUBR
1289         ENTRY   1
1290
1291         GETYP   A,(AB)
1292         CAIE    A,TVEC          ; MUST BE VECTOR
1293         JRST    WTYP1
1294         MOVE    B,1(AB)         ; GET IT
1295         GETYP   A,(B)           ; CHECK 1ST ELEMENTS TYPE
1296         CAIN    A,TPCODE        ; PURE CODE
1297         JRST    .+3
1298         CAIE    A,TCODE
1299         JRST    NRSUBR
1300         HLRM    B,(B)           ; CLOBEER SPECIAL COUNT FIELD
1301         MOVSI   A,TRSUBR
1302         JRST    FINIS
1303
1304 NRSUBR: ERRUUO  EQUOTE FIRST-ELEMENT-OF-VECTOR-NOT-CODE
1305
1306 ; ROUTINE TO GENERATE ENTRYY OTHER THAN FIRST TO RSUBRR
1307
1308 IMFUNCTION MENTRY,SUBR,[RSUBR-ENTRY]
1309
1310         ENTRY   2
1311
1312         GETYP   0,(AB)          ; TYPE OF ARG
1313         CAIE    0,TVEC          ; BETTER BE VECTOR
1314         JRST    WTYP1
1315         GETYP   0,2(AB)
1316         CAIE    0,TFIX
1317         JRST    WTYP2
1318         MOVE    B,1(AB)         ; GET VECTOR
1319         CAML    B,[-3,,0]
1320         JRST    BENTRY
1321         GETYP   0,(B)           ; FIRST ELEMENT
1322         CAIE    0,TRSUBR
1323         JRST    MENTR1
1324 MENTR2: GETYP   0,2(B)
1325         CAIE    0,TATOM
1326         JRST    BENTRY
1327         MOVE    C,3(AB)
1328         HRRM    C,2(B)          ; OFFSET INTO VECTOR
1329         HLRM    B,(B)
1330         MOVSI   A,TENTER
1331         JRST    FINIS
1332
1333 MENTR1: CAIE    0,TATOM
1334         JRST    BENTRY
1335         MOVE    B,1(B)          ; GET ATOM
1336         PUSHJ   P,IGVAL         ; GET VAL
1337         GETYP   0,A
1338         CAIE    0,TRSUBR
1339         JRST    BENTRY
1340         MOVE    C,1(AB)         ; RESTORE B
1341         MOVEM   A,(C)
1342         MOVEM   B,1(C)
1343         MOVE    B,C
1344         JRST    MENTR2
1345
1346 BENTRY: ERRUUO  EQUOTE BAD-VECTOR
1347
1348 ; SUBR TO GET ENTRIES OFFSET
1349
1350 MFUNCTION LENTRY,SUBR,[ENTRY-LOC]
1351
1352         ENTRY   1
1353
1354         GETYP   0,(AB)
1355         CAIE    0,TENTER
1356         JRST    WTYP1
1357         MOVE    B,1(AB)
1358         HRRZ    B,2(B)
1359         MOVSI   A,TFIX
1360         JRST    FINIS
1361
1362 ; RETURN FALSE
1363
1364 RTFALS: MOVSI   A,TFALSE
1365         MOVEI   B,0
1366         POPJ    P,
1367
1368 ;SUBROUTINE CALL FOR RSUBRs
1369 RCALL:  SUBM    M,(P)           ;CALCULATE PC's OFFSET IN THE RSUBR
1370         HRLI    0,400000        ; DONT LOSE IN MULTI SEG MODE
1371
1372         PUSHJ   P,@0            ;GO TO THE PROPER SUBROUTINE
1373         SUBM    M,(P)           ;RECONSTITUTE THE RSUBR's PC
1374         POPJ    P,
1375
1376
1377
1378 ;CHTYPE TAKES TWO ARGUMENTS.  ANY GOODIE AND A AN ATOMIC TYPE NAME
1379 ;IT CHECKS THE STORAGE ALLOCATION TYPES OF THE TWO ARE THE SAME AND
1380 ;IF THEY ARE CHANGES THE TYPE OF THE FIRST TO THAT NAME D IN THE SECOND
1381
1382 MFUNCTION CHTYPE,SUBR
1383
1384         ENTRY   2
1385         GETYP   A,2(AB)         ;FIRST CHECK THAT ARG 2 IS AN ATOM
1386         CAIE    A,TATOM
1387         JRST    NOTATOM
1388         MOVE    B,3(AB)         ;AND TYPE NAME
1389         PUSHJ   P,TYPLOO                ;GO LOOKUP TYPE
1390 TFOUND: HRRZ    B,(A)           ;GOBBLE THE SAT
1391         TRNE    B,CHBIT         ; SKIP IF CHTYPABLE
1392         JRST    CANTCH
1393         TRNE    B,TMPLBT        ; TEMPLAT
1394         HRLI    B,-1
1395         AND     B,[-1,,SATMSK]
1396         GETYP   A,(AB)          ;NOW GET TYPE TO HACK
1397         PUSHJ   P,SAT           ;FIND OUT ITS SAT
1398         JUMPE   A,TYPERR        ;COMPLAIN
1399         CAILE   A,NUMSAT
1400         JRST    CHTMPL          ; JUMP IF TEMPLATE DATA
1401         CAIE    A,(B)           ;DO THEY AGREE?
1402         JRST    TYPDIF          ;NO, COMPLAIN
1403 CHTMP1: MOVSI   A,(D)           ;GET NEW TYPE
1404         HRR     A,(AB)          ; FOR DEFERRED GOODIES
1405         JUMPL   B,CHMATC        ; CHECK IT
1406         MOVE    B,1(AB)         ;AND VALUE
1407         JRST    FINIS
1408
1409 CHTMPL: MOVE    E,1(AB)         ; GET ARG
1410         HLRZ    A,(E)
1411         ANDI    A,SATMSK
1412         MOVE    0,3(AB)         ; SEE IF TO "TEMPLATE"
1413         CAMN    0,IMQUOTE TEMPLATE
1414         JRST    CHTMP1
1415         TLNN    E,-1            ; SKIP IF RESTED
1416         CAIE    A,(B)
1417         JRST    TYPDIF
1418         JRST    CHTMP1
1419
1420 CHMATC: PUSH    TP,A
1421         PUSH    TP,1(AB)        ; SAVE GOODIE
1422         MOVSI   A,TATOM
1423         MOVE    B,3(AB)
1424         MOVSI   C,TATOM
1425         MOVE    D,IMQUOTE DECL
1426         PUSHJ   P,IGET          ; FIND THE DECL
1427         PUSH    TP,A
1428         PUSH    TP,B
1429         MOVE    C,(AB)
1430         MOVE    D,1(AB)         ; NOW GGO TO MATCH
1431         PUSHJ   P,TMATCH
1432         JRST    CHMAT1
1433         SUB     TP,[2,,2]
1434 CHMAT2: POP     TP,B
1435         POP     TP,A
1436         JRST    FINIS
1437
1438 CHMAT1: POP     TP,B
1439         POP     TP,A
1440         MOVE    C,-1(TP)
1441         MOVE    D,(TP)
1442         PUSHJ   P,TMATCH
1443         JRST    TMPLVI
1444         JRST    CHMAT2
1445
1446 TYPLOO: PUSHJ   P,TYPFND
1447         ERRUUO  EQUOTE BAD-TYPE-NAME
1448         POPJ    P,
1449
1450 TYPFND: HLRE    A,B             ; FIND DOPE WORDS
1451         SUBM    B,A             ; A POINTS TO IT
1452         HRRE    D,(A)           ; TYPE-CODE TO D
1453         JUMPE   D,CPOPJ
1454         ANDI    D,TYPMSK        ; FLUSH FUNNY BITS
1455         MOVEI   A,(D)
1456         ASH     A,1
1457         HRLI    A,(A)
1458         ADD     A,TYPVEC+1
1459 CPOPJ1: AOS     (P)
1460         POPJ    P,
1461
1462
1463 REPEAT 0,[
1464         MOVE    A,TYPVEC+1      ;GOBBLE DOWN TYPE VECTOR
1465         MOVEI   D,0             ;INITIALIZE TYPE COUNTER
1466 TLOOK:  CAMN    B,1(A)          ;CHECK THIS ONE
1467         JRST    CPOPJ1
1468         ADDI    D,1             ;BUMP COUNTER
1469         AOBJP   A,.+2           ;COUTN DOWN ON VECTOR
1470         AOBJN   A,TLOOK
1471         POPJ    P,
1472 CPOPJ1: AOS     (P)
1473         POPJ    P,
1474 ]
1475
1476 TYPDIF: ERRUUO  EQUOTE STORAGE-TYPES-DIFFER
1477
1478
1479 TMPLVI: ERRUUO  EQUOTE DECL-VIOLATION
1480 \f
1481
1482 ; FUNCTION TO ADD A NEW TYPE TO THE WORLD WITH GIVEN PRIMITIVE TYPE
1483
1484 MFUNCTION NEWTYPE,SUBR
1485
1486         ENTRY
1487
1488         HLRZ    0,AB            ; CHEC # OF ARGS
1489         CAILE   0,-4            ; AT LEAST 2
1490         JRST    TFA
1491         CAIGE   0,-6
1492         JRST    TMA             ; NOT MORE THAN 3
1493         GETYP   A,(AB)          ; GET 1ST ARGS TYPE (SHOULD BE ATOM)
1494         GETYP   C,2(AB)         ; SAME WITH SECOND
1495         CAIN    A,TATOM         ; CHECK
1496         CAIE    C,TATOM
1497         JRST    NOTATOM
1498
1499         MOVE    B,3(AB)         ; GET PRIM TYPE NAME
1500         PUSHJ   P,TYPLOO        ; LOOK IT UP
1501         HRRZ    A,(A)           ; GOBBLE SAT
1502         ANDI    A,SATMSK
1503         HRLI    A,TATOM         ; MAKE NEW TYPE
1504         PUSH    P,A             ; AND SAVE
1505         MOVE    B,1(AB)         ; SEE IF PREV EXISTED
1506         PUSHJ   P,TYPFND
1507         JRST    NEWTOK          ; DID NOT EXIST BEFORE
1508         MOVEI   B,2(A)          ; FOR POSSIBLE TMPLAT BIT
1509         HRRZ    A,(A)           ; GET SAT
1510         HRRZ    0,(P)           ; AND PROPOSED
1511         ANDI    A,SATMSK
1512         ANDI    0,SATMSK
1513         CAIN    0,(A)           ; SKIP IF LOSER
1514         JRST    NEWTFN          ; O.K.
1515
1516         ERRUUO  EQUOTE TYPE-ALREADY-EXISTS
1517
1518 NEWTOK: POP     P,A
1519         MOVE    B,1(AB)         ; NEWTYPE NAME
1520         PUSHJ   P,INSNT         ; MUNG IN NEW TYPE
1521
1522 NEWTFN: CAML    AB,[-5,,]       ; SKIP IF TEMPLAT SUPPLIED
1523         JRST    NEWTF1
1524         MOVEI   0,TMPLBT        ; GET THE BIT
1525         IORM    0,-2(B)         ; INTO WORD
1526         MOVE    A,(AB)          ; GET TYPE NAME
1527         MOVE    B,1(AB)
1528         MOVSI   C,TATOM
1529         MOVE    D,IMQUOTE DECL
1530         PUSH    TP,4(AB)        ; GET TEMLAT
1531         PUSH    TP,5(AB)
1532         PUSHJ   P,IPUT
1533 NEWTF1: MOVE    A,(AB)
1534         MOVE    B,1(AB)         ; RETURN NAME
1535         JRST    FINIS
1536
1537 ; SET  UP GROWTH FIELDS
1538
1539 IGROWT: SKIPA   A,[111100,,(C)]
1540 IGROWB: MOVE    A,[001100,,(C)]
1541         HLRE    B,C
1542         SUB     C,B             ; POINT TO DOPE WORD
1543         MOVE    B,TYPIC ; INDICATED GROW BLOCK
1544         DPB     B,A
1545         POPJ    P,
1546
1547 INSNT:  PUSH    TP,A
1548         PUSH    TP,B            ; SAVE NAME OF NEWTYPE
1549         MOVE    C,TYPBOT+1      ; CHECK GROWTH NEED
1550         CAMGE   C,TYPVEC+1
1551         JRST    ADDIT           ; STILL ROOM
1552 GAGN:   PUSHJ   P,IGROWB        ; SETUP BOTTOM GROWTH
1553         SKIPE   C,EVATYP+1
1554         PUSHJ   P,IGROWT        ; SET UP TOP GROWTH
1555         SKIPE   C,APLTYP+1
1556         PUSHJ   P,IGROWT
1557         SKIPE   C,PRNTYP+1
1558         PUSHJ   P,IGROWT
1559         MOVE    C,[11.,,5]      ; SET UP INDICATOR FOR AGC
1560         PUSHJ   P,AGC           ; GROW THE WORLD
1561         AOJL    A,GAGN          ; BAD AGC LOSSAGE
1562         MOVE    0,[-101,,-100]
1563         ADDM    0,TYPBOT+1      ; FIX UP POINTER
1564
1565 ADDIT:  MOVE    C,TYPVEC+1
1566         SUB     C,[2,,2]        ; ALLOCATE ROOM
1567         MOVEM   C,TYPVEC+1
1568         HLRE    B,C             ; PREPARE TO BLT
1569         SUBM    C,B             ; C POINTS DOPE WORD END
1570         HRLI    C,2(C)          ; GET BLT AC READY
1571         BLT     C,-3(B)
1572         POP     TP,-1(B)        ; CLOBBER IT IN
1573         POP     TP,-2(B)
1574         HLRE    C,TYPVEC+1      ; GET CODE
1575         MOVNS   C
1576         ASH     C,-1
1577         SUBI    C,1
1578         MOVE    D,-1(B)         ; B HAS POINTER TO TYPE VECTOR DOPE WORDS
1579         MOVEI   0,(D)
1580         CAIG    0,HIBOT         ; IS ATOM PURE?
1581          JRST   ADDNOI          ; NO, SO NO HACKING REQUIRED
1582         PUSH    P,C
1583         MOVE    B,D
1584         PUSHJ   P,IMPURIF       ; DO IMPURE OF ATOM
1585         MOVE    C,TYPVEC+1
1586         HLRE    B,C
1587         SUBM    C,B             ; RESTORE B
1588         POP     P,C
1589         MOVE    D,-1(B)         ; RESTORE D
1590 ADDNOI: HLRE    A,D
1591         SUBM    D,A
1592         TLO     C,400000
1593         HRRM    C,(A)           ; INTO "GROWTH" FIELD
1594         POPJ    P,
1595
1596 \f
1597 ; Interface to interpreter for setting up tables associated with
1598 ;       template data structures.
1599 ;       A/      <\b-name of type>\b-
1600 ;       B/      <\b-length ins>\b-
1601 ;       C/      <\b-uvector of garbage collector code or 0>
1602 ;       D/      <\b-uvector of GETTERs>\b-
1603 ;       E/      <\b-uvector of PUTTERs>\b-
1604
1605 CTMPLT: SUBM    M,(P)           ; could possibly gc during this stuff
1606         PUSH    TP,$TATOM       ; save name of type
1607         PUSH    TP,A
1608         PUSH    P,B             ; save length instr
1609         HLRE    A,TD.LNT+1      ; check for template slots left?
1610         HRRZ    B,TD.LNT+1
1611         SUB     B,A             ; point to dope words
1612         HLRZ    B,1(B)          ; get real length
1613         ADDI    A,-2(B)
1614         JUMPG   A,GOODRM        ; jump if ok
1615
1616         PUSH    TP,$TUVEC       ; save getters and putters
1617         PUSH    TP,C
1618         PUSH    TP,$TUVEC       ; save getters and putters
1619         PUSH    TP,D
1620         PUSH    TP,$TUVEC
1621         PUSH    TP,E
1622         MOVEI   A,10-2(B)       ; grow it 10 by copying remember d.w. length
1623         PUSH    P,A             ; save new length
1624         PUSHJ   P,CAFRE1        ; get frozen uvector
1625         ADD     B,[10,,10]      ; rest it down some
1626         HRL     C,TD.LNT+1      ; prepare to BLT in
1627         MOVEM   B,TD.LNT+1      ; and save as new length vector
1628         HRRI    C,(B)           ; destination
1629         ADD     B,(P)           ; final destination address
1630         BLT     C,-12(B)
1631         MOVE    A,(P)           ; length for new getters
1632         PUSHJ   P,CAFRE1
1633         HRL     C,TD.GET+1      ; get old for copy
1634         MOVEM   B,TD.GET+1
1635         PUSHJ   P,DOBLTS        ; go fixup new uvector
1636         MOVE    A,(P)           ; finally putters
1637         PUSHJ   P,CAFRE1
1638         HRL     C,TD.PUT+1
1639         MOVEM   B,TD.PUT+1
1640         PUSHJ   P,DOBLTS        ; go fixup new uvector
1641         MOVE    A,(P)           ; finally putters
1642         PUSHJ   P,CAFRE1
1643         HRL     C,TD.AGC+1
1644         MOVEM   B,TD.AGC+1
1645         PUSHJ   P,DOBLTS        ; go fixup new uvector
1646         SUB     P,[1,,1]        ; flush stack craft
1647         MOVE    E,(TP)
1648         MOVE    D,-2(TP)
1649         MOVE    C,-4(TP)                        ;GET TD.AGC
1650         SUB     TP,[6,,6]
1651
1652 GOODRM: MOVE    B,TD.LNT+1      ; move down to fit new guy
1653         SUB     B,[1,,1]        ; will always win due to prev checks
1654         MOVEM   B,TD.LNT+1
1655         HRLI    B,1(B)
1656         HLRE    A,TD.LNT+1
1657         MOVNS   A
1658         ADDI    A,-1(B)         ; A/ final destination
1659         BLT     B,-1(A)
1660         POP     P,(A)           ; new length ins munged in
1661         HLRE    A,TD.LNT+1
1662         MOVNS   A               ; A/ offset for other guys
1663         PUSH    P,A             ; save it
1664         ADD     A,TD.GET+1      ; point for storing uvs of ins
1665         MOVEM   D,-1(A)
1666         MOVE    A,(P)
1667         ADD     A,TD.PUT+1
1668         MOVEM   E,-1(A)         ; store putter also
1669         MOVE    A,(P)
1670         ADD     A,TD.AGC+1
1671         MOVEM   C,-1(A)         ; store putter also
1672         POP     P,A             ; compute primtype
1673         ADDI    A,NUMSAT
1674         PUSH    P,A
1675         MOVE    B,(TP)          ; ready to mung type vector
1676         SUB     TP,[2,,2]
1677         PUSHJ   P,TYPFND        ; CHECK TO SEE WHETHER TEMPLATE EXISTS
1678         JRST    NOTEM
1679         POP     P,C             ; GET SAT
1680         HRRM    C,(A)
1681         JRST    MPOPJ
1682 NOTEM:  POP     P,A             ; RESTORE SAT
1683         HRLI    A,TATOM         ; GET TYPE
1684         PUSHJ   P,INSNT         ; INSERT INTO VECTOR
1685         JRST    MPOPJ
1686
1687 ; this routine copies GET and PUT vectors into new ones
1688
1689 DOBLTS: HRRI    C,(B)
1690         ADD     B,-1(P)
1691         BLT     C,-11(B)        ; zap those guys in
1692         MOVEI   A,TUVEC         ; mung in uniform type
1693         PUTYP   A,(B)
1694         MOVEI   C,-7(B)         ; zero out remainder of uvector
1695         HRLI    C,-10(B)
1696         SETZM   -1(C)
1697         BLT     C,-1(B)
1698         POPJ    P,
1699 \f
1700
1701 ; FUNCTIONS TO SET UP EVALUATION AND APPLICATION RULES FOR DATA TYPES
1702
1703 MFUNCTION EVALTYPE,SUBR
1704
1705         ENTRY
1706
1707         PUSHJ   P,CHKARG        ; VERIFY WINNAGE IN ARGS
1708         MOVEI   A,EVATYP        ; POINT TO TABLE
1709         MOVEI   E,EVTYPE        ; POINT TO PURE VERSION
1710         MOVEI   0,EVAL
1711 TBLCAL: PUSHJ   P,TBLSET        ; SETUP TABLE ENTRY
1712         JRST    FINIS
1713
1714 MFUNCTION APPLYTYPE,SUBR
1715
1716         ENTRY
1717
1718         PUSHJ   P,CHKARG
1719         MOVEI   A,APLTYP        ; POINT TO APPLY TABLE
1720         MOVEI   E,APTYPE        ; PURE TABLE
1721         MOVEI   0,APPLY
1722         JRST    TBLCAL
1723
1724
1725 MFUNCTION PRINTTYPE,SUBR
1726
1727         ENTRY
1728
1729         PUSHJ   P,CHKARG
1730         MOVEI   A,PRNTYP        ; POINT TO APPLY TABLE
1731         MOVEI   E,PRTYPE        ; PURE TABLE
1732         MOVEI   0,PRINT
1733         JRST    TBLCAL
1734
1735 ; CHECK ARGS AND SETUP FOR TABLE HACKER
1736
1737 CHKARG: JUMPGE  AB,TFA
1738         CAMGE   AB,[-5,,]
1739         JRST    TMA
1740         GETYP   A,(AB)          ; 1ST MUST BE TYPE NAME
1741         CAIE    A,TATOM
1742         JRST    WTYP1
1743         MOVE    B,1(AB)         ; GET ATOM
1744         PUSHJ   P,TYPLOO        ; VERIFY THAT IT IS A TYPE
1745         PUSH    P,D             ; SAVE TYPE NO.
1746         MOVEI   D,-1            ; INDICATE FUNNYNESS
1747         CAML    AB,[-3,,]       ; SKIP IF 2 OR MORE
1748         JRST    TY1AR
1749         HRRZ    A,(A)           ; GET SAT
1750         ANDI    A,SATMSK
1751         PUSH    P,A
1752         GETYP   A,2(AB)         ; GET 2D TYPE
1753         CAIE    A,TATOM         ; EITHER TYPE OR APPLICABLE
1754         JRST    TRYAPL          ; TRY APPLICABLE
1755         MOVE    B,3(AB)         ; VERIFY IT IS A TYPE
1756         PUSHJ   P,TYPLOO
1757         HRRZ    A,(A)           ; GET SAT
1758         ANDI    A,SATMSK
1759         POP     P,C             ; RESTORE SAVED SAT
1760         CAIE    A,(C)           ; SKIP IF A WINNER
1761         JRST    TYPDIF          ; REPORT ERROR
1762 TY1AR:  POP     P,C             ; GET SAVED TYPE
1763         MOVEI   B,0             ; TELL THAT WE ARE A TYPE
1764         POPJ    P,
1765
1766 TRYAPL: PUSHJ   P,APLQ          ; IS THIS APPLICABLE
1767         JRST    NAPT
1768         SUB     P,[1,,1]
1769         MOVE    B,2(AB)         ; RETURN SAME
1770         MOVE    D,3(AB)
1771         POP     P,C
1772         POPJ    P,
1773
1774 \f
1775 ; HERE TO PUT ENTRY IN APPROPRIATE TABLE
1776
1777 TBLSET: PUSH    TP,B
1778         PUSH    TP,D            ; SAVE VALUE
1779         PUSH    TP,$TFIX
1780         PUSH    TP,A
1781         PUSH    P,C             ; SAVE TYPE BEING HACKED
1782         PUSH    P,E
1783         SKIPE   B,1(A)          ; SKIP IF VECTOR DOESN'T EXIST YET
1784         JRST    TBL.OK
1785         MOVE    B,-2(TP)        ; CHECK FOR RETURN IT HACK
1786         SKIPN   -3(TP)
1787         CAIE    B,-1
1788         JRST    .+2
1789         JRST    RETPM2
1790         HLRE    A,TYPBOT+1      ; GET CURRENT TABLE LNTH
1791         MOVNS   A
1792         ASH     A,-1
1793         PUSH    P,0
1794         PUSHJ   P,IVECT         ; GET VECTOR
1795         POP     P,0
1796         MOVE    C,(TP)          ; POINT TO RETURN POINT
1797         MOVEM   B,1(C)          ; SAVE VECTOR
1798
1799 TBL.OK: POP     P,E
1800         POP     P,C             ; RESTORE TYPE
1801         SUB     TP,[2,,2]
1802         POP     TP,D
1803         POP     TP,A
1804         JUMPN   A,TBLOK1        ; JUMP IF FUNCTION ETC. SUPPLIED
1805         CAIN    D,-1
1806         JRST    TBLOK1
1807         CAILE   D,NUMPRI        ; SKIP IF ORIGINAL TYPE
1808         MOVNI   E,(D)           ; CAUSE E TO ENDUP 0
1809         ADDI    E,(D)           ; POINT TO PURE SLOT
1810 TBLOK1: ADDI    C,(C)           ; POINT TO VECTOR SLOT
1811         ADDI    C,(B)
1812         CAIN    D,-1
1813         JRST    RETCUR
1814         JUMPN   A,OK.SET        ; OK TO CLOBBER
1815         ADDI    B,(D)           ; POINT TO TARGET TYPE'S SLOT
1816         ADDI    B,(D)           ; POINT TO TARGET TYPE'S SLOT
1817         SKIPN   A,(B)           ; SKIP IF WINNER
1818         SKIPE   1(B)            ; SKIP IF LOSER
1819         SKIPA   D,1(B)          ; SETUP D
1820         JRST    CH.PTB          ; CHECK PURE TABLE
1821
1822 OK.SET: CAIN    0,(D)           ; SKIP ON RESET
1823         SETZB   A,D
1824         MOVEM   A,(C)           ; STORE
1825         MOVEM   D,1(C)
1826 RETAR1: MOVE    A,(AB)          ; RET TYPE
1827         MOVE    B,1(AB)
1828         JRST    FINIS
1829
1830 CH.PTB: MOVEI   A,0
1831         MOVE    D,[SETZ NAPT]
1832         JUMPE   E,OK.SET
1833         MOVE    D,(E)
1834         JRST    OK.SET
1835
1836 RETPM2: SUB     TP,[4,,4]
1837         SUB     P,[2,,2]
1838         ASH     C,1
1839         SOJA    E,RETPM4
1840
1841 RETCUR: SKIPN   A,(C)
1842         SKIPE   1(C)
1843         SKIPA   B,1(C)
1844         JRST    RETPRM
1845
1846         JUMPN   A,CPOPJ
1847 RETPM1: MOVEI   A,0
1848         JUMPL   B,RTFALS
1849         CAMN    B,1(E)
1850         JRST    .+3
1851         ADDI    A,2
1852         AOJA    E,.-3
1853
1854 RETPM3: ADD     A,TYPVEC+1
1855         MOVE    B,3(A)
1856         MOVE    A,2(A)
1857         POPJ    P,
1858
1859 RETPRM: SUBI    C,(B)           ; UNDO BADNESS
1860 RETPM4: CAIG    C,NUMPRI*2
1861         SKIPG   1(E)
1862         JRST    RTFALS
1863
1864         MOVEI   A,-2(C)
1865         JRST    RETPM3
1866
1867 CALLTY: MOVE    A,TYPVEC
1868         MOVE    B,TYPVEC+1
1869         POPJ    P,
1870
1871 MFUNCTION ALLTYPES,SUBR
1872
1873         ENTRY   0
1874
1875         MOVE    A,TYPVEC
1876         MOVE    B,TYPVEC+1
1877         JRST    FINIS
1878
1879 ;\f
1880
1881 ;FUNCTION TO RETURN TYPE OF ELEMENTS IN A UVECTOR
1882
1883 MFUNCTION UTYPE,SUBR
1884
1885         ENTRY   1
1886
1887         GETYP   A,(AB)          ;GET U VECTOR
1888         PUSHJ   P,SAT
1889         CAIE    A,SNWORD
1890         JRST    WTYP1
1891         MOVE    B,1(AB)         ; GET UVECTOR
1892         PUSHJ   P,CUTYPE
1893         JRST    FINIS
1894
1895 CUTYPE: HLRE    A,B             ;GET -LENGTH
1896         HRRZS   B
1897         SUB     B,A             ;POINT TO TYPE WORD
1898         GETYP   A,(B)
1899         JRST    ITYPE           ; GET NAME OF TYPE
1900
1901 ; FUNCTION TO CHANGE UNIFORM TYPE OF A VECTOR
1902
1903 MFUNCTION CHUTYPE,SUBR
1904
1905         ENTRY   2
1906
1907         GETYP   A,2(AB)         ;GET 2D TYPE
1908         CAIE    A,TATOM
1909         JRST    NOTATO
1910         GETYP   A,(AB)          ; CALL WITH UVECTOR?
1911         PUSHJ   P,SAT
1912         CAIE    A,SNWORD
1913         JRST    WTYP1
1914         MOVE    A,1(AB)         ; GET UV POINTER
1915         MOVE    B,3(AB)         ;GET ATOM
1916         PUSHJ   P,CCHUTY
1917         MOVE    A,(AB)          ; RETURN UVECTOR
1918         MOVE    B,1(AB)
1919         JRST    FINIS
1920
1921 CCHUTY: PUSH    TP,$TUVEC
1922         PUSH    TP,A
1923         PUSHJ   P,TYPLOO        ;LOOK IT UP
1924         HRRZ    B,(A)           ;GET SAT
1925         TRNE    B,CHBIT
1926         JRST    CANTCH
1927         ANDI    B,SATMSK
1928         SKIPGE  MKTBS(B)
1929         JRST    CANTCH
1930         HLRE    C,(TP)          ;-LENGTH
1931         HRRZ    E,(TP)
1932         SUB     E,C             ;POINT TO TYPE
1933         GETYP   A,(E)           ;GET TYPE
1934         JUMPE   A,WIN0          ;ALLOW TYPE "LOSE" TO CHANGE TO ANYTHING
1935         PUSHJ   P,SAT           ;GET SAT
1936         JUMPE   A,TYPERR
1937         CAIE    A,(B)           ;COMPARE
1938         JRST    TYPDIF
1939 WIN0:   ADDI    D,.VECT.
1940         HRLM    D,(E)           ;CLOBBER NEW ONE
1941         POP     TP,B
1942         POP     TP,A
1943         POPJ    P,
1944
1945 CANTCH: PUSH    TP,$TATOM
1946         PUSH    TP,EQUOTE CANT-CHTYPE-INTO
1947         PUSH    TP,2(AB)
1948         PUSH    TP,3(AB)
1949         MOVEI   A,2
1950         JRST    CALER
1951
1952 NOTATOM:
1953         PUSH    TP,$TATOM
1954         PUSH    TP,EQUOTE NON-ATOMIC-ARGUMENT
1955         PUSH    TP,(AB)
1956         PUSH    TP,1(AB)
1957         MOVEI   A,2
1958         JRST    CALER
1959
1960
1961 \f
1962 ; SUBROUTINE TO LEAVE MUDDLE CLOSING ALL CHANNELS ON THE WAY
1963
1964 MFUNCTION QUIT,SUBR
1965
1966         ENTRY   0
1967
1968
1969         PUSHJ   P,CLOSAL        ; DO THE CLOSES
1970         PUSHJ   P,%KILLM
1971         JRST    IFALSE          ; JUST IN CASE
1972
1973 CLOSAL: MOVEI   B,CHNL0+2       ; POINT TO 1ST (NOT INCLUDING TTY I/O)
1974         MOVE    PVP,PVSTOR+1
1975         MOVE    TVP,REALTV+1(PVP)
1976         SUBI    B,(TVP)
1977         HRLS    B
1978         ADD     B,TVP
1979         PUSH    TP,$TVEC
1980         PUSH    TP,B
1981         PUSH    P,[N.CHNS-1]    ; MAX NO. OF CHANS
1982
1983 CLOSA1: MOVE    B,(TP)
1984         ADD     B,[2,,2]
1985         MOVEM   B,(TP)
1986         HLLZS   -2(B)
1987         SKIPN   C,-1(B)         ; THIS ONE OPEN?
1988         JRST    CLOSA4          ; NO
1989         CAME    C,TTICHN+1
1990         CAMN    C,TTOCHN+1
1991         JRST    CLOSA4
1992         PUSH    TP,-2(B)        ; PUSH IT
1993         PUSH    TP,-1(B)
1994         MCALL   1,FCLOSE                ; CLOSE IT
1995 CLOSA4: SOSLE   (P)             ; COUNT DOWN
1996         JRST    CLOSA1
1997
1998
1999         SUB     TP,[2,,2]
2000         SUB     P,[1,,1]
2001
2002 CLOSA3: SKIPN   B,CHNL0+1
2003         POPJ    P,
2004         PUSH    TP,(B)
2005         HLLZS   (TP)
2006         PUSH    TP,1(B)
2007         HRRZ    B,(B)
2008         MOVEM   B,CHNL0+1
2009         MCALL   1,FCLOSE
2010         JRST    CLOSA3
2011 \f
2012
2013 IMPURE
2014
2015 WHOAMI: 0               ; SYAYS WHETHER I AM REALLY A MUDDLE OR SOME HACK
2016
2017
2018 ;GARBAGE COLLECTORS PDLS
2019
2020
2021 GCPDL:  -GCPLNT,,GCPDL
2022
2023         BLOCK   GCPLNT
2024
2025
2026 PURE
2027
2028 MUDSTR: ASCII /MUDDLE \7f\7f\7f/
2029 STRNG:  -1
2030         -1
2031         -1
2032         ASCIZ / IN OPERATION./
2033
2034 ;MARKED PDLS FOR GC PROCESS
2035
2036 VECTGO
2037 ; DUMMY FRAME FOR INITIALIZER CALLS
2038
2039         TENTRY,,LISTEN
2040         0
2041         .-3
2042         0
2043         0
2044         -ITPLNT,,TPBAS-1
2045         0
2046
2047 TPBAS:  BLOCK   ITPLNT+PDLBUF
2048         GENERAL
2049         ITPLNT+2+PDLBUF+7,,0
2050
2051
2052 VECRET
2053
2054
2055 $TMATO: TATOM,,-1
2056
2057 END
2058 \f