--- /dev/null
+TITLE MAIN LOOP AND GLOBALLY REFERENCED SUBROUTINES
+RELOCA
+MAIN==1 ;THIS INCLUDES ONCE ONLY CODE
+
+NINT==72. ;NUMBER OF POSSIBLE ITS INTERRUPTS
+NASOCS==159. ;LENGTH OF ASSOCIATION VECTOR
+
+
+.GLOBAL PATCH,TBINIT,LERR,LPROG,PIDSTO,PROCID,PTIME,GCPDL,INTFLG,WTYP1,WTYP2
+.GLOBAL PAT,PDLBUF,INTINT,PARNEW,GCPVP,START,SWAP,ICR,SPBASE,TPBASE,GLOBAS,GLOBSP,TPBAS
+.GLOBAL TOPLEVEL,INTNUM,INTVEC,INTOBL,ASOVEC,ERROBL,MAINPR,RESFUN,.BLOCK,ASOLNT,NODES
+.GLOBAL WRONGT,TTYOPE,OPEN,CLOSE,IOT,ILVAL,MESS,FACTI
+
+.INSRT MUDDLE >
+
+VECTGO
+TVBASE": BLOCK TVLNT
+ GENERAL
+ TVLNT+2,,0
+TVLOC=TVBASE
+
+
+
+;INITIAL TYPE TABLE
+
+TYPVLC": BLOCK 2*NUMPRI+2
+ GENERAL
+ 2*NUMPRI+2+2,,0
+
+TYPTP==.-2 ; POINT TO TOP OF TYPES
+
+INTVCL: BLOCK 2*NINT
+ TLIST,,0
+ 2*NINT+2,,0
+
+NODLST: TTP,,0
+ 0
+ TASOC,,0
+ BLOCK ASOLNT-3
+ GENERAL+<SASOC,,0>
+ ASOLNT+2,,0
+
+
+ASOVCL: BLOCK NASOCS
+ TASOC,,0
+ NASOCS+2,,0
+
+
+
+;THESE ENTRIES MUST NOT MOVE DURING INITILAIZATION
+
+ADDTV TVEC,[-2*NUMPRI-2,,TYPVLC]
+TYPVEC==TVOFF-1
+
+ADDTV TVEC,TYPTP
+TYPTOP==TVOFF-1 ; POINT TO CURRENT TOP OF TYPE VECTORS
+
+;ENTRY FOR ROOT,TTICHN,TTOCHN
+
+ADDTV TCHAN,0
+TTICHN==TVOFF-1
+
+ADDTV TCHAN,0
+TTOCHN==TVOFF-1
+
+ADDTV TOBLS,0
+ROOT==TVOFF-1
+ADDTV TOBLS,0
+INTOBL==TVOFF-1
+ADDTV TOBLS,0
+ERROBL==TVOFF-1
+ADDTV TVEC,0
+GRAPHS==TVOFF-1
+ADDTV TFIX,0
+INTNUM==TVOFF-1
+ADDTV TVEC,[-2*NINT,,INTVCL]
+INTVEC==TVOFF-1
+ADDTV TUVEC,[-NASOCS,,ASOVCL]
+ASOVEC==TVOFF-1
+
+DEFINE ADDCHN N
+ ADDTV TCHAN,0
+ CHANL!N==TVOFF-1
+ .GLOBAL CHANL!N
+ TERMIN
+
+REPEAT 16.,ADDCHN \.RPCNT
+
+ADDTV TASOC,[-ASOLNT,,NODLST]
+NODES==TVOFF-1
+
+
+;GLOBAL SPECIAL PDL
+
+GSP: BLOCK GSPLNT
+ GENERAL
+ GSPLNT+2,,0
+
+ADDTV TVEC,[-GSPLNT,,GSP]
+GLOBASE==TVOFF-1
+GLOB==.-2
+ADDTV TVEC,GLOB
+GLOBSP==TVOFF-1 ;ENTRY FOR CURRENT POINTER TO GLOBAL SP
+
+;PROCESS VECTOR FOR GARBAGE COLLECTOR PROCESS
+
+GCPVP: BLOCK PVLNT*2
+ GENERAL
+ PVLNT*2+2,,0
+
+
+VECRET
+
+;INITIAL PROCESS VECTOR
+
+PVBASE": BLOCK PVLNT*2
+ GENERAL
+ PVLNT*2+2,,0
+PVLOC==PVBASE
+
+
+;ENTRY FOR PROCESS I.D.
+
+ ADDPV TFIX,1,PROCID
+;THE FOLLOWING IRP MAKES SPACE FO9 SAVED ACS
+
+ZZZ==.
+
+IRP A,,[0,A,B,C,D,E,PVP,TVP,PP,AB,TB,TP,SP,P]B,,[0
+0,0,0,0,0,TPVP,TTVP,TPP,TAB,TTB,TTP,TSP,TPDL]
+
+LOC PVLOC+2*A
+A!STO=.-PVBASE
+B,,0
+0
+TERMIN
+
+PVLOC==PVLOC+16.*2
+LOC ZZZ
+
+;ADD LAST ERROR AND PROG GOODIE
+
+ADDPV TTB,0,LERR
+
+ADDPV TTB,0,LPROG
+
+
+
+ADDPV TTB,0,TBINIT
+ADDPV TTP,0,TPBASE
+ADDPV TSP,0,SPBASE
+ADDPV TPDL,0,PBASE
+ADDPV 0,0,RESFUN
+ADDPV TLIST,0,.BLOCK
+ADDPV TLIST,0,MESS
+ADDPV TACT,0,FACTI
+
+
+
+;MAIN LOOP AND STARTUP
+
+;SECONDARY STARTUP
+
+START:
+ MOVE PVP,MAINPR ;MAKE SURE WE START IN THE MAIN PROCESS
+ PUSHJ P,INTINT ;INITIALIZE INTERRUPT HANDLER
+ PUSHJ P,TTYOPEN ;OPEN THE TTY
+MIO: MOVEI B,[ASCIZ /MUDDLE IN OPERATION./]
+ PUSHJ P,MSGTYP ;TYPE OUT TO USER
+
+ XCT MESSAG ;MAYBE PRINT A MESSAGE
+
+RESTART: ;RESTART A PROCESS
+STP:
+ HRR TB,TBINIT+1(PVP) ;POINT INTO STACK AT START
+ MOVE PP,PPSAV(TB) ;FLUSH FAILPOINTS
+ JRST CONTIN
+
+ MQUOTE TOPLEVEL
+TOPLEVEL:
+ MCALL 0,LISTEN
+ JRST TOPLEVEL
+
+MFUNCTION LISTEN,SUBR
+
+ ENTRY
+
+ PUSH P,[0] ;FLAG: DON'T PRINT ERROR MSG
+ JRST ER1
+
+MFUNCTION ERROR,SUBR
+
+ ENTRY
+ PUSH P,[-1] ;PRINT ERROR FLAG
+
+ER1: PUSH TP,$TMATOM ;BIND CHANNELS,OBLIST AND EOF
+ PUSH TP,MQUOTE INCHAN
+ PUSH TP,TTICHN(TVP) ;TYPE OF TTY CHAN
+ PUSH TP,TTICHN+1(TVP) ;AND ITS VALUE
+ PUSH TP,[0] ;DUMMY FOR SPECBIND
+ PUSH TP,[0]
+
+ PUSH TP,$TMATOM
+ PUSH TP,MQUOTE OUTCHAN
+ PUSH TP,TTOCHN(TVP) ;TYPE OF OUT CHNA
+ PUSH TP,TTOCHN+1(TVP) ;AND IT S VAL
+ PUSH TP,[0]
+ PUSH TP,[0]
+
+ PUSH TP,$TMATOM
+ PUSH TP,MQUOTE OBLIST
+ PUSH TP,ROOT(TVP) ;DEFAULT OBLIST TYPE
+ PUSH TP,ROOT+1(TVP) ;AND VALUE
+ PUSH TP,[0]
+ PUSH TP,[0]
+
+ PUSH TP,$TMATOM
+ PUSH TP,MQUOTE EOF
+ PUSH TP,$TLIST ;DEFAULT EOF- NIL
+ PUSH TP,[0]
+ PUSH TP,[0]
+ PUSH TP,[0]
+
+ MOVE B,MQUOTE LER,[LERR ]INTRUP
+ PUSHJ P,ILVAL ;GET VALUE OF LAST ERR
+ PUSH TP,[TATOM,,-1] ;FOR BINDING
+ PUSH TP,MQUOTE LER,[LERR ]INTRUP
+ PUSH TP,$TTB
+ ADD B,[1,,0] ;INCREASE LEVEL
+ HRR B,TB
+ HLRZ A,B ;AND SAVE NEW LEVEL
+ PUSH P,A
+ PUSH TP,B
+ PUSH TP,[0]
+ PUSH TP,[0]
+
+ PUSHJ P,SPECBIND ;BIND THE CRETANS
+ MOVE A,-1(P) ;RESTORE SWITHC
+ JUMPE A,NOERR ;IF 0, DONT PRINT ERROR MESS
+ PUSH TP,$TATOM
+ PUSH TP,MQUOTE *ERROR*
+ MCALL 1,PRINT ;PRINT THE MESSAGE
+NOERR: MOVE C,AB ;GET A COPY OF AB
+
+ERRLP: JUMPGE C,LEVPRT ;IF NONE, RE-ENTER READ-EVAL-PRINT LOOP
+ PUSH TP,$TAB
+ PUSH TP,C
+ PUSH TP,(C) ;GET AN ARGS TYPE
+ PUSH TP,1(C) ;AND VALUE
+ MCALL 1,PRINT
+ POP TP,C
+ SUB TP,[1,,1]
+ ADD C,[2,,2] ;BUMP SAVED AB
+ JRST ERRLP ;AND CONTINUE
+
+LEVPRT: PUSH TP,$TATOM
+ PUSH TP,MQUOTE LISTENING-AT-LEVEL
+ MCALL 1,PRINT ;PRINT LEVEL
+ PUSH TP,$TFIX ;READY TO PRINT LEVEL
+ MOVE A,(P) ;GET LEVEL
+ SUB P,[2,,2] ;AND POP STACK
+ PUSH TP,A
+ MCALL 1,PRIN1 ;PRINT WITHOUT SPACES ETC.
+ PUSH TP,$TATOM ;NOW PROCESS
+ PUSH TP,MQUOTE [ PROCESS ]
+ MCALL 1,PRINC ;DONT SLASHIFY SPACES
+ PUSH TP,PROCID(PVP) ;NOW ID
+ PUSH TP,PROCID+1(PVP)
+ MCALL 1,PRIN1
+
+MAINLP: PUSHJ P,CRLF ;TYPE OUT A CARRIAGE RETURN, LINEFEED
+ MCALL 0,READ
+ PUSH TP,A
+ PUSH TP,B
+ MCALL 1,EVAL
+ PUSH TP,A
+ PUSH TP,B
+ MCALL 1,PRINT
+ JRST MAINLP
+
+
+
+;FUNCTION TO DO ERROR RETURN
+
+MFUNCTION ERRET,SUBR
+
+ ENTRY
+ CAML AB,[-1,,0] ;CHECK FOR AN ARG
+ JRST STP ;NO ARGS, RESTART PROCESS
+ CAML AB,[-3,,0] ;FRAME SUPPLIED
+ JRST ERRET1 ;NO
+ ADD AB,[2,,2] ;POINT AB AT FRAME ARG
+ PUSHJ P,FRCHECK ;CHECK IT OUT
+ SUB AB,[2,,2] ;POINT IT BACK
+
+
+ERRET1: MOVE B,MQUOTE LER,[LERR ]INTRUP
+ PUSHJ P,ILVAL ;GET VALUE
+ HRR TB,B ;AND CLOBBER
+ CAMGE AB,[-3,,0] ;FRAME SUPPLIED?
+ HRR TB,3(AB) ;YES, RESTORE TB FROM FRAME
+RTA: MOVE A,(AB)
+ MOVE B,1(AB) ;AND GET RETURNED VALUE
+ JRST FINIS
+
+
+MFUNCTION FRAME,SUBR
+ ENTRY
+ MOVE B,MQUOTE LER,[LERR ]INTRUP
+ PUSHJ P,ILVAL
+ JUMPGE AB,FRM1 ;FRAME ARGUMENT SUPPLIED?
+ PUSHJ P,FRCHECK ;YES, CHECK IT
+ MOVE B,OTBSAV(C) ;GET PREVIOUS FRAME
+
+FRM1: HLL B,OTBSAV(B) ;TIME
+ MOVEI A,1(PVP) ;PVP END
+ HLRE D,PVP ;PVP LENGTH
+ SUB A,D ;ARRIVE AT PVP DOPE WORD
+ HRLI A,TFRAME
+ JRST FINIS
+
+MFUNCTION ARGS,SUBR
+ ENTRY 1 ;
+ PUSHJ P,FRCHECK
+ MOVEI A,2
+ PUSHJ P,CELL" ;B_ADDRESS OF INFO CELL
+ MOVSI A,TINFO
+ MOVEM A,(B)
+ MOVEI A,(TP) ;GENERATE DOPE WORD POINTER
+ HLRE E,TP
+ SUBI A,-1(E)
+ CAME A,TPGROW" ;ALLOWING FOR BLOWN PDL
+ ADDI A,PDLBUF"
+ HRLZS A ;POINTER TO LEFT HALF...
+ HLR A,OTBSAV(C) ;TIME TO RIGHT
+ MOVEM A,1(B) ;TO SECOND WORD OF CELL
+ HRRI A,(B) ;INFO CELL IN CDR OF ARGS VALUE CELL
+ HRLI A,TARGS
+ MOVE B,ABSAV(C)
+ JRST FINIS
+
+MFUNCTION FUNCT,SUBR ;RETURNS FUNCTION NAME OF
+ ENTRY 1 ; FRAME ARGUMENT
+ PUSHJ P,FRCHECK ;CHECK ARG; LEAVE TB IN C
+ HRRZ A,FSAV(C) ;FUNCTION POINTER
+ MOVE B,@-1(A) ;GET FUNCTION NAME POINTER
+ MOVSI A,TATOM
+ JRST FINIS
+
+FRCHECK:
+ HLRZ A,(AB) ;CHECK TYPE OF ARG
+ CAIE A,TFRAME ;FRAME?
+ JRST WRTYFR
+ HRRZ C,1(AB) ;GET TB OF FRAME
+ CAILE C,1(TP) ;DOES FRAME POINT BEYOND END OF STACK?
+ JRST BADFRAME
+ HLRZ A,FSAV(C) ;GET TYPE OF POINTED AT BY FRAME
+ CAIE A,TENTRY ;ENTRY?
+ JRST BADFRAME ;NO
+ HLRZ D,1(AB) ;TIME IN FRAME
+ HLRZ E,OTBSAV(C) ;TIME IN .FRAME
+ CAME D,E ;THE SAME?
+ JRST BADFRAME ;NO, PDL UP-DOWN LOSSAGE
+ HRRZ D,OTBSAV(C) ;AT TOPLEVEL?
+ JUMPE D,TOPLOSE ;YES
+ POPJ P,
+
+
+
+WRTYFR:
+ PUSH TP,$TATOM
+ PUSH TP,MQUOTE WRONG-TYPE-FRAME
+ JRST CALER1
+
+
+BADFRAME:
+ PUSH TP,$TATOM
+ PUSH TP,MQUOTE FRAME-NO-LONGER-EXISTS
+ JRST CALER1
+
+
+TOPLOSE:
+ PUSH TP,$TATOM
+ PUSH TP,MQUOTE TOP-LEVEL-FRAME
+ JRST CALER1
+
+
+
+
+
+
+;THIS SUBROUTINE ALLOCATES A NEW PROCESS TAKES NO ARGS AND
+;IS CALLED BY PUSHJ P,. RETURNS IN A AND B A NEW PROCESS.
+
+ICR: MOVEI A,PVLNT ;SETUP CALL TO VECTOR FOR PVP
+ PUSHJ P,IVECT ;GOBBLE A VECTOR
+ HRLI C,PVBASE ;SETUP A BLT POINTER
+ HRRI C,(B) ;GET INTO ADDRESS
+ BLT C,PVLNT*2-1(B) ;COPY A PROTOTYPE INTO NEW PVP
+ MOVSI C,400000+SPVP ;SET SPECIAL TYPE
+ MOVEM C,PVLNT*2(B) ;CLOBBER IT IN
+ PUSH TP,A ;SAVE THE RESULTS OF VECTOR
+ PUSH TP,B
+
+ PUSH TP,$TFIX ;GET A UNIFORM VECTOR
+ PUSH TP,[PLNT]
+ MCALL 1,UVECTOR
+ ADD B,[PDLBUF-2,,-1] ;FUDGE WITH BUFFER
+ MOVE C,(TP) ;REGOBBLE PROCESS POINTER
+ MOVEM B,PSTO+1(C) ;STORE IN ALL HOMES
+ MOVEM B,PBASE+1(C)
+
+ MOVEI A,PPLNT ;GET LENGTH OF PP
+ PUSHJ P,IVECT
+ ADD B,[PDLBUF-2,,-1]
+ MOVE C,(TP) ;GET PROCESS POINTER BACK
+ MOVEM B,PPSTO+1(C)
+
+ MOVEI A,TPLNT ;PREPARE TO CREATE A TEMPORARY PDL
+ PUSHJ P,IVECT ;GET THE TEMP PDL
+ ADD B,[PDLBUF,,0] ;PDL GROWTH HACK
+ MOVE C,(TP) ;RE-GOBBLE NEW PVP
+ SUB B,[1,,1] ;FIX FOR STACK
+ MOVEM B,TPBASE+1(C)
+ MOVEM B,TPSTO+1(C) ;MAKE THIS THE CURRENT STACK POINTER
+ MOVEM C,PVPSTO+1(C) ;SAVE THE NEW PVP ITSELF
+ MOVEM TVP,TVPSTO+1(C) ;AND THE GOOD OLD TRANSFER VECTOR
+ AOS A,PTIME ;GOBBLE A UNIQUE PROCESS I.D.
+ MOVEM A,PROCID+1(C) ;SAVE THAT ALSO
+
+;SETUP INITIAL BINDINGS
+
+ PUSH TP,$TPVP ;SAVE PVP
+ PUSH TP,C
+ MOVEI A,4
+ PUSHJ P,IVECT ;B _ NEW BIND VECTOR
+ POP TP,C
+ SUB TP,[1,,1]
+ MOVEM B,SPBASE+1(C) ;NEW SPBASE
+ MOVE A,$TSP
+ MOVEM A,(B)
+ SETZM 1(B)
+ MOVE A,$TBIND
+ HRR A,B
+ ADD B,[1,,1]
+ PUSH B,A
+ MOVEM B,SPSTO+1(C) ;SAVE AS INITIAL SP
+ PUSH B,MQUOTE THIS-PROCESS
+ PUSH B,$TPVP
+ PUSH B,C
+ PUSH B,[0]
+ PUSH B,[0]
+ AOBJP B,ICRQ
+ .VALUE [ASCIZ /SP DISASTER/]
+ICRQ: MOVSI A,TPVP
+ MOVE B,C
+ POPJ P,
+
+;MINI ROUTINE TO CALL VECTOR WITH COUNT IN A
+
+IVECT: PUSH TP,$TFIX
+ PUSH TP,A
+ MCALL 1,VECTOR ;GOBBLE THE VECTOR
+ POPJ P,
+
+
+;SUBROUTINE TO SWAP A PROCESS IN
+;CALLED WITH JSP A,SWAP AND NEW PVP IN B
+
+SWAP: ;FIRST STORE ALL THE ACS
+
+ IRP A,,[PVP,TVP,PP,AB,TB,TP,SP,P,PP]
+ MOVEM A,A!STO+1(PVP)
+ TERMIN
+
+ MOVE E,PVP ;RETURN OLD PROCESS IN E
+ MOVE PVP,D ;AND MAKE NEW ONE BE D
+
+ ;NOW RESTORE NEW PROCESSES AC'S
+
+ IRP A,,[PVP,TVP,PP,AB,TB,TP,SP,P,PP]
+ MOVE A,A!STO+1(PVP)
+ TERMIN
+
+ JRST (C) ;AND RETURN
+
+
+;INTERNAL FUNCTION TO GET STRAGE ALLOCATION TYPE
+;GETS THE TYPE CODE IN A AND RETURNS SAT IN A.
+
+SAT: LSH A,1 ;TIMES 2 TO REF VECTOR
+ HRLS A ;TO BOTH HALVES TO HACK AOBJN POINTER
+ ADD A,TYPVEC+1(TVP) ;ACCESS THE VECTOR
+ HRR A,(A) ;GET PROBABLE SAT
+ JUMPL A,.+2 ;DID WE REALLY HAVE A VALID TYPE
+ MOVEI A,0 ;NO RETURN 0
+ MOVEI A,(A) ;CLOBBER LEFT HALF
+ POPJ P, ;AND RETURN
+
+;TYPE (ITYPE) ARE FUNCTIONS TO RETURN THE ATOMIC NAME OF THE
+;TYPE OF A GOODIE. TYPE TAKES ITS ARGS ON AP AND RETURNS IN A AND B.
+;ITYPE TAKES ITS ARGS IN A AND B AND RETURNS IN SAME (B=0) FOR INVALID
+;TYPECODE.
+MFUNCTION TYPE,SUBR
+
+ ENTRY 1
+ HLLZ A,(AB) ;TYPE INTO A
+TYPE1: PUSHJ P,ITYPE ;GO TO INTERNAL
+ JUMPN B,FINIS ;GOOD RETURN
+TYPERR: PUSH TP,$TATOM ;SETUP ERROR CALL
+ PUSH TP,MQUOTE TYPE-UNDEFINED
+ JRST CALER1" ;STANDARD ERROR HACKER
+
+ITYPE: LSH A,1 ;TIMES 2
+ HLRS A ;TO BOTH SIDES
+ ADD A,TYPVEC+1(TVP) ;GET ACTUAL LOCATION
+ JUMPGE A,TYPLOS ;LOST, TYPE OUT OF BOUNDS
+ MOVE B,1(A) ;PICKUP TYPE
+ HLLZ A,(A)
+ POPJ P,
+
+TYPLOS: MOVSI A,TLIST
+ MOVEI B,NIL
+ POPJ P,
+
+;PRIMTTYPE RETURNS THE TYPE ATOM OF A PRIMITIVE TYPE IN A CLASS
+
+STBL: REPEAT NUMSAT,MQUOTE INTERNAL-TYPE
+
+LOC STBL
+
+IRP A,,[[1WORD,FIX],[2WORD,LIST],[NWORD,UVECTOR],[2NWORD,VECTOR]
+[ARGS,ARGUMENTS],[FRAME,FRAME],[ATOM,ATOM],[CHSTR,STRING]]
+
+IRP B,C,[A]
+LOC STBL+S!B
+MQUOTE C
+
+.ISTOP
+
+TERMIN
+TERMIN
+
+LOC STBL+NUMSAT+1
+
+
+MFUNCTION PRIMTYPE,SUBR
+
+ ENTRY 1
+
+ GETYP A,(AB) ;GET TYPE
+ PUSHJ P,SAT ;GET SAT
+ JUMPE A,TYPERR
+ MOVE B,@STBL(A)
+ MOVSI A,TATOM
+ JRST FINIS
+
+;CHTYPE TAKES TWO ARGUMENTS. ANY GOODIE AND A AN ATOMIC TYPE NAME
+;IT CHECKS THE STORAGE ALLOCATION TYPES OF THE TWO ARE THE SAME AND
+;IF THEY ARE CHANGES THE TYPE OF THE FIRST TO THAT NAME D IN THE SECOND
+
+MFUNCTION CHTYPE,SUBR
+
+ ENTRY 2
+ HLRZ A,2(AB) ;FIRST CHECK THAT ARG 2 IS AN ATOM
+ CAIE A,TATOM
+ JRST NOTATOM
+ MOVE B,3(AB) ;AND TYPE NAME
+ PUSHJ P,TYPLOO ;GO LOOKUP TYPE
+TFOUND: HRRZ B,(A) ;GOBBLE THE SAT
+ HLRZ A,(AB) ;NOW GET TYPE TO HACK
+ PUSHJ P,SAT ;FIND OUT ITS SAT
+ JUMPE A,TYPERR ;COMPLAIN
+ CAIE A,(B) ;DO THEY AGREE?
+ JRST TYPDIF ;NO, COMPLAIN
+ MOVSI A,(D) ;GET NEW TYPE
+ MOVE B,1(AB) ;AND VALUE
+ JRST FINIS
+
+TYPLOO: MOVE A,TYPVEC+1(TVP) ;GOBBLE DOWN TYPE VECTOR
+ MOVEI D,0 ;INITIALIZE TYPE COUNTER
+TLOOK: CAMN B,1(A) ;CHECK THIS ONE
+ POPJ P, ;WIN, RETURN
+ ADDI D,1 ;BUMP COUNTER
+ AOBJP A,.+2 ;COUTN DOWN ON VECTOR
+ AOBJN A,TLOOK
+
+ PUSH TP,$TATOM ;LOST, GENERATE ERROR
+ PUSH TP,MQUOTE BAD-TYPE-NAME
+ JRST CALER1
+
+TYPDIF: PUSH TP,$TATOM ;MAKE ERROR MESSAGE
+ PUSH TP,MQUOTE STORAGE-TYPES-DIFFER
+ JRST CALER1
+
+; FUNCTION TO ADD A NEW TYPE TO THE WORLD WITH GIVEN PRIMITIVE TYPE
+
+MFUNCTION NEWTYPE,SUBR
+
+ ENTRY 2
+
+ GETYP A,(AB) ; GET 1ST ARGS TYPE (SHOULD BE ATOM)
+ GETYP C,2(AB) ; SAME WITH SECOND
+ CAIN A,TATOM ; CHECK
+ CAIE C,TATOM
+ JRST NOTATOM
+
+ SKIPGE C,TYPTOP+1(TVP) ; SKIP IF VECTOR FULL
+ JRST ADDIT ; NO, GO ADD
+ PUSH TP,$TVEC ; CALL GROW
+ PUSH TP,TYPVEC+1(TVP)
+ PUSH TP,$TFIX
+ PUSH TP,[100]
+ PUSH TP,$TFIX
+ PUSH TP,[0]
+ MCALL 3,GROW ; GROW THE POOR VECTOR
+ MOVE C,TYPTOP+1(TVP) ; GET NEW TOP
+
+ADDIT: MOVE B,3(AB) ; GET PRIM TYPE NAME
+ PUSHJ P,TYPLOO ; LOOK IT UP
+ HRRZ A,(B) ; GOBBLE SAT
+ HRLI A,TATOM ; MAKE NEW TYPE
+ MOVEM A,(C) ; CLOBBER IT IN
+ MOVE B,1(AB) ; GET NEW TYPE NAME
+ MOVEM B,1(C)
+ ADD C,[2,,2] ; BUMP POINTER
+ MOVEM C,TYPTOP+1(TVP)
+ MOVE A,(AB)
+ MOVE B,1(AB) ; RETURN NAME
+ JRST FINIS
+
+MFUNCTION ALLTYPES,SUBR
+
+ ENTRY 0
+
+ MOVE A,TYPVEC(TVP)
+ MOVE B,TYPVEC+1(TVP)
+ JRST FINIS
+
+MFUNCTION UTYPE,SUBR
+
+ ENTRY 1
+
+ GETYP A,(AB) ;GET U VECTOR
+ CAIE A,TUVEC
+ JRST WTYP1
+ HLRE A,1(AB) ;GET -LENGTH
+ HRRZ B,1(AB)
+ SUB B,A ;POINT TO TYPE WORD
+ HLLZ A,(B)
+ JRST TYPE1 ;NOW, USE TYPE CODE
+MFUNCTION CHUTYPE,SUBR
+
+ ENTRY 2
+
+ GETYP A,2(AB) ;GET 2D TYPE
+ CAIE A,TATOM
+ JRST NOTATO
+ MOVE A,3(AB) ;GET ATOM
+ PUSHJ P,TYPLOO ;LOOK IT UP
+ HRRZ B,(A) ;GET SAT
+ GETYP A,(AB) ;CHECK FOR UVECTOR
+ CAIE A,TUVEC
+ JRST WTYP1
+ HLRE C,1(AB) ;-LENGTH
+ HRRZ E,1(AB)
+ SUB E,C ;POINT TO TYPE
+ HLRZ A,(E) ;GET TYPE
+ JUMPE A,WIN0 ;ALLOW TYPE "LOSE" TO CHANGE TO ANYTHING
+ PUSHJ P,SAT ;GET SAT
+ JUMPE A,TYPERR
+ CAIE A,(B) ;COMPARE
+ JRST TYPDIF
+WIN0: HRLM D,(E) ;CLOBBER NEW ONE
+ GETYPF A,(AB) ;RETURN ARG
+ MOVE B,1(AB)
+ JRST FINIS
+
+WNA:
+ PUSH TP,$TATOM
+ PUSH TP,MQUOTE WRONG-NUMBER-OF-ARGUMENTS
+ MOVEI A,1
+ JRST CALER"
+
+NOTATOM:
+ PUSH TP,$TATOM
+ PUSH TP,MQUOTE NON-ATOMIC-ARGUMENT
+ PUSH TP,(AB)
+ PUSH TP,1(AB)
+ MOVEI A,2
+ JRST CALER
+
+
+CRLF: MOVEI A,15
+ JRST TYO"
+MSGTYP": HRLI B,440700 ;MAKE BYTE POINTER
+MSGTY1: ILDB A,B ;GET NEXT CHARACTER
+ JUMPE A,CPOPJ ;NULL ENDS STRING
+ PUSHJ P,TYO"
+ JRST MSGTY1 ;AND GET NEXT CHARACTER
+CPOPJ: POPJ P,
+
+; HACK TO PRINT MESSAGE OF INTEREST TO USER
+
+MESOUT: MOVSI A,(JFCL)
+ MOVEM A,MESSAG ;DO ONLY ONCE
+ .SUSET [.RSNAM,,A] ;READ SNAME AND SAVE
+ PUSH P,A ;AND SAVE
+ .SUSET [.SSNAM,,[SIXBIT /MUDDLE/]
+ MOVEI A,[SIXBIT / DSKMUDDLEMESSAG/]
+ PUSHJ P,OPEN ;TRY TO OPEN
+ JRST RESNM
+MESSI: PUSHJ P,IOT ;READ A CHAR
+ JUMPL B,MESCLS ;DONE, QUIT
+ EXCH A,B ;CHAR TO A SAVE CHAN
+ CAIE A,14 ;DONT TYPE FF
+ PUSHJ P,TYO ;AND TYPE IT OUT
+ MOVE A,B ;CHANNEL BACK TO A
+ JRST MESSI ;UNTIL DONE
+
+MESCLS: PUSHJ P,CLOSE ;AND CLOSE
+
+RESNM: POP P,A ;RESTORE SNAME
+ .SUSET [.SSNAM,,A]
+ POPJ P,
+
+MESSAG: PUSHJ P,MESOUT ;MESSAGE SWITCH
+
+
+CRADIX": 10.
+PTIME: 0 ;UNIQUE NUMBER FOR PROCID AND ENVIRONMENTS
+OBLNT": 151. ;LENGTH OF INITIAL OBLISTS
+VECTOP: VECLOC
+VECBOT": VECBASE
+CODBOT: 0 ;ABSOLUTE BOTTOM OF CODE
+CODTOP": PARBASE
+PARTOP: PARLOC
+PARBOT": PARBASE
+PVLNTH: 0
+TVLNTH: 0
+TVBOT: TVBASE
+VECNEW": 0 ;LOCATION FOR OFFSET BETWWEN OLD VECTOP AND NEW VECTOP
+PARNEW": 0 ;LOCATION FOR OFFSET BETTWEEN OLD PARBOT AND NEW PARBOT
+INTFLG: 0 ;INTERRUPT PENDING FLAG
+MAINPR: 0 ;HOLDS POINTER TO THE MAIN PROCESS
+
+PATCH:
+PAT: BLOCK 100
+PATEND: 0
+
+;GARBAGE COLLECTORS PDLS
+
+
+GCPDL: -GCPLNT,,GCPDL
+
+ BLOCK GCPLNT
+
+
+;PROCESS PDL
+
+
+;MARKED PDLS FOR GC PROCESS
+
+VECTGO
+; DUMMY FRAME FOR INITIALIZER CALLS
+
+ TENTRY,,LISTEN
+ 0
+ .-3
+ 0
+ 0
+ -ITPLNT,,TPBAS-1
+ 0
+
+TPBAS: BLOCK ITPLNT+PDLBUF
+ GENERAL
+ ITPLNT+2+PDLBUF+7,,0
+
+APBAS: BLOCK IAPLNT
+ IAPLNT+1,,0
+
+VECRET
+
+
+
+
+$TMATO: TATOM,,-1
+
+
+END
+\f\f\ 3\f
\ No newline at end of file
projects / pdp10-muddle.git / blobdiff