1 TITLE MAIN LOOP AND GLOBALLY REFERENCED SUBROUTINES
3 MAIN==1 ;THIS INCLUDES ONCE ONLY CODE
5 NINT==72. ;NUMBER OF POSSIBLE ITS INTERRUPTS
6 NASOCS==159. ;LENGTH OF ASSOCIATION VECTOR
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
26 TYPVLC": BLOCK 2*NUMPRI+2
30 TYPTP==.-2 ; POINT TO TOP OF TYPES
50 ;THESE ENTRIES MUST NOT MOVE DURING INITILAIZATION
52 ADDTV TVEC,[-2*NUMPRI-2,,TYPVLC]
56 TYPTOP==TVOFF-1 ; POINT TO CURRENT TOP OF TYPE VECTORS
58 ;ENTRY FOR ROOT,TTICHN,TTOCHN
76 ADDTV TVEC,[-2*NINT,,INTVCL]
78 ADDTV TUVEC,[-NASOCS,,ASOVCL]
87 REPEAT 16.,ADDCHN \.RPCNT
89 ADDTV TASOC,[-ASOLNT,,NODLST]
99 ADDTV TVEC,[-GSPLNT,,GSP]
103 GLOBSP==TVOFF-1 ;ENTRY FOR CURRENT POINTER TO GLOBAL SP
105 ;PROCESS VECTOR FOR GARBAGE COLLECTOR PROCESS
114 ;INITIAL PROCESS VECTOR
116 PVBASE": BLOCK PVLNT*2
122 ;ENTRY FOR PROCESS I.D.
125 ;THE FOLLOWING IRP MAKES SPACE FO9 SAVED ACS
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]
141 ;ADD LAST ERROR AND PROG GOODIE
160 ;MAIN LOOP AND STARTUP
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
171 XCT MESSAG ;MAYBE PRINT A MESSAGE
173 RESTART: ;RESTART A PROCESS
175 HRR TB,TBINIT+1(PVP) ;POINT INTO STACK AT START
176 MOVE PP,PPSAV(TB) ;FLUSH FAILPOINTS
184 MFUNCTION LISTEN,SUBR
188 PUSH P,[0] ;FLAG: DON'T PRINT ERROR MSG
194 PUSH P,[-1] ;PRINT ERROR FLAG
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
204 PUSH TP,MQUOTE OUTCHAN
205 PUSH TP,TTOCHN(TVP) ;TYPE OF OUT CHNA
206 PUSH TP,TTOCHN+1(TVP) ;AND IT S VAL
211 PUSH TP,MQUOTE OBLIST
212 PUSH TP,ROOT(TVP) ;DEFAULT OBLIST TYPE
213 PUSH TP,ROOT+1(TVP) ;AND VALUE
219 PUSH TP,$TLIST ;DEFAULT EOF- NIL
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
229 ADD B,[1,,0] ;INCREASE LEVEL
231 HLRZ A,B ;AND SAVE NEW LEVEL
237 PUSHJ P,SPECBIND ;BIND THE CRETANS
238 MOVE A,-1(P) ;RESTORE SWITHC
239 JUMPE A,NOERR ;IF 0, DONT PRINT ERROR MESS
241 PUSH TP,MQUOTE *ERROR*
242 MCALL 1,PRINT ;PRINT THE MESSAGE
243 NOERR: MOVE C,AB ;GET A COPY OF AB
245 ERRLP: JUMPGE C,LEVPRT ;IF NONE, RE-ENTER READ-EVAL-PRINT LOOP
248 PUSH TP,(C) ;GET AN ARGS TYPE
249 PUSH TP,1(C) ;AND VALUE
253 ADD C,[2,,2] ;BUMP SAVED AB
254 JRST ERRLP ;AND CONTINUE
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
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)
271 MAINLP: PUSHJ P,CRLF ;TYPE OUT A CARRIAGE RETURN, LINEFEED
283 ;FUNCTION TO DO ERROR RETURN
288 CAML AB,[-1,,0] ;CHECK FOR AN ARG
289 JRST STP ;NO ARGS, RESTART PROCESS
290 CAML AB,[-3,,0] ;FRAME SUPPLIED
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
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
303 MOVE B,1(AB) ;AND GET RETURNED VALUE
309 MOVE B,MQUOTE LER,[LERR ]INTRUP
311 JUMPGE AB,FRM1 ;FRAME ARGUMENT SUPPLIED?
312 PUSHJ P,FRCHECK ;YES, CHECK IT
313 MOVE B,OTBSAV(C) ;GET PREVIOUS FRAME
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
326 PUSHJ P,CELL" ;B_ADDRESS OF INFO CELL
329 MOVEI A,(TP) ;GENERATE DOPE WORD POINTER
332 CAME A,TPGROW" ;ALLOWING FOR BLOWN PDL
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
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
351 HLRZ A,(AB) ;CHECK TYPE OF ARG
352 CAIE A,TFRAME ;FRAME?
354 HRRZ C,1(AB) ;GET TB OF FRAME
355 CAILE C,1(TP) ;DOES FRAME POINT BEYOND END OF STACK?
357 HLRZ A,FSAV(C) ;GET TYPE OF POINTED AT BY FRAME
358 CAIE A,TENTRY ;ENTRY?
360 HLRZ D,1(AB) ;TIME IN FRAME
361 HLRZ E,OTBSAV(C) ;TIME IN .FRAME
363 JRST BADFRAME ;NO, PDL UP-DOWN LOSSAGE
364 HRRZ D,OTBSAV(C) ;AT TOPLEVEL?
372 PUSH TP,MQUOTE WRONG-TYPE-FRAME
378 PUSH TP,MQUOTE FRAME-NO-LONGER-EXISTS
384 PUSH TP,MQUOTE TOP-LEVEL-FRAME
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.
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
405 PUSH TP,$TFIX ;GET A UNIFORM VECTOR
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
413 MOVEI A,PPLNT ;GET LENGTH OF PP
416 MOVE C,(TP) ;GET PROCESS POINTER BACK
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
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
431 ;SETUP INITIAL BINDINGS
433 PUSH TP,$TPVP ;SAVE PVP
436 PUSHJ P,IVECT ;B _ NEW BIND VECTOR
439 MOVEM B,SPBASE+1(C) ;NEW SPBASE
447 MOVEM B,SPSTO+1(C) ;SAVE AS INITIAL SP
448 PUSH B,MQUOTE THIS-PROCESS
454 .VALUE [ASCIZ /SP DISASTER/]
459 ;MINI ROUTINE TO CALL VECTOR WITH COUNT IN A
463 MCALL 1,VECTOR ;GOBBLE THE VECTOR
467 ;SUBROUTINE TO SWAP A PROCESS IN
468 ;CALLED WITH JSP A,SWAP AND NEW PVP IN B
470 SWAP: ;FIRST STORE ALL THE ACS
472 IRP A,,[PVP,TVP,PP,AB,TB,TP,SP,P,PP]
476 MOVE E,PVP ;RETURN OLD PROCESS IN E
477 MOVE PVP,D ;AND MAKE NEW ONE BE D
479 ;NOW RESTORE NEW PROCESSES AC'S
481 IRP A,,[PVP,TVP,PP,AB,TB,TP,SP,P,PP]
488 ;INTERNAL FUNCTION TO GET STRAGE ALLOCATION TYPE
489 ;GETS THE TYPE CODE IN A AND RETURNS SAT IN A.
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
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
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
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
522 TYPLOS: MOVSI A,TLIST
526 ;PRIMTTYPE RETURNS THE TYPE ATOM OF A PRIMITIVE TYPE IN A CLASS
528 STBL: REPEAT NUMSAT,MQUOTE INTERNAL-TYPE
532 IRP A,,[[1WORD,FIX],[2WORD,LIST],[NWORD,UVECTOR],[2NWORD,VECTOR]
533 [ARGS,ARGUMENTS],[FRAME,FRAME],[ATOM,ATOM],[CHSTR,STRING]]
547 MFUNCTION PRIMTYPE,SUBR
551 GETYP A,(AB) ;GET TYPE
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
562 MFUNCTION CHTYPE,SUBR
565 HLRZ A,2(AB) ;FIRST CHECK THAT ARG 2 IS AN ATOM
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
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
584 ADDI D,1 ;BUMP COUNTER
585 AOBJP A,.+2 ;COUTN DOWN ON VECTOR
588 PUSH TP,$TATOM ;LOST, GENERATE ERROR
589 PUSH TP,MQUOTE BAD-TYPE-NAME
592 TYPDIF: PUSH TP,$TATOM ;MAKE ERROR MESSAGE
593 PUSH TP,MQUOTE STORAGE-TYPES-DIFFER
596 ; FUNCTION TO ADD A NEW TYPE TO THE WORLD WITH GIVEN PRIMITIVE TYPE
598 MFUNCTION NEWTYPE,SUBR
602 GETYP A,(AB) ; GET 1ST ARGS TYPE (SHOULD BE ATOM)
603 GETYP C,2(AB) ; SAME WITH SECOND
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)
616 MCALL 3,GROW ; GROW THE POOR VECTOR
617 MOVE C,TYPTOP+1(TVP) ; GET NEW TOP
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
626 ADD C,[2,,2] ; BUMP POINTER
627 MOVEM C,TYPTOP+1(TVP)
629 MOVE B,1(AB) ; RETURN NAME
632 MFUNCTION ALLTYPES,SUBR
644 GETYP A,(AB) ;GET U VECTOR
647 HLRE A,1(AB) ;GET -LENGTH
649 SUB B,A ;POINT TO TYPE WORD
651 JRST TYPE1 ;NOW, USE TYPE CODE
652 MFUNCTION CHUTYPE,SUBR
656 GETYP A,2(AB) ;GET 2D TYPE
659 MOVE A,3(AB) ;GET ATOM
660 PUSHJ P,TYPLOO ;LOOK IT UP
662 GETYP A,(AB) ;CHECK FOR UVECTOR
665 HLRE C,1(AB) ;-LENGTH
667 SUB E,C ;POINT TO TYPE
669 JUMPE A,WIN0 ;ALLOW TYPE "LOSE" TO CHANGE TO ANYTHING
674 WIN0: HRLM D,(E) ;CLOBBER NEW ONE
675 GETYPF A,(AB) ;RETURN ARG
681 PUSH TP,MQUOTE WRONG-NUMBER-OF-ARGUMENTS
687 PUSH TP,MQUOTE NON-ATOMIC-ARGUMENT
696 MSGTYP": HRLI B,440700 ;MAKE BYTE POINTER
697 MSGTY1: ILDB A,B ;GET NEXT CHARACTER
698 JUMPE A,CPOPJ ;NULL ENDS STRING
700 JRST MSGTY1 ;AND GET NEXT CHARACTER
703 ; HACK TO PRINT MESSAGE OF INTEREST TO USER
705 MESOUT: MOVSI A,(JFCL)
706 MOVEM A,MESSAG ;DO ONLY ONCE
707 .SUSET [.RSNAM,,A] ;READ SNAME AND SAVE
709 .SUSET [.SSNAM,,[SIXBIT /MUDDLE/]
710 MOVEI A,[SIXBIT / DSKMUDDLEMESSAG/]
711 PUSHJ P,OPEN ;TRY TO OPEN
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
721 MESCLS: PUSHJ P,CLOSE ;AND CLOSE
723 RESNM: POP P,A ;RESTORE SNAME
727 MESSAG: PUSHJ P,MESOUT ;MESSAGE SWITCH
731 PTIME: 0 ;UNIQUE NUMBER FOR PROCID AND ENVIRONMENTS
732 OBLNT": 151. ;LENGTH OF INITIAL OBLISTS
735 CODBOT: 0 ;ABSOLUTE BOTTOM OF CODE
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
751 ;GARBAGE COLLECTORS PDLS
754 GCPDL: -GCPLNT,,GCPDL
762 ;MARKED PDLS FOR GC PROCESS
765 ; DUMMY FRAME FOR INITIALIZER CALLS
775 TPBAS: BLOCK ITPLNT+PDLBUF