MUDDLE/nmain.14

   1 TITLE MAIN LOOP AND GLOBALLY REFERENCED SUBROUTINES
   2 RELOCA
   3 MAIN==1 ;THIS INCLUDES ONCE ONLY CODE
   4
   5 NINT==72.       ;NUMBER OF POSSIBLE ITS INTERRUPTS
   6 NASOCS==159.    ;LENGTH OF ASSOCIATION VECTOR
   7
   8
   9 .GLOBAL PATCH,TBINIT,LERR,LPROG,PIDSTO,PROCID,PTIME,GCPDL,INTFLG,WTYP1,WTYP2
  10 .GLOBAL PAT,PDLBUF,INTINT,PARNEW,GCPVP,START,SWAP,ICR,SPBASE,TPBASE,GLOBAS,GLOBSP,TPBAS
  11 .GLOBAL TOPLEVEL,INTNUM,INTVEC,INTOBL,ASOVEC,ERROBL,MAINPR,RESFUN,.BLOCK,ASOLNT,NODES
  12 .GLOBAL WRONGT,TTYOPE,OPEN,CLOSE,IOT,ILVAL,MESS,FACTI
  13
  14 .INSRT MUDDLE >
  15
  16 VECTGO
  17 TVBASE":        BLOCK   TVLNT
  18         GENERAL
  19         TVLNT+2,,0
  20 TVLOC=TVBASE
  21
  22
  23
  24 ;INITIAL TYPE TABLE
  25
  26 TYPVLC":        BLOCK   2*NUMPRI+2
  27         GENERAL
  28         2*NUMPRI+2+2,,0
  29
  30 TYPTP==.-2                      ; POINT TO TOP OF TYPES
  31
  32 INTVCL: BLOCK   2*NINT
  33         TLIST,,0
  34         2*NINT+2,,0
  35
  36 NODLST: TTP,,0
  37         0
  38         TASOC,,0
  39         BLOCK   ASOLNT-3
  40         GENERAL+<SASOC,,0>
  41         ASOLNT+2,,0
  42
  43
  44 ASOVCL: BLOCK   NASOCS
  45         TASOC,,0
  46         NASOCS+2,,0
  47
  48
  49
  50 ;THESE ENTRIES MUST NOT MOVE DURING INITILAIZATION
  51
  52 ADDTV TVEC,[-2*NUMPRI-2,,TYPVLC]
  53 TYPVEC==TVOFF-1
  54
  55 ADDTV TVEC,TYPTP
  56 TYPTOP==TVOFF-1                 ; POINT TO CURRENT TOP OF TYPE VECTORS
  57
  58 ;ENTRY FOR ROOT,TTICHN,TTOCHN
  59
  60 ADDTV TCHAN,0
  61 TTICHN==TVOFF-1
  62
  63 ADDTV TCHAN,0
  64 TTOCHN==TVOFF-1
  65
  66 ADDTV TOBLS,0
  67 ROOT==TVOFF-1
  68 ADDTV TOBLS,0
  69 INTOBL==TVOFF-1
  70 ADDTV TOBLS,0
  71 ERROBL==TVOFF-1
  72 ADDTV TVEC,0
  73 GRAPHS==TVOFF-1
  74 ADDTV TFIX,0
  75 INTNUM==TVOFF-1
  76 ADDTV TVEC,[-2*NINT,,INTVCL]
  77 INTVEC==TVOFF-1
  78 ADDTV TUVEC,[-NASOCS,,ASOVCL]
  79 ASOVEC==TVOFF-1
  80
  81 DEFINE ADDCHN N
  82         ADDTV TCHAN,0
  83         CHANL!N==TVOFF-1
  84         .GLOBAL CHANL!N
  85         TERMIN
  86
  87 REPEAT 16.,ADDCHN \.RPCNT
  88
  89 ADDTV TASOC,[-ASOLNT,,NODLST]
  90 NODES==TVOFF-1
  91
  92
  93 ;GLOBAL SPECIAL PDL
  94
  95 GSP:    BLOCK   GSPLNT
  96         GENERAL
  97         GSPLNT+2,,0
  98
  99 ADDTV TVEC,[-GSPLNT,,GSP]
 100 GLOBASE==TVOFF-1
 101 GLOB==.-2
 102 ADDTV TVEC,GLOB
 103 GLOBSP==TVOFF-1 ;ENTRY FOR CURRENT POINTER TO GLOBAL SP
 104
 105 ;PROCESS VECTOR FOR GARBAGE COLLECTOR PROCESS
 106
 107 GCPVP:  BLOCK   PVLNT*2
 108         GENERAL
 109         PVLNT*2+2,,0
 110
 111
 112 VECRET
 113
 114 ;INITIAL PROCESS VECTOR
 115
 116 PVBASE":        BLOCK   PVLNT*2
 117         GENERAL
 118         PVLNT*2+2,,0
 119 PVLOC==PVBASE
 120
 121
 122 ;ENTRY FOR PROCESS I.D.
 123
 124         ADDPV   TFIX,1,PROCID
 125 ;THE FOLLOWING IRP MAKES SPACE FO9 SAVED ACS
 126
 127 ZZZ==.
 128
 129 IRP A,,[0,A,B,C,D,E,PVP,TVP,PP,AB,TB,TP,SP,P]B,,[0
 130 0,0,0,0,0,TPVP,TTVP,TPP,TAB,TTB,TTP,TSP,TPDL]
 131
 132 LOC PVLOC+2*A
 133 A!STO=.-PVBASE
 134 B,,0
 135 0
 136 TERMIN
 137
 138 PVLOC==PVLOC+16.*2
 139 LOC ZZZ
 140
 141 ;ADD LAST ERROR AND PROG GOODIE
 142
 143 ADDPV TTB,0,LERR
 144
 145 ADDPV TTB,0,LPROG
 146
 147
 148
 149 ADDPV TTB,0,TBINIT
 150 ADDPV TTP,0,TPBASE
 151 ADDPV TSP,0,SPBASE
 152 ADDPV TPDL,0,PBASE
 153 ADDPV 0,0,RESFUN
 154 ADDPV TLIST,0,.BLOCK
 155 ADDPV TLIST,0,MESS
 156 ADDPV TACT,0,FACTI
 157
 158
 159
 160 ;MAIN LOOP AND STARTUP
 161
 162 ;SECONDARY STARTUP
 163
 164 START:
 165         MOVE    PVP,MAINPR              ;MAKE SURE WE START IN THE MAIN PROCESS
 166         PUSHJ   P,INTINT        ;INITIALIZE INTERRUPT HANDLER
 167         PUSHJ   P,TTYOPEN               ;OPEN THE TTY
 168 MIO:    MOVEI   B,[ASCIZ /MUDDLE IN OPERATION./]
 169         PUSHJ   P,MSGTYP        ;TYPE OUT TO USER
 170
 171         XCT     MESSAG          ;MAYBE PRINT A MESSAGE
 172
 173 RESTART:                                ;RESTART A PROCESS
 174 STP:
 175         HRR     TB,TBINIT+1(PVP)        ;POINT INTO STACK AT START
 176         MOVE    PP,PPSAV(TB)    ;FLUSH FAILPOINTS
 177         JRST    CONTIN
 178
 179         MQUOTE  TOPLEVEL
 180 TOPLEVEL:
 181         MCALL   0,LISTEN
 182         JRST    TOPLEVEL
 183
 184 MFUNCTION LISTEN,SUBR
 185
 186         ENTRY
 187
 188         PUSH    P,[0]   ;FLAG: DON'T PRINT ERROR MSG
 189         JRST    ER1
 190
 191 MFUNCTION ERROR,SUBR
 192
 193         ENTRY
 194         PUSH    P,[-1]          ;PRINT ERROR FLAG
 195
 196 ER1:    PUSH    TP,$TMATOM      ;BIND CHANNELS,OBLIST AND EOF
 197         PUSH    TP,MQUOTE INCHAN
 198         PUSH    TP,TTICHN(TVP)  ;TYPE OF TTY CHAN
 199         PUSH    TP,TTICHN+1(TVP)        ;AND ITS VALUE
 200         PUSH    TP,[0]  ;DUMMY FOR SPECBIND
 201         PUSH    TP,[0]
 202
 203         PUSH    TP,$TMATOM
 204         PUSH    TP,MQUOTE OUTCHAN
 205         PUSH    TP,TTOCHN(TVP)  ;TYPE OF OUT CHNA
 206         PUSH    TP,TTOCHN+1(TVP)        ;AND IT S VAL
 207         PUSH    TP,[0]
 208         PUSH    TP,[0]
 209
 210         PUSH    TP,$TMATOM
 211         PUSH    TP,MQUOTE OBLIST
 212         PUSH    TP,ROOT(TVP)    ;DEFAULT OBLIST TYPE
 213         PUSH    TP,ROOT+1(TVP)  ;AND VALUE
 214         PUSH    TP,[0]
 215         PUSH    TP,[0]
 216
 217         PUSH    TP,$TMATOM
 218         PUSH    TP,MQUOTE EOF
 219         PUSH    TP,$TLIST       ;DEFAULT EOF- NIL
 220         PUSH    TP,[0]
 221         PUSH    TP,[0]
 222         PUSH    TP,[0]
 223
 224         MOVE    B,MQUOTE LER,[LERR ]INTRUP
 225         PUSHJ   P,ILVAL         ;GET VALUE OF LAST ERR
 226         PUSH    TP,[TATOM,,-1]          ;FOR BINDING
 227         PUSH    TP,MQUOTE LER,[LERR ]INTRUP
 228         PUSH    TP,$TTB
 229         ADD     B,[1,,0]                ;INCREASE LEVEL
 230         HRR     B,TB
 231         HLRZ    A,B             ;AND SAVE NEW LEVEL
 232         PUSH    P,A
 233         PUSH    TP,B
 234         PUSH    TP,[0]
 235         PUSH    TP,[0]
 236
 237         PUSHJ   P,SPECBIND      ;BIND THE CRETANS
 238         MOVE    A,-1(P)         ;RESTORE SWITHC
 239         JUMPE   A,NOERR         ;IF 0, DONT PRINT ERROR MESS
 240         PUSH    TP,$TATOM
 241         PUSH    TP,MQUOTE *ERROR*
 242         MCALL   1,PRINT         ;PRINT THE MESSAGE
 243 NOERR:  MOVE    C,AB            ;GET A COPY OF AB
 244
 245 ERRLP:  JUMPGE  C,LEVPRT        ;IF NONE, RE-ENTER READ-EVAL-PRINT LOOP
 246         PUSH    TP,$TAB
 247         PUSH    TP,C
 248         PUSH    TP,(C)          ;GET AN ARGS TYPE
 249         PUSH    TP,1(C)         ;AND VALUE
 250         MCALL   1,PRINT
 251         POP     TP,C
 252         SUB     TP,[1,,1]
 253         ADD     C,[2,,2]        ;BUMP SAVED AB
 254         JRST    ERRLP           ;AND CONTINUE
 255
 256 LEVPRT: PUSH    TP,$TATOM
 257         PUSH    TP,MQUOTE LISTENING-AT-LEVEL
 258         MCALL   1,PRINT         ;PRINT LEVEL
 259         PUSH    TP,$TFIX        ;READY TO PRINT LEVEL
 260         MOVE    A,(P)           ;GET LEVEL
 261         SUB     P,[2,,2]        ;AND POP STACK
 262         PUSH    TP,A
 263         MCALL   1,PRIN1         ;PRINT WITHOUT SPACES ETC.
 264         PUSH    TP,$TATOM       ;NOW PROCESS
 265         PUSH    TP,MQUOTE [ PROCESS ]
 266         MCALL   1,PRINC         ;DONT SLASHIFY SPACES
 267         PUSH    TP,PROCID(PVP)  ;NOW ID
 268         PUSH    TP,PROCID+1(PVP)
 269         MCALL   1,PRIN1
 270
 271 MAINLP: PUSHJ   P,CRLF          ;TYPE OUT A CARRIAGE RETURN, LINEFEED
 272         MCALL   0,READ
 273         PUSH    TP,A
 274         PUSH    TP,B
 275         MCALL   1,EVAL
 276         PUSH    TP,A
 277         PUSH    TP,B
 278         MCALL   1,PRINT
 279         JRST    MAINLP
 280
 281
 282
 283 ;FUNCTION TO DO ERROR RETURN
 284
 285 MFUNCTION ERRET,SUBR
 286
 287         ENTRY
 288         CAML    AB,[-1,,0]      ;CHECK FOR AN ARG
 289         JRST    STP             ;NO ARGS, RESTART PROCESS
 290         CAML    AB,[-3,,0]      ;FRAME SUPPLIED
 291         JRST    ERRET1          ;NO
 292         ADD     AB,[2,,2]       ;POINT AB AT FRAME ARG
 293         PUSHJ   P,FRCHECK       ;CHECK IT OUT
 294         SUB     AB,[2,,2]       ;POINT IT BACK
 295
 296
 297 ERRET1: MOVE    B,MQUOTE LER,[LERR ]INTRUP
 298         PUSHJ   P,ILVAL         ;GET VALUE
 299         HRR     TB,B            ;AND CLOBBER
 300         CAMGE   AB,[-3,,0]      ;FRAME SUPPLIED?
 301         HRR     TB,3(AB)        ;YES, RESTORE TB FROM FRAME
 302 RTA:    MOVE    A,(AB)
 303         MOVE    B,1(AB)         ;AND GET RETURNED VALUE
 304         JRST    FINIS
 305
 306
 307 MFUNCTION       FRAME,SUBR
 308         ENTRY
 309         MOVE    B,MQUOTE LER,[LERR ]INTRUP
 310         PUSHJ   P,ILVAL
 311         JUMPGE  AB,FRM1         ;FRAME ARGUMENT SUPPLIED?
 312         PUSHJ   P,FRCHECK       ;YES, CHECK IT
 313         MOVE    B,OTBSAV(C)     ;GET PREVIOUS FRAME
 314
 315 FRM1:   HLL     B,OTBSAV(B)     ;TIME
 316         MOVEI   A,1(PVP)        ;PVP END
 317         HLRE    D,PVP   ;PVP LENGTH
 318         SUB     A,D     ;ARRIVE AT PVP DOPE WORD
 319         HRLI    A,TFRAME
 320         JRST    FINIS
 321
 322 MFUNCTION       ARGS,SUBR
 323         ENTRY   1       ;
 324         PUSHJ   P,FRCHECK
 325         MOVEI   A,2
 326         PUSHJ   P,CELL"         ;B_ADDRESS OF INFO CELL
 327         MOVSI   A,TINFO
 328         MOVEM   A,(B)
 329         MOVEI   A,(TP)          ;GENERATE DOPE WORD POINTER
 330         HLRE    E,TP
 331         SUBI    A,-1(E)
 332         CAME    A,TPGROW"       ;ALLOWING FOR BLOWN PDL
 333         ADDI    A,PDLBUF"
 334         HRLZS   A               ;POINTER TO LEFT HALF...
 335         HLR     A,OTBSAV(C)     ;TIME TO RIGHT
 336         MOVEM   A,1(B)          ;TO SECOND WORD OF CELL
 337         HRRI    A,(B)           ;INFO CELL IN CDR OF ARGS VALUE CELL
 338         HRLI    A,TARGS
 339         MOVE    B,ABSAV(C)
 340         JRST    FINIS
 341
 342 MFUNCTION       FUNCT,SUBR      ;RETURNS FUNCTION NAME OF
 343         ENTRY   1       ; FRAME ARGUMENT
 344         PUSHJ   P,FRCHECK       ;CHECK ARG; LEAVE TB IN C
 345         HRRZ    A,FSAV(C)       ;FUNCTION POINTER
 346         MOVE    B,@-1(A)        ;GET FUNCTION NAME POINTER
 347         MOVSI   A,TATOM
 348         JRST    FINIS
 349
 350 FRCHECK:
 351         HLRZ    A,(AB)  ;CHECK TYPE OF ARG
 352         CAIE    A,TFRAME        ;FRAME?
 353         JRST    WRTYFR
 354         HRRZ    C,1(AB) ;GET TB OF FRAME
 355         CAILE   C,1(TP) ;DOES FRAME POINT BEYOND END OF STACK?
 356         JRST    BADFRAME
 357         HLRZ    A,FSAV(C)       ;GET TYPE OF  POINTED AT BY FRAME
 358         CAIE    A,TENTRY        ;ENTRY?
 359         JRST    BADFRAME        ;NO
 360         HLRZ    D,1(AB) ;TIME IN FRAME
 361         HLRZ    E,OTBSAV(C)     ;TIME IN .FRAME
 362         CAME    D,E     ;THE SAME?
 363         JRST    BADFRAME        ;NO, PDL UP-DOWN LOSSAGE
 364         HRRZ    D,OTBSAV(C)     ;AT TOPLEVEL?
 365         JUMPE D,TOPLOSE ;YES
 366         POPJ    P,
 367
 368
 369
 370 WRTYFR:
 371         PUSH    TP,$TATOM
 372         PUSH    TP,MQUOTE WRONG-TYPE-FRAME
 373         JRST    CALER1
 374
 375
 376 BADFRAME:
 377         PUSH    TP,$TATOM
 378         PUSH    TP,MQUOTE FRAME-NO-LONGER-EXISTS
 379         JRST    CALER1
 380
 381
 382 TOPLOSE:
 383         PUSH    TP,$TATOM
 384         PUSH    TP,MQUOTE TOP-LEVEL-FRAME
 385         JRST    CALER1
 386
 387
 388
 389
 390
 391
 392 ;THIS SUBROUTINE ALLOCATES A NEW PROCESS TAKES NO ARGS AND
 393 ;IS CALLED BY PUSHJ P,. RETURNS IN A AND B A NEW PROCESS.
 394
 395 ICR:    MOVEI   A,PVLNT         ;SETUP CALL TO VECTOR FOR PVP
 396         PUSHJ   P,IVECT         ;GOBBLE A VECTOR
 397         HRLI    C,PVBASE        ;SETUP A BLT POINTER
 398         HRRI    C,(B)           ;GET INTO ADDRESS
 399         BLT     C,PVLNT*2-1(B)  ;COPY A PROTOTYPE INTO NEW PVP
 400         MOVSI   C,400000+SPVP   ;SET SPECIAL TYPE
 401         MOVEM   C,PVLNT*2(B)    ;CLOBBER IT IN
 402         PUSH    TP,A            ;SAVE THE RESULTS OF VECTOR
 403         PUSH    TP,B
 404
 405         PUSH    TP,$TFIX        ;GET A UNIFORM VECTOR
 406         PUSH    TP,[PLNT]
 407         MCALL   1,UVECTOR
 408         ADD     B,[PDLBUF-2,,-1]        ;FUDGE WITH BUFFER
 409         MOVE    C,(TP)          ;REGOBBLE PROCESS POINTER
 410         MOVEM   B,PSTO+1(C)     ;STORE IN ALL HOMES
 411         MOVEM   B,PBASE+1(C)
 412
 413         MOVEI   A,PPLNT         ;GET LENGTH OF PP
 414         PUSHJ   P,IVECT
 415         ADD     B,[PDLBUF-2,,-1]
 416         MOVE    C,(TP)          ;GET PROCESS POINTER BACK
 417         MOVEM   B,PPSTO+1(C)
 418
 419         MOVEI   A,TPLNT         ;PREPARE TO CREATE A TEMPORARY PDL
 420         PUSHJ   P,IVECT         ;GET THE TEMP PDL
 421         ADD     B,[PDLBUF,,0]   ;PDL GROWTH HACK
 422         MOVE    C,(TP)          ;RE-GOBBLE NEW PVP
 423         SUB     B,[1,,1]        ;FIX FOR STACK
 424         MOVEM   B,TPBASE+1(C)
 425         MOVEM   B,TPSTO+1(C)    ;MAKE THIS THE CURRENT STACK POINTER
 426         MOVEM   C,PVPSTO+1(C)   ;SAVE THE NEW PVP ITSELF
 427         MOVEM   TVP,TVPSTO+1(C) ;AND THE GOOD OLD TRANSFER VECTOR
 428         AOS     A,PTIME         ;GOBBLE A UNIQUE PROCESS I.D.
 429         MOVEM   A,PROCID+1(C)   ;SAVE THAT ALSO
 430
 431 ;SETUP INITIAL BINDINGS
 432
 433         PUSH    TP,$TPVP                ;SAVE PVP
 434         PUSH    TP,C
 435         MOVEI   A,4
 436         PUSHJ   P,IVECT         ;B _ NEW BIND VECTOR
 437         POP     TP,C
 438         SUB     TP,[1,,1]
 439         MOVEM   B,SPBASE+1(C)   ;NEW SPBASE
 440         MOVE    A,$TSP
 441         MOVEM   A,(B)
 442         SETZM   1(B)
 443         MOVE    A,$TBIND
 444         HRR     A,B
 445         ADD     B,[1,,1]
 446         PUSH    B,A
 447         MOVEM   B,SPSTO+1(C)    ;SAVE AS INITIAL SP
 448         PUSH    B,MQUOTE THIS-PROCESS
 449         PUSH    B,$TPVP
 450         PUSH    B,C
 451         PUSH    B,[0]
 452         PUSH    B,[0]
 453         AOBJP   B,ICRQ
 454         .VALUE  [ASCIZ /SP DISASTER/]
 455 ICRQ:   MOVSI   A,TPVP
 456         MOVE    B,C
 457         POPJ    P,
 458
 459 ;MINI ROUTINE TO CALL VECTOR WITH COUNT IN A
 460
 461 IVECT:  PUSH    TP,$TFIX
 462         PUSH    TP,A
 463         MCALL   1,VECTOR        ;GOBBLE THE VECTOR
 464         POPJ    P,
 465
 466
 467 ;SUBROUTINE TO SWAP A PROCESS IN
 468 ;CALLED WITH JSP A,SWAP AND NEW PVP IN B
 469
 470 SWAP:                           ;FIRST STORE ALL THE ACS
 471
 472         IRP     A,,[PVP,TVP,PP,AB,TB,TP,SP,P,PP]
 473         MOVEM   A,A!STO+1(PVP)
 474         TERMIN
 475
 476         MOVE    E,PVP   ;RETURN OLD PROCESS IN E
 477         MOVE    PVP,D   ;AND MAKE NEW ONE BE D
 478
 479         ;NOW RESTORE NEW PROCESSES AC'S
 480
 481         IRP     A,,[PVP,TVP,PP,AB,TB,TP,SP,P,PP]
 482         MOVE    A,A!STO+1(PVP)
 483         TERMIN
 484
 485         JRST    (C)             ;AND RETURN
 486
 487
 488 ;INTERNAL FUNCTION TO GET STRAGE ALLOCATION TYPE
 489 ;GETS THE TYPE CODE IN A AND RETURNS SAT IN A.
 490
 491 SAT:    LSH     A,1             ;TIMES 2 TO REF VECTOR
 492         HRLS    A               ;TO BOTH HALVES TO HACK AOBJN POINTER
 493         ADD     A,TYPVEC+1(TVP) ;ACCESS THE VECTOR
 494         HRR     A,(A)           ;GET PROBABLE SAT
 495         JUMPL   A,.+2           ;DID WE REALLY HAVE A VALID TYPE
 496         MOVEI   A,0             ;NO RETURN 0
 497         MOVEI   A,(A)           ;CLOBBER LEFT HALF
 498         POPJ    P,              ;AND RETURN
 499
 500 ;TYPE (ITYPE) ARE FUNCTIONS TO RETURN THE ATOMIC NAME OF THE
 501 ;TYPE OF A GOODIE.  TYPE TAKES ITS ARGS ON AP AND RETURNS IN A AND B.
 502 ;ITYPE TAKES ITS ARGS IN A AND B AND RETURNS IN SAME (B=0) FOR INVALID
 503 ;TYPECODE.
 504 MFUNCTION TYPE,SUBR
 505
 506         ENTRY   1
 507         HLLZ    A,(AB)          ;TYPE INTO A
 508 TYPE1:  PUSHJ   P,ITYPE         ;GO TO INTERNAL
 509         JUMPN   B,FINIS         ;GOOD RETURN
 510 TYPERR: PUSH    TP,$TATOM       ;SETUP ERROR CALL
 511         PUSH    TP,MQUOTE TYPE-UNDEFINED
 512         JRST    CALER1"         ;STANDARD ERROR HACKER
 513
 514 ITYPE:  LSH     A,1             ;TIMES 2
 515         HLRS    A               ;TO BOTH SIDES
 516         ADD     A,TYPVEC+1(TVP) ;GET ACTUAL LOCATION
 517         JUMPGE  A,TYPLOS        ;LOST, TYPE OUT OF BOUNDS
 518         MOVE    B,1(A)          ;PICKUP TYPE
 519         HLLZ    A,(A)
 520         POPJ    P,
 521
 522 TYPLOS: MOVSI   A,TLIST
 523         MOVEI   B,NIL
 524         POPJ    P,
 525
 526 ;PRIMTTYPE  RETURNS THE TYPE ATOM OF A PRIMITIVE TYPE IN A CLASS
 527
 528 STBL:   REPEAT NUMSAT,MQUOTE INTERNAL-TYPE
 529
 530 LOC STBL
 531
 532 IRP A,,[[1WORD,FIX],[2WORD,LIST],[NWORD,UVECTOR],[2NWORD,VECTOR]
 533 [ARGS,ARGUMENTS],[FRAME,FRAME],[ATOM,ATOM],[CHSTR,STRING]]
 534
 535 IRP B,C,[A]
 536 LOC STBL+S!B
 537 MQUOTE C
 538
 539 .ISTOP
 540
 541 TERMIN
 542 TERMIN
 543
 544 LOC STBL+NUMSAT+1
 545
 546
 547 MFUNCTION PRIMTYPE,SUBR
 548
 549         ENTRY   1
 550
 551         GETYP   A,(AB)          ;GET TYPE
 552         PUSHJ   P,SAT           ;GET SAT
 553         JUMPE   A,TYPERR
 554         MOVE    B,@STBL(A)
 555         MOVSI   A,TATOM
 556         JRST    FINIS
 557
 558 ;CHTYPE TAKES TWO ARGUMENTS.  ANY GOODIE AND A AN ATOMIC TYPE NAME
 559 ;IT CHECKS THE STORAGE ALLOCATION TYPES OF THE TWO ARE THE SAME AND
 560 ;IF THEY ARE CHANGES THE TYPE OF THE FIRST TO THAT NAME D IN THE SECOND
 561
 562 MFUNCTION CHTYPE,SUBR
 563
 564         ENTRY   2
 565         HLRZ    A,2(AB)         ;FIRST CHECK THAT ARG 2 IS AN ATOM
 566         CAIE    A,TATOM
 567         JRST    NOTATOM
 568         MOVE    B,3(AB)         ;AND TYPE NAME
 569         PUSHJ   P,TYPLOO                ;GO LOOKUP TYPE
 570 TFOUND: HRRZ    B,(A)           ;GOBBLE THE SAT
 571         HLRZ    A,(AB)          ;NOW GET TYPE TO HACK
 572         PUSHJ   P,SAT           ;FIND OUT ITS SAT
 573         JUMPE   A,TYPERR        ;COMPLAIN
 574         CAIE    A,(B)           ;DO THEY AGREE?
 575         JRST    TYPDIF          ;NO, COMPLAIN
 576         MOVSI   A,(D)           ;GET NEW TYPE
 577         MOVE    B,1(AB)         ;AND VALUE
 578         JRST    FINIS
 579
 580 TYPLOO: MOVE    A,TYPVEC+1(TVP) ;GOBBLE DOWN TYPE VECTOR
 581         MOVEI   D,0             ;INITIALIZE TYPE COUNTER
 582 TLOOK:  CAMN    B,1(A)          ;CHECK THIS ONE
 583         POPJ    P,              ;WIN, RETURN
 584         ADDI    D,1             ;BUMP COUNTER
 585         AOBJP   A,.+2           ;COUTN DOWN ON VECTOR
 586         AOBJN   A,TLOOK
 587
 588         PUSH    TP,$TATOM       ;LOST, GENERATE ERROR
 589         PUSH    TP,MQUOTE BAD-TYPE-NAME
 590         JRST    CALER1
 591
 592 TYPDIF: PUSH    TP,$TATOM       ;MAKE ERROR MESSAGE
 593         PUSH    TP,MQUOTE STORAGE-TYPES-DIFFER
 594         JRST    CALER1
 595
 596 ; FUNCTION TO ADD A NEW TYPE TO THE WORLD WITH GIVEN PRIMITIVE TYPE
 597
 598 MFUNCTION NEWTYPE,SUBR
 599
 600         ENTRY   2
 601
 602         GETYP   A,(AB)          ; GET 1ST ARGS TYPE (SHOULD BE ATOM)
 603         GETYP   C,2(AB)         ; SAME WITH SECOND
 604         CAIN    A,TATOM         ; CHECK
 605         CAIE    C,TATOM
 606         JRST    NOTATOM
 607
 608         SKIPGE  C,TYPTOP+1(TVP) ; SKIP IF VECTOR FULL
 609         JRST    ADDIT           ; NO, GO ADD
 610         PUSH    TP,$TVEC                ; CALL GROW
 611         PUSH    TP,TYPVEC+1(TVP)
 612         PUSH    TP,$TFIX
 613         PUSH    TP,[100]
 614         PUSH    TP,$TFIX
 615         PUSH    TP,[0]
 616         MCALL   3,GROW          ; GROW THE POOR VECTOR
 617         MOVE    C,TYPTOP+1(TVP) ; GET NEW TOP
 618
 619 ADDIT:  MOVE    B,3(AB) ; GET PRIM TYPE NAME
 620         PUSHJ   P,TYPLOO                ; LOOK IT UP
 621         HRRZ    A,(B)           ; GOBBLE SAT
 622         HRLI    A,TATOM ; MAKE NEW TYPE
 623         MOVEM   A,(C)           ; CLOBBER IT IN
 624         MOVE    B,1(AB)         ; GET NEW TYPE NAME
 625         MOVEM   B,1(C)
 626         ADD     C,[2,,2]        ; BUMP POINTER
 627         MOVEM   C,TYPTOP+1(TVP)
 628         MOVE    A,(AB)
 629         MOVE    B,1(AB)         ; RETURN NAME
 630         JRST    FINIS
 631
 632 MFUNCTION ALLTYPES,SUBR
 633
 634         ENTRY   0
 635
 636         MOVE    A,TYPVEC(TVP)
 637         MOVE    B,TYPVEC+1(TVP)
 638         JRST    FINIS
 639
 640 MFUNCTION UTYPE,SUBR
 641
 642         ENTRY   1
 643
 644         GETYP   A,(AB)          ;GET U VECTOR
 645         CAIE    A,TUVEC
 646         JRST    WTYP1
 647         HLRE    A,1(AB)         ;GET -LENGTH
 648         HRRZ    B,1(AB)
 649         SUB     B,A             ;POINT TO TYPE WORD
 650         HLLZ    A,(B)
 651         JRST    TYPE1           ;NOW, USE TYPE CODE
 652 MFUNCTION CHUTYPE,SUBR
 653
 654         ENTRY   2
 655
 656         GETYP   A,2(AB)         ;GET 2D TYPE
 657         CAIE    A,TATOM
 658         JRST    NOTATO
 659         MOVE    A,3(AB)         ;GET ATOM
 660         PUSHJ   P,TYPLOO        ;LOOK IT UP
 661         HRRZ    B,(A)           ;GET SAT
 662         GETYP   A,(AB)          ;CHECK FOR UVECTOR
 663         CAIE    A,TUVEC
 664         JRST    WTYP1
 665         HLRE    C,1(AB)         ;-LENGTH
 666         HRRZ    E,1(AB)
 667         SUB     E,C             ;POINT TO TYPE
 668         HLRZ    A,(E)           ;GET TYPE
 669         JUMPE   A,WIN0          ;ALLOW TYPE "LOSE" TO CHANGE TO ANYTHING
 670         PUSHJ   P,SAT           ;GET SAT
 671         JUMPE   A,TYPERR
 672         CAIE    A,(B)           ;COMPARE
 673         JRST    TYPDIF
 674 WIN0:   HRLM    D,(E)           ;CLOBBER NEW ONE
 675         GETYPF  A,(AB)          ;RETURN ARG
 676         MOVE    B,1(AB)
 677         JRST    FINIS
 678
 679 WNA:
 680         PUSH    TP,$TATOM
 681         PUSH    TP,MQUOTE WRONG-NUMBER-OF-ARGUMENTS
 682         MOVEI   A,1
 683         JRST    CALER"
 684
 685 NOTATOM:
 686         PUSH    TP,$TATOM
 687         PUSH    TP,MQUOTE NON-ATOMIC-ARGUMENT
 688         PUSH    TP,(AB)
 689         PUSH    TP,1(AB)
 690         MOVEI   A,2
 691         JRST    CALER
 692
 693
 694 CRLF:   MOVEI   A,15
 695         JRST    TYO"
 696 MSGTYP":        HRLI    B,440700        ;MAKE BYTE POINTER
 697 MSGTY1: ILDB    A,B             ;GET NEXT CHARACTER
 698         JUMPE   A,CPOPJ         ;NULL ENDS STRING
 699         PUSHJ   P,TYO"
 700         JRST    MSGTY1          ;AND GET NEXT CHARACTER
 701 CPOPJ:  POPJ    P,
 702
 703 ; HACK TO PRINT MESSAGE OF INTEREST TO USER
 704
 705 MESOUT: MOVSI   A,(JFCL)
 706         MOVEM   A,MESSAG                ;DO ONLY ONCE
 707         .SUSET  [.RSNAM,,A]     ;READ SNAME AND SAVE
 708         PUSH    P,A             ;AND SAVE
 709         .SUSET  [.SSNAM,,[SIXBIT /MUDDLE/]
 710         MOVEI   A,[SIXBIT /   DSKMUDDLEMESSAG/]
 711         PUSHJ   P,OPEN          ;TRY TO OPEN
 712         JRST    RESNM
 713 MESSI:  PUSHJ   P,IOT           ;READ A CHAR
 714         JUMPL   B,MESCLS        ;DONE, QUIT
 715         EXCH    A,B             ;CHAR TO A SAVE CHAN
 716         CAIE    A,14            ;DONT TYPE FF
 717         PUSHJ   P,TYO           ;AND TYPE IT OUT
 718         MOVE    A,B             ;CHANNEL BACK TO A
 719         JRST    MESSI           ;UNTIL DONE
 720
 721 MESCLS: PUSHJ   P,CLOSE ;AND CLOSE
 722
 723 RESNM:  POP     P,A             ;RESTORE SNAME
 724         .SUSET  [.SSNAM,,A]
 725         POPJ    P,
 726
 727 MESSAG: PUSHJ   P,MESOUT                ;MESSAGE SWITCH
 728
 729
 730 CRADIX":        10.
 731 PTIME:  0                       ;UNIQUE NUMBER FOR PROCID AND ENVIRONMENTS
 732 OBLNT": 151.                    ;LENGTH OF INITIAL OBLISTS
 733 VECTOP: VECLOC
 734 VECBOT":        VECBASE
 735 CODBOT: 0                       ;ABSOLUTE BOTTOM OF CODE
 736 CODTOP":        PARBASE
 737 PARTOP: PARLOC
 738 PARBOT":        PARBASE
 739 PVLNTH: 0
 740 TVLNTH: 0
 741 TVBOT:  TVBASE
 742 VECNEW":        0                       ;LOCATION FOR OFFSET BETWWEN OLD VECTOP AND NEW VECTOP
 743 PARNEW":        0                       ;LOCATION FOR OFFSET BETTWEEN OLD PARBOT AND NEW PARBOT
 744 INTFLG: 0                       ;INTERRUPT PENDING FLAG
 745 MAINPR: 0               ;HOLDS POINTER TO THE MAIN PROCESS
 746
 747 PATCH:
 748 PAT:    BLOCK   100
 749 PATEND: 0
 750
 751 ;GARBAGE COLLECTORS PDLS
 752
 753
 754 GCPDL:  -GCPLNT,,GCPDL
 755
 756         BLOCK   GCPLNT
 757
 758
 759 ;PROCESS PDL
 760
 761
 762 ;MARKED PDLS FOR GC PROCESS
 763
 764 VECTGO
 765 ; DUMMY FRAME FOR INITIALIZER CALLS
 766
 767         TENTRY,,LISTEN
 768         0
 769         .-3
 770         0
 771         0
 772         -ITPLNT,,TPBAS-1
 773         0
 774
 775 TPBAS:  BLOCK   ITPLNT+PDLBUF
 776         GENERAL
 777         ITPLNT+2+PDLBUF+7,,0
 778
 779 APBAS:  BLOCK   IAPLNT
 780         IAPLNT+1,,0
 781
 782 VECRET
 783
 784
 785
 786
 787 $TMATO: TATOM,,-1
 788
 789
 790 END
 791 \f\f\ 3\f