<mdl.int>/main.353

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