1 TITLE MAIN LOOP AND GLOBALLY REFERENCED SUBROUTINES
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
23 ;MAIN LOOP AND STARTUP
25 START: MOVEI 0,0 ; SET NO HACKS
27 TLNE 0,-1 ; SEE IF CHANNEL
32 PUSHJ P,CKVRS ; CHECK VERSION NUMBERS
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
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
49 PUSHJ P,TTYOPE ;OPEN THE TTY
51 SKIPE WHOAMI ; SKIP IF THIS IS MUDDLE
52 JRST NODEMT ; ELSE NO MESSAGE
53 SKIPE DEMFLG ; SKIP IF NOT DEMON
55 SKIPN NOTTY ; IF NO TTY, IGNORE
56 PUSHJ P,MSGTYP ;TYPE OUT TO USER
58 NODEMT: XCT MESSAG ;MAYBE PRINT A MESSAGE
59 PUSHJ P,INTINT ;INITIALIZE INTERRUPT HANDLER
61 PUSHJ P,PURCLN ; CLEAN UP PURE SHARED AREA
62 RESTART: ;RESTART A PROCESS
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
69 MOVEI A,TFALSE ; IN CASE FALLS OFF PROCESS
80 IMFUNCTION LISTEN,SUBR
83 PUSH P,[0] ;FLAG: DON'T PRINT ERROR MSG
86 ; USER SUPPLIED ERROR HANDLER, TEMPORARY KLUDGE
89 ERROR: MOVE B,IMQUOTE ERROR
90 PUSHJ P,IGVAL ; GET VALUE
92 CAIN C,TSUBR ; CHECK FOR NO CHANGE
93 CAIE B,RERR1 ; SKIP IF NOT CHANGED
95 JRST RERR1 ; GO TO THE DEFAULT
96 PUSH TP,A ; SAVE VALUE
99 MOVEI D,1 ; AND COUNTER
100 USER1: PUSH TP,(C) ; PUSH THEM
105 ACALL D,APPLY ; EVAL USERS ERROR
110 IMFUNCTION ERROR%,SUBR,ERROR
114 PUSH TP,MQUOTE ERROR,ERROR,INTRUP
115 PUSHJ P,FRMSTK ; PUT ERROR'S FRAME ON STACK
118 RERR2: JUMPGE C,RERR22
123 RERR22: ACALL D,EMERGENCY
128 PUSH P,[-1] ;PRINT ERROR FLAG
130 ER1: MOVE B,IMQUOTE INCHAN
131 PUSHJ P,ILVAL ; CHECK INPUT CHANNEL IS SOME KIND OF TTY
133 CAIE A,TCHAN ; SKIP IF IT IS A CHANNEL
134 JRST ER2 ; NO, MUST REBIND
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
148 MCALL 2,TTYECH ; ECHO INPUT
149 NOECHO: MOVE B,IMQUOTE OUTCHAN
150 PUSHJ P,ILVAL ; GET THE VALUE
152 CAIE A,TCHAN ; SKIP IF OK CHANNEL
153 JRST ER3 ; NOT CHANNEL, MUST REBIND
156 ER3: MOVE B,IMQUOTE OUTCHAN
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
168 JRST MAKOB ; NO GLOBAL OBLIST, MAKE ONE
169 MOVEI C,(B) ; COPY ADDRESS
170 MOVE A,(C) ; GET THE GVAL
172 PUSHJ P,OBCHK ; IS IT A WINNER ?
173 JRST MAKOB ; NO, GO MAKE A NEW ONE
174 MOVE B,IMQUOTE OBLIST
177 NOTOBL: PUSH TP,[TATOM,,-1] ;FOR BINDING
178 PUSH TP,IMQUOTE LER,[LERR ]INTRUP
180 HRLI A,TFRAME ; CORRCT TYPE
185 MOVE A,PVSTOR+1 ; GET PROCESS
186 ADD A,[PROCID,,PROCID] ; POINT TO ID (ALSO LEVEL)
190 ADDI A,1 ; BUMP ERROR LEVEL
192 PUSH TP,PROCID+1(PVP)
195 MOVE B,IMQUOTE READ-TABLE
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
210 PUSHJ P,SPECBIND ;BIND THE CRETANS
211 MOVE A,-1(P) ;RESTORE SWITHC
212 JUMPE A,NOERR ;IF 0, DONT PRINT ERROR MESS
214 PUSH TP,EQUOTE *ERROR*
216 MCALL 1,PRINC ;PRINT THE MESSAGE
217 NOERR: MOVE C,AB ;GET A COPY OF AB
219 ERRLP: JUMPGE C,LEVPRT ;IF NONE, RE-ENTER READ-EVAL-PRINT LOOP
223 GETYP A,(C) ; GET ARGS TYPE
226 MOVE A,1(C) ; GET ATOM
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
234 MCALL 0,TERPRI ; CRLF
235 POP P,B ; GET ROUTINE BACK
239 ADD C,[2,,2] ;BUMP SAVED AB
240 JRST ERRLP ;AND CONTINUE
243 LEVPRT: XCT INITFL ;LOAD MUDDLE INIT FILE IF FIRST TIME
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
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
257 PUSH TP,PROCID(PVP) ;NOW ID
258 PUSH TP,PROCID+1(PVP)
265 PUSH TP,EQUOTE [ INT-LEVEL ]
268 JRST MAINLP ; FALL INTO MAIN LOOP
270 \f;ROUTINES FOR ERROR-LISTEN
274 JRST CPOPJ1 ; WIN FOR SINGLE OBLIST
275 CAIE 0,TLIST ; IF LIST, MAKE SURE EACH IS AN OBLIST
276 JRST CPOPJ ; ELSE, LOSE
278 JUMPE B,CPOPJ ; NIL ,LOSE
281 PUSH P,[0] ;FLAG FOR DEFAULT CHECKING
282 MOVEI 0,1000 ; VERY BIG NUMBER FOR CIRCULARITY TEST
285 SOJE 0,OBLOSE ; CIRCULARITY TEST
286 HRRZ B,(TP) ; GET LIST POINTER
288 CAIE A,TOBLS ; SKIP IF WINNER
289 JRST DEFCHK ; CHECK FOR SPECIAL ATOM DEFAULT
294 OBLOSE: SUB TP,[2,,2]
298 DEFCHK: SKIPN (P) ; BEEN HERE BEFORE ?
299 CAIE A,TATOM ; OR, NOT AN ATOM ?
300 JRST OBLOSE ; YES, LOSE
302 CAME A,MQUOTE DEFAULT
305 HRRZ B,(B) ; CHECK FOR END OF LIST
307 JUMPN B,OBCHK0 ; NOT THE END, CONTINUE LOOKING
308 JRST OBLOSE ; LOSE FOR DEFAULT AT THE END
312 PUSH6: PUSH TP,[TATOM,,-1]
321 MAKOB: PUSH TP,INITIAL
327 PUSH TP,IMQUOTE OBLIST
332 PUSH TP,IMQUOTE OBLIST
340 ;THIS IS IT FOLKS...THE MAIN LOOP. READ, EVAL, PRINT
342 MAINLP: MOVE A,$TATOM ;KLUDGE BY NDR LIKE ERROR TO LET LOOSER REDEFINE
344 PUSHJ P,ILVAL ;GET ITS LVAL TO SEE IF REDEFINED
348 MOVE A,$TATOM ;SEE IF IT HAS GVAL SINCE NO LVAL
363 MCALL 1,APPLY ;LOOSER HAS REDEFINED SO CALL HIS
365 IREPER: PUSH P,[0] ;INDICATE FALL THROUGH
368 ERRREP: PUSH TP,[TATOM,,-1]
376 PUSH TP,EQUOTE NON-APPLICABLE-REP
385 IMFUNCTION REPER,SUBR,REP
387 PUSH P,[1] ;INDICATE DIRECT CALL
388 REPERF: MCALL 0,TERPRI
393 PUSHJ P,ILVAL ; ASSIGNED?
397 PUSHJ P,LSTTOF ; PUT LAST AS FIRST
400 MOVE C,IMQUOTE LAST-OUT
404 MOVE B,IMQUOTE L-OUTS
405 PUSHJ P,ILVAL ; ASSIGNED?
409 CAME B,(TP) ; DONT STUFF IT INTO ITSELF
410 JRST STUFIT ; STUFF IT IN
412 CAIE 0,TLIST ; IF A LIST THE L-OUTS
413 STUFIT: PUSHJ P,LSTTOF ; PUT LAST AS FIRST
415 POP P,C ;FLAG FOR FALL THROUGH OR CALL
416 JUMPN C,FINIS ;IN CASE LOOSER CALLED REP
424 MOVEI D,(C) ; SAVE PTR TO 2ND ELEMENT
425 MOVEI 0,-1 ; LET THE LOSER LOSE (HA HA HA)
427 LSTTO1: HRRZ C,(C) ; START SCAN
434 CAIE D,(C) ; AVOID CIRCULARITY
442 LSTTO2: MOVSI A,TLIST
447 ;FUNCTION TO RETRY A PREVIOUS FUNCTION CALL
452 JUMPGE AB,RETRY1 ; USE MOST RECENT
455 GETYP A,(AB) ; CHECK TYPE
458 MOVEI B,(AB) ; POINT TO ARG
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
466 PUSH TP,B ; SAVE FRAME
467 MOVE B,OTBSAV(B) ; GET PRVIOUS FOR UNBIND HACK
469 PUSHJ P,CHUNW ; CHECK ANY UNWINDING
470 CAME SP,SPSAV(TB) ; UNBINDING NEEDED?
472 MOVE P,PSAV(TB) ; GET OTHER STUFF
474 HLRE A,AB ; COMPUTE # OF ARGS
475 MOVNI A,-FRAMLN(A) ; MAKE TP POINT PAST FRAME
477 MOVE C,TPSAV(TB) ; COMPUTE TP
480 MOVE TB,B ; FIX UP TB
481 HRRZ C,FSAV(TB) ; GET FUNCTION
484 GETYP 0,(C) ; RSUBR OR ENTRY?
488 MOVS R,(C) ; SET UP R
493 RETRNT: CAIE 0,TRSUBR
496 RETRN4: HRRZ C,2(C) ; OFFSET
502 RETRN5: MOVEI D,(M) ; TOTAL OFFSET
520 RETRN1: HRL C,(C) ; FIX LH
533 RETRN2: ERRUUO EQUOTE CANT-RETRY-ENTRY-GONE
535 RETRER: ERRUUO EQUOTE PURE-LOAD-FAILURE
538 ;FUNCTION TO DO ERROR RETURN
540 IMFUNCTION ERRET,SUBR
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
552 PUSHJ P,CHPROC ; POINT TO FRAME SLOT
554 ERRET2: MOVE B,IMQUOTE LER,[LERR ]INTRUP
555 PUSHJ P,ILVAL ; GET ITS VALUE
559 PUSHJ P,CHFSWP ; CHECK VALIDITY AND SWAP IF NECESSARY
560 HRRZ 0,OTBSAV(B) ; TOP LEVEL?
562 PUSHJ P,CHUNW ; ANY UNWINDING
566 ; FUNCTION TO RETURN LAST ERROR FRAME OR PREVIOUS FRAME
568 IMFUNCTION FRAME,SUBR
571 JUMPGE AB,FRM1 ; DEFAULT CASE
572 CAMG AB,[-3,,0] ; SKIP IF OK ARGS
574 PUSHJ P,OKFRT ; A FRAME OR SIMILAR THING?
577 FRM1: PUSHJ P,CFRAME ; GO TO INTERNAL
580 CFRAME: JUMPN A,FRM2 ; ARG SUPPLIED?
581 MOVE B,IMQUOTE LER,[LERR ]INTRUP
584 FRM2: PUSHJ P,CHPROC ; CHECK FOR PROCESS
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
592 TRNN B,-1 ; SKIP IF OK
595 FRM3: JUMPN B,FRM4 ; JUMP IF WINNER
596 MOVE B,IMQUOTE THIS-PROCESS
597 PUSHJ P,ILVAL ; GET PROCESS OF INTEREST
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
607 OKFRT: AOS (P) ;ASSUME WINNAGE
620 CHPROC: GETYP 0,A ; TYPE
624 CAMN B,PVSTOR+1 ; THIS PROCESS?
629 CHPRO1: MOVE B,OTBSAV(TB)
632 ; FUNCTION TO RETURN ARGS TUPLE FOR A FRAME
636 PUSHJ P,OKFRT ; CHECK FRAME TYPE
641 CARGS: PUSHJ P,CHPROC
644 MOVEI B,-1(TP) ; POINT TO FRAME SLOT
645 PUSHJ P,CHFRM ; AND CHECK FOR VALIDITY
646 MOVE C,(TP) ; FRAME BACK
648 CARGS1: GETYP 0,FSAV(C) ; IS THIS A FUNNY ONE
649 CAIE 0,TCBLK ; SKIP IF FUNNY
651 MOVE C,OTBSAV(C) ; ASSOCIATE WITH PREVIOUS FRAME
653 HLR A,OTBSAV(C) ; TIME IT AND
654 MOVE B,ABSAV(C) ; GET POINTER
655 SUB TP,[2,,2] ; FLUSH CRAP
658 ; FUNCTION TO RETURN FUNCTION ASSOCIATED WITH A FRAME
661 ENTRY 1 ; FRAME ARGUMENT
662 PUSHJ P,OKFRT ; CHECK TYPE
667 CFUNCT: PUSHJ P,CHPROC
671 PUSHJ P,CHFRM ; CHECK IT
672 MOVE C,(TP) ; RESTORE FRAME
673 HRRZ A,FSAV(C) ;FUNCTION POINTER
675 SKIPA B,@-1(A) ;NO, GET SUBR'S NAME POINTER
676 MOVE B,(A)+3 ;YES, GET RSUBR'S NAME ENTRY
682 ERRUUO EQUOTE FRAME-NO-LONGER-EXISTS
686 ERRUUO EQUOTE TOP-LEVEL-FRAME
691 ; ROUTINE TO HANG INDEFINITELY WITH INTERRUPTS ENABLED
697 JUMPGE AB,HANG1 ; NO PREDICATE
703 REHANG: MOVE A,[PUSHJ P,CHKPRH]
704 MOVEM A,ONINT ; CHECK PREDICATE AFTER ANY INTERRUPT
705 HANG1: ENABLE ;LET OURSELVES BE INTERRUPTED OUT
707 DISABLE ;PREVENT INTERRUPTS AT RANDOM TIMES
714 ; ROUTINE TO SLEEP FOR POSITIVE NUMBER OF SECONDS WITH INTERRUPTS ENABLED
715 ; ARGUMENT SHOULD BE OF TYPE FIX OR FLOAT AND NON-NEGATIVE
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
739 FMPR B,[30.0] ;CONVERT TO FLOATING # OF THIRTIETHS OF A SECOND
740 MULI B,400 ;KLUDGE TO FIX IT
743 MOVE B,C ;MOVE THE FIXED NUMBER INTO B
744 JUMPL B,OUTRNG ;CHECK TO SEE THAT WE HAVE POSITIVE NUMBER
746 RESLEE: MOVE B,[PUSHJ P,CHKPRS]
764 SETZM ONINT ; TURN OFF FEATURE FOR NOW
768 HANGP: SKIPA B,[REHANG]
769 SLEEPP: MOVEI B,RESLEE
782 MFUNCTION VALRET,SUBR
783 ; SUBR TO VALRET A STRING TO SUPERIOR ITS PROCESS
786 GETYP A,(AB) ; GET TYPE OF ARGUMENT
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
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
806 MFUNCTION LOGOUT,SUBR
808 ; SUBR TO DO A .LOGOUT (VALID ONLY AT TOP LEVEL)
810 PUSHJ P,%TOPLQ ; SKIP IF AT TOP LEVEL
813 PUSHJ P,%LOGOUT ; TRY TO FLUSH
814 JRST IFALSE ; COULDN'T DO IT...RETURN FALSE
816 ; FUNCTS TO GET UNAME AND JNAME
818 ; GET XUNAME (REAL UNAME)
819 MFUNCTION XUNAME,SUBR
825 JRST FINIS ; 10X ROUTINES SKIP
836 MFUNCTION XJNAME,SUBR
850 ; FUNCTION TO SET AND READ GLOBAL SNAME
859 GETYP A,(AB) ; ARG MUST BE STRING
869 SNAME1: MOVE B,IMQUOTE SNM
878 RSUJNM: PUSHJ P,6TOCHS ; CONVERT IT
882 SGSNAM: MOVE B,IMQUOTE SNM
896 PUSHJ P,%SSNAM ; SET SNAME IN SYSTEM
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.
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
917 PUSH TP,$TFIX ;GET A UNIFORM VECTOR
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
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
934 ;SETUP INITIAL BINDING
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
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
951 MOVSI A,TPVP ;CLOBBER THE TYPE
952 MOVE B,(TP) ;AND POINTER TO PROCESS
956 ;MINI ROUTINE TO CALL VECTOR WITH COUNT IN A
960 MCALL 1,VECTOR ;GOBBLE THE VECTOR
964 ;SUBROUTINE TO SWAP A PROCESS IN
965 ;CALLED WITH JSP A,SWAP AND NEW PVP IN B
967 SWAP: ;FIRST STORE ALL THE ACS
970 MOVE SP,$TSP ; STORE SPSAVE
973 IRP A,,[SP,AB,TB,TP,P,M,R,FRM]
977 SETOM 1(TP) ; FENCE POST MAIN STACK
978 MOVEM TP,TPSAV(TB) ; CORRECT FRAME
979 SETZM PSAV(TB) ; CLEAN UP CURRENT FRAME
983 MOVE E,PVP ;RETURN OLD PROCESS IN E
984 MOVE PVP,D ;AND MAKE NEW ONE BE D
988 ;NOW RESTORE NEW PROCESSES AC'S
991 IRP A,,[AB,TB,SP,TP,P,M,R,FRM]
1002 ;SUBRS ASSOCIATED WITH TYPES
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
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
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
1025 ; PREDICATE -- IS OBJECT OF TYPE SPECIFIED
1027 MFUNCTION %TYPEQ,SUBR,[TYPE?]
1031 MOVE D,AB ; GET ARGS
1038 PUSHJ P,ITYPQ ; GO INTERNAL
1042 ITYPQ: GETYP A,A ; OBJECT
1044 TYPEQ0: SOJL C,CIFALS
1046 CAIE 0,TATOM ; Type name must be an atom
1048 CAMN B,1(D) ; Same as the OBJECT?
1049 JRST CPOPJ1 ; Yes, return type name
1051 JRST TYPEQ0 ; No, continue comparing
1057 CTYPEQ: SOJE A,CIFALS ; TREAT NO ARGS AS FALSE
1058 MOVEI D,1(A) ; FIND BASE OF ARGS
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
1067 JFCL ; IGNORE SKIP FOR NOW
1068 MOVE TP,E ; SET TP BACK
1069 JUMPL B,CPOPJ1 ; SKIP
1072 ; Entries to get type codes for types for fixing up RSUBRs and assembling
1074 MFUNCTION %TYPEC,SUBR,[TYPE-C]
1083 CAMGE AB,[-3,,0] ; skip if only type name given
1087 TYPEC1: PUSHJ P,CTYPEC ; go to internal
1090 GTPTYP: CAMGE AB,[-5,,0]
1098 CTYPEC: PUSH P,C ; save primtype checker
1099 PUSHJ P,TYPFND ; search type vector
1100 JRST CTPEC2 ; create the poor loser
1104 CAMN B,IMQUOTE TEMPLATE
1120 TCHK: PUSH P,D ; SAVE TYPE
1121 MOVE A,D ; GO TO SAT
1123 CAIG A,NUMSAT ; SKIP IF A TEMPLATE
1125 POP P,D ; RESTORE TYPE
1128 CTPEC2: POP P,C ; GET BACK PRIMTYPE
1136 MCALL 2,NEWTYPE ; CREATE THE POOR GUY
1138 SUBM M,(P) ; UNRELATIVIZE
1141 CTPEC3: HRRZ 0,FSAV(TB)
1149 MFUNCTION %TYPEW,SUBR,[TYPE-W]
1163 CTYPW3: PUSHJ P,CTYPEW
1166 CTYPW1: GETYP 0,2(AB)
1169 CAMGE AB,[-5,,0] ; JUMP IF RH IS GIVEN
1171 CTYPW5: MOVE C,3(AB)
1174 CTYPW2: CAMGE AB,[-7,,0]
1183 PUSHJ P,CTYPEC ; GET CODE IN B
1189 MFUNCTION %VTYPE,SUBR,[VALID-TYPE?]
1202 CVTYPE: PUSHJ P,TYPFND ; LOOK IT UP
1213 ;PRIMTTYPE RETURNS THE TYPE ATOM OF A PRIMITIVE TYPE IN A CLASS
1215 STBL: REPEAT NUMSAT,SETZ MQUOTE INTERNAL-TYPE
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]]
1226 IFSE [Y],SETZ IMQUOTE X
1227 IFSN [Y],SETZ MQUOTE X
1238 MFUNCTION TYPEPRIM,SUBR
1248 CTYPEP: PUSHJ P,TYPLOO ; CONVERT ATOM TO CODE
1249 HRRZ A,(A) ; SAT TO A
1253 MFUNCTION PTSATC,SUBR,[PRIMTYPE-C]
1264 CPRTYC: PUSHJ P,TYPLOO
1271 IMFUNCTION PRIMTYPE,SUBR
1275 MOVE A,(AB) ;GET TYPE
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
1289 ; RSUBR MAKES A VECTOR INTO AN OBJECT OF TYPE RSUBR, ALSO SLIGHTLY MUNGING IT
1291 IMFUNCTION RSUBR,SUBR
1295 CAIE A,TVEC ; MUST BE VECTOR
1297 MOVE B,1(AB) ; GET IT
1298 GETYP A,(B) ; CHECK 1ST ELEMENTS TYPE
1299 CAIN A,TPCODE ; PURE CODE
1303 HLRM B,(B) ; CLOBEER SPECIAL COUNT FIELD
1307 NRSUBR: ERRUUO EQUOTE FIRST-ELEMENT-OF-VECTOR-NOT-CODE
1309 ; ROUTINE TO GENERATE ENTRYY OTHER THAN FIRST TO RSUBRR
1311 IMFUNCTION MENTRY,SUBR,[RSUBR-ENTRY]
1315 GETYP 0,(AB) ; TYPE OF ARG
1316 CAIE 0,TVEC ; BETTER BE VECTOR
1321 MOVE B,1(AB) ; GET VECTOR
1324 GETYP 0,(B) ; FIRST ELEMENT
1327 MENTR2: GETYP 0,2(B)
1331 HRRM C,2(B) ; OFFSET INTO VECTOR
1336 MENTR1: CAIE 0,TATOM
1338 MOVE B,1(B) ; GET ATOM
1339 PUSHJ P,IGVAL ; GET VAL
1343 MOVE C,1(AB) ; RESTORE B
1349 BENTRY: ERRUUO EQUOTE BAD-VECTOR
1351 ; SUBR TO GET ENTRIES OFFSET
1353 MFUNCTION LENTRY,SUBR,[ENTRY-LOC]
1367 RTFALS: MOVSI A,TFALSE
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
1375 PUSHJ P,@0 ;GO TO THE PROPER SUBROUTINE
1376 SUBM M,(P) ;RECONSTITUTE THE RSUBR's PC
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
1385 MFUNCTION CHTYPE,SUBR
1388 GETYP A,2(AB) ;FIRST CHECK THAT ARG 2 IS AN ATOM
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
1396 TRNE B,TMPLBT ; TEMPLAT
1399 GETYP A,(AB) ;NOW GET TYPE TO HACK
1400 PUSHJ P,SAT ;FIND OUT ITS SAT
1401 JUMPE A,TYPERR ;COMPLAIN
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
1412 CHTMPL: MOVE E,1(AB) ; GET ARG
1415 MOVE 0,3(AB) ; SEE IF TO "TEMPLATE"
1416 CAMN 0,IMQUOTE TEMPLATE
1418 TLNN E,-1 ; SKIP IF RESTED
1424 PUSH TP,1(AB) ; SAVE GOODIE
1429 PUSHJ P,IGET ; FIND THE DECL
1433 MOVE D,1(AB) ; NOW GGO TO MATCH
1449 TYPLOO: PUSHJ P,TYPFND
1450 ERRUUO EQUOTE BAD-TYPE-NAME
1453 TYPFND: HLRE A,B ; FIND DOPE WORDS
1454 SUBM B,A ; A POINTS TO IT
1455 HRRE D,(A) ; TYPE-CODE TO D
1457 ANDI D,TYPMSK ; FLUSH FUNNY BITS
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
1471 ADDI D,1 ;BUMP COUNTER
1472 AOBJP A,.+2 ;COUTN DOWN ON VECTOR
1479 TYPDIF: ERRUUO EQUOTE STORAGE-TYPES-DIFFER
1482 TMPLVI: ERRUUO EQUOTE DECL-VIOLATION
1485 ; FUNCTION TO ADD A NEW TYPE TO THE WORLD WITH GIVEN PRIMITIVE TYPE
1487 MFUNCTION NEWTYPE,SUBR
1491 HLRZ 0,AB ; CHEC # OF ARGS
1492 CAILE 0,-4 ; AT LEAST 2
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
1502 MOVE B,3(AB) ; GET PRIM TYPE NAME
1503 PUSHJ P,TYPLOO ; LOOK IT UP
1504 HRRZ A,(A) ; GOBBLE SAT
1506 HRLI A,TATOM ; MAKE NEW TYPE
1508 MOVE B,1(AB) ; SEE IF PREV EXISTED
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
1516 CAIN 0,(A) ; SKIP IF LOSER
1519 ERRUUO EQUOTE TYPE-ALREADY-EXISTS
1522 MOVE B,1(AB) ; NEWTYPE NAME
1523 PUSHJ P,INSNT ; MUNG IN NEW TYPE
1525 NEWTFN: CAML AB,[-5,,] ; SKIP IF TEMPLAT SUPPLIED
1527 MOVEI 0,TMPLBT ; GET THE BIT
1528 IORM 0,-2(B) ; INTO WORD
1529 MOVE A,(AB) ; GET TYPE NAME
1533 PUSH TP,4(AB) ; GET TEMLAT
1537 MOVE B,1(AB) ; RETURN NAME
1540 ; SET UP GROWTH FIELDS
1542 IGROWT: SKIPA A,[111100,,(C)]
1543 IGROWB: MOVE A,[001100,,(C)]
1545 SUB C,B ; POINT TO DOPE WORD
1546 MOVE B,TYPIC ; INDICATED GROW BLOCK
1551 PUSH TP,B ; SAVE NAME OF NEWTYPE
1552 MOVE C,TYPBOT+1 ; CHECK GROWTH NEED
1554 JRST ADDIT ; STILL ROOM
1555 GAGN: PUSHJ P,IGROWB ; SETUP BOTTOM GROWTH
1557 PUSHJ P,IGROWT ; SET UP TOP GROWTH
1562 MOVE C,[11.,,5] ; SET UP INDICATOR FOR AGC
1563 PUSHJ P,AGC ; GROW THE WORLD
1564 AOJL A,GAGN ; BAD AGC LOSSAGE
1566 ADDM 0,TYPBOT+1 ; FIX UP POINTER
1568 ADDIT: MOVE C,TYPVEC+1
1569 SUB C,[2,,2] ; ALLOCATE ROOM
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
1575 POP TP,-1(B) ; CLOBBER IT IN
1577 HLRE C,TYPVEC+1 ; GET CODE
1581 MOVE D,-1(B) ; B HAS POINTER TO TYPE VECTOR DOPE WORDS
1583 CAIG 0,HIBOT ; IS ATOM PURE?
1584 JRST ADDNOI ; NO, SO NO HACKING REQUIRED
1587 PUSHJ P,IMPURIF ; DO IMPURE OF ATOM
1590 SUBM C,B ; RESTORE B
1592 MOVE D,-1(B) ; RESTORE D
1596 HRRM C,(A) ; INTO "GROWTH" FIELD
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-
1608 CTMPLT: SUBM M,(P) ; could possibly gc during this stuff
1609 PUSH TP,$TATOM ; save name of type
1611 PUSH P,B ; save length instr
1612 HLRE A,TD.LNT+1 ; check for template slots left?
1614 SUB B,A ; point to dope words
1615 HLRZ B,1(B) ; get real length
1617 JUMPG A,GOODRM ; jump if ok
1619 PUSH TP,$TUVEC ; save getters and putters
1621 PUSH TP,$TUVEC ; save getters and putters
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
1634 MOVE A,(P) ; length for new getters
1636 HRL C,TD.GET+1 ; get old for copy
1638 PUSHJ P,DOBLTS ; go fixup new uvector
1639 MOVE A,(P) ; finally putters
1643 PUSHJ P,DOBLTS ; go fixup new uvector
1644 MOVE A,(P) ; finally putters
1648 PUSHJ P,DOBLTS ; go fixup new uvector
1649 SUB P,[1,,1] ; flush stack craft
1652 MOVE C,-4(TP) ;GET TD.AGC
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
1661 ADDI A,-1(B) ; A/ final destination
1663 POP P,(A) ; new length ins munged in
1665 MOVNS A ; A/ offset for other guys
1667 ADD A,TD.GET+1 ; point for storing uvs of ins
1671 MOVEM E,-1(A) ; store putter also
1674 MOVEM C,-1(A) ; store putter also
1675 POP P,A ; compute primtype
1678 MOVE B,(TP) ; ready to mung type vector
1680 PUSHJ P,TYPFND ; CHECK TO SEE WHETHER TEMPLATE EXISTS
1685 NOTEM: POP P,A ; RESTORE SAT
1686 HRLI A,TATOM ; GET TYPE
1687 PUSHJ P,INSNT ; INSERT INTO VECTOR
1690 ; this routine copies GET and PUT vectors into new ones
1694 BLT C,-11(B) ; zap those guys in
1695 MOVEI A,TUVEC ; mung in uniform type
1697 MOVEI C,-7(B) ; zero out remainder of uvector
1704 ; FUNCTIONS TO SET UP EVALUATION AND APPLICATION RULES FOR DATA TYPES
1706 MFUNCTION EVALTYPE,SUBR
1710 PUSHJ P,CHKARG ; VERIFY WINNAGE IN ARGS
1711 MOVEI A,EVATYP ; POINT TO TABLE
1712 MOVEI E,EVTYPE ; POINT TO PURE VERSION
1714 TBLCAL: PUSHJ P,TBLSET ; SETUP TABLE ENTRY
1717 MFUNCTION APPLYTYPE,SUBR
1722 MOVEI A,APLTYP ; POINT TO APPLY TABLE
1723 MOVEI E,APTYPE ; PURE TABLE
1728 MFUNCTION PRINTTYPE,SUBR
1733 MOVEI A,PRNTYP ; POINT TO APPLY TABLE
1734 MOVEI E,PRTYPE ; PURE TABLE
1738 ; CHECK ARGS AND SETUP FOR TABLE HACKER
1740 CHKARG: JUMPGE AB,TFA
1743 GETYP A,(AB) ; 1ST MUST BE TYPE NAME
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
1752 HRRZ A,(A) ; GET SAT
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
1760 HRRZ A,(A) ; GET SAT
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
1769 TRYAPL: PUSHJ P,APLQ ; IS THIS APPLICABLE
1772 MOVE B,2(AB) ; RETURN SAME
1778 ; HERE TO PUT ENTRY IN APPROPRIATE TABLE
1781 PUSH TP,D ; SAVE VALUE
1784 PUSH P,C ; SAVE TYPE BEING HACKED
1786 SKIPE B,1(A) ; SKIP IF VECTOR DOESN'T EXIST YET
1788 MOVE B,-2(TP) ; CHECK FOR RETURN IT HACK
1793 HLRE A,TYPBOT+1 ; GET CURRENT TABLE LNTH
1797 PUSHJ P,IVECT ; GET VECTOR
1799 MOVE C,(TP) ; POINT TO RETURN POINT
1800 MOVEM B,1(C) ; SAVE VECTOR
1803 POP P,C ; RESTORE TYPE
1807 JUMPN A,TBLOK1 ; JUMP IF FUNCTION ETC. SUPPLIED
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
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
1825 OK.SET: CAIN 0,(D) ; SKIP ON RESET
1829 RETAR1: MOVE A,(AB) ; RET TYPE
1839 RETPM2: SUB TP,[4,,4]
1857 RETPM3: ADD A,TYPVEC+1
1862 RETPRM: SUBI C,(B) ; UNDO BADNESS
1863 RETPM4: CAIG C,NUMPRI*2
1870 CALLTY: MOVE A,TYPVEC
1874 MFUNCTION ALLTYPES,SUBR
1884 ;FUNCTION TO RETURN TYPE OF ELEMENTS IN A UVECTOR
1886 MFUNCTION UTYPE,SUBR
1890 GETYP A,(AB) ;GET U VECTOR
1894 MOVE B,1(AB) ; GET UVECTOR
1898 CUTYPE: HLRE A,B ;GET -LENGTH
1900 SUB B,A ;POINT TO TYPE WORD
1902 JRST ITYPE ; GET NAME OF TYPE
1904 ; FUNCTION TO CHANGE UNIFORM TYPE OF A VECTOR
1906 MFUNCTION CHUTYPE,SUBR
1910 GETYP A,2(AB) ;GET 2D TYPE
1913 GETYP A,(AB) ; CALL WITH UVECTOR?
1917 MOVE A,1(AB) ; GET UV POINTER
1918 MOVE B,3(AB) ;GET ATOM
1920 MOVE A,(AB) ; RETURN UVECTOR
1924 CCHUTY: PUSH TP,$TUVEC
1926 PUSHJ P,TYPLOO ;LOOK IT UP
1933 HLRE C,(TP) ;-LENGTH
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
1943 HRLM D,(E) ;CLOBBER NEW ONE
1948 CANTCH: PUSH TP,$TATOM
1949 PUSH TP,EQUOTE CANT-CHTYPE-INTO
1957 PUSH TP,EQUOTE NON-ATOMIC-ARGUMENT
1965 ; SUBROUTINE TO LEAVE MUDDLE CLOSING ALL CHANNELS ON THE WAY
1972 PUSHJ P,CLOSAL ; DO THE CLOSES
1974 JRST IFALSE ; JUST IN CASE
1976 CLOSAL: MOVEI B,CHNL0+2 ; POINT TO 1ST (NOT INCLUDING TTY I/O)
1978 MOVE TVP,REALTV+1(PVP)
1984 PUSH P,[N.CHNS-1] ; MAX NO. OF CHANS
1990 SKIPN C,-1(B) ; THIS ONE OPEN?
1995 PUSH TP,-2(B) ; PUSH IT
1997 MCALL 1,FCLOSE ; CLOSE IT
1998 CLOSA4: SOSLE (P) ; COUNT DOWN
2005 CLOSA3: SKIPN B,CHNL0+1
2018 WHOAMI: 0 ; SYAYS WHETHER I AM REALLY A MUDDLE OR SOME HACK
2021 ;GARBAGE COLLECTORS PDLS
2024 GCPDL: -GCPLNT,,GCPDL
2031 MUDSTR: ASCII /MUDDLE
\7f\7f\7f/
2035 ASCIZ / IN OPERATION./
2037 ;MARKED PDLS FOR GC PROCESS
2040 ; DUMMY FRAME FOR INITIALIZER CALLS
2050 TPBAS: BLOCK ITPLNT+PDLBUF
2052 ITPLNT+2+PDLBUF+7,,0