1 TITLE MAIN LOOP AND GLOBALLY REFERENCED SUBROUTINES
5 .GLOBAL TBINIT,PIDSTO,PROCID,PTIME,GCPDL,PBASE,TYPTOP,RERR,FRMSTK,EMERGE
6 .GLOBAL PDLBUF,INTINT,START,SWAP,ICR,SPBASE,TPBASE,TPBAS,CURPRI,CHFINI,MKTBS
7 .GLOBAL TOPLEVEL,INTOBL,INITIA,ERROBL,MAINPR,RESFUN,STATUS,TYPVEC,ROOT,TTICHN,TTOCHN
8 .GLOBAL TTYOPE,MOPEN,MCLOSE,MIOT,ILVAL,MESS,ERROR,CHFRM,IGVAL,TYPBOT,ASOVEC
9 .GLOBAL PRINT,PRIN1,PRINC,MUDSTR,VECBOT,CSTACK,IFALSE,TYPLOO,RCALL,SWAPIN,CTMPLT
10 .GLOBAL IDPROC,CHFSWP,ILOC,MAKACT,BNDV,SPECSTORE,BINDID,IGLOC,MTYO,MSGTYP,CAFRE1,CPOPJ
11 .GLOBAL EVATYP,EVTYPE,APLTYP,APTYPE,PRNTYP,PRTYPE,AGC,SGSNAM,NAPT,APLQ,STRTO6
12 .GLOBAL 6TOCHS,TYPFND,STBL,CHNL0,N.CHNS,CLOSAL,%LOGOUT,%SSNAM,%RSNAM,%KILLM,SAT
13 .GLOBAL MAKINF,%VALRET,COMPERR,IPUT,IGET,TMATCH,INITIZ,IPCINI,%UNAM,%JNAM,%RUNAM,%RJNAM,%RXUNA,%RXJNA,%VALFI
14 .GLOBAL NOTTY,DEMFLG,CFRAME,CARGS,CFUNCT,CITYPE,CTYPEQ,CPTYPE,CTYPEP,CUTYPE,
15 .GLOBAL CCHUTY,RTFALS,PGINT,PURCLN,CTYPEC,CTYPEW,IDVAL1,CALLTY,MESSAG,INITFL,WHOAMI
16 .GLOBAL %SLEEP,%HANG,%TOPLQ,ONINT,CHUNW,CURFCN,BUFRIN,TD.LNT,TD.GET,TD.AGC,TD.PUT,MPOPJ
17 .GLOBAL PURVEC,PLOAD,SSPECS,OUTRNG,CVTYPE,FSTART,CKVRS,CPRTYC,PVSTOR,SPSTOR
18 .GLOBAL TYPIC,CISET,LSTUF,IMPURI,REALTV
21 ;MAIN LOOP AND STARTUP
23 START: MOVEI 0,0 ; SET NO HACKS
25 TLNE 0,-1 ; SEE IF CHANNEL
30 PUSHJ P,CKVRS ; CHECK VERSION NUMBERS
32 JRST FSTART ; GO RESTORE
33 START1: MOVEM 0,WHOAMI ; HACK FOR TS FOO linked to TS MUDDLE
34 MOVE PVP,MAINPR ; MAKE SURE WE START IN THE MAIN PROCESS
35 JUMPE 0,INITIZ ; MIGHT BE RESTART
36 MOVE P,PSTO+1(PVP) ; SET UP FOR BOOTSTRAP HACK
38 INITIZ: MOVE PVP,MAINPR
39 SKIPN P ; IF NO CURRENT P
40 MOVE P,PSTO+1(PVP) ; PDL TO GET OFF THE GROUND
41 SKIPN TP ; SAME FOR TP
42 MOVE TP,TPSTO+1(PVP) ; GET A TP TO WORK WITH
43 SETZB R,M ; RESET RSUBR AC'S
47 PUSHJ P,TTYOPE ;OPEN THE TTY
49 SKIPE WHOAMI ; SKIP IF THIS IS MUDDLE
50 JRST NODEMT ; ELSE NO MESSAGE
51 SKIPE DEMFLG ; SKIP IF NOT DEMON
53 SKIPN NOTTY ; IF NO TTY, IGNORE
54 PUSHJ P,MSGTYP ;TYPE OUT TO USER
56 NODEMT: XCT MESSAG ;MAYBE PRINT A MESSAGE
57 PUSHJ P,INTINT ;INITIALIZE INTERRUPT HANDLER
59 PUSHJ P,PURCLN ; CLEAN UP PURE SHARED AREA
60 RESTART: ;RESTART A PROCESS
63 MOVE B,TBINIT+1(PVP) ;POINT INTO STACK AT START
64 PUSHJ P,CHUNW ; LEAVE WHILE DOING UNWIND CHECK
66 MOVEI A,TFALSE ; IN CASE FALLS OFF PROCESS
77 IMFUNCTION LISTEN,SUBR
80 PUSH P,[0] ;FLAG: DON'T PRINT ERROR MSG
83 ; USER SUPPLIED ERROR HANDLER, TEMPORARY KLUDGE
86 ERROR: MOVE B,IMQUOTE ERROR
87 PUSHJ P,IGVAL ; GET VALUE
89 CAIN C,TSUBR ; CHECK FOR NO CHANGE
90 CAIE B,RERR1 ; SKIP IF NOT CHANGED
92 JRST RERR1 ; GO TO THE DEFAULT
93 PUSH TP,A ; SAVE VALUE
96 MOVEI D,1 ; AND COUNTER
97 USER1: PUSH TP,(C) ; PUSH THEM
102 ACALL D,APPLY ; EVAL USERS ERROR
107 IMFUNCTION ERROR%,SUBR,ERROR
111 PUSH TP,MQUOTE ERROR,ERROR,INTRUP
112 PUSHJ P,FRMSTK ; PUT ERROR'S FRAME ON STACK
115 RERR2: JUMPGE C,RERR22
120 RERR22: ACALL D,EMERGENCY
125 PUSH P,[-1] ;PRINT ERROR FLAG
127 ER1: MOVE B,IMQUOTE INCHAN
128 PUSHJ P,ILVAL ; CHECK INPUT CHANNEL IS SOME KIND OF TTY
130 CAIE A,TCHAN ; SKIP IF IT IS A CHANNEL
131 JRST ER2 ; NO, MUST REBIND
134 ER2: MOVE B,IMQUOTE INCHAN
135 MOVEI C,TTICHN ; POINT TO VALU
136 PUSHJ P,PUSH6 ; PUSH THE BINDING
137 MOVE B,TTICHN+1 ; GET IN CHAN
138 NOTINC: SKIPN DEMFLG ; SKIP IF DEMON
145 MCALL 2,TTYECH ; ECHO INPUT
146 NOECHO: MOVE B,IMQUOTE OUTCHAN
147 PUSHJ P,ILVAL ; GET THE VALUE
149 CAIE A,TCHAN ; SKIP IF OK CHANNEL
150 JRST ER3 ; NOT CHANNEL, MUST REBIND
153 ER3: MOVE B,IMQUOTE OUTCHAN
155 PUSHJ P,PUSH6 ; PUSH THE BINDINGS
156 NOTOUT: MOVE B,IMQUOTE OBLIST
157 PUSHJ P,ILVAL ; GET THE VALUE OF OBLIST
158 PUSHJ P,OBCHK ; IS IT A WINNER ?
159 SKIPA A,$TATOM ; NO, SKIP AND CONTINUE
160 JRST NOTOBL ; YES, DO NOT DO REBINDING
161 MOVE B,IMQUOTE OBLIST
165 JRST MAKOB ; NO GLOBAL OBLIST, MAKE ONE
166 MOVEI C,(B) ; COPY ADDRESS
167 MOVE A,(C) ; GET THE GVAL
169 PUSHJ P,OBCHK ; IS IT A WINNER ?
170 JRST MAKOB ; NO, GO MAKE A NEW ONE
171 MOVE B,IMQUOTE OBLIST
174 NOTOBL: PUSH TP,[TATOM,,-1] ;FOR BINDING
175 PUSH TP,IMQUOTE LER,[LERR ]INTRUP
177 HRLI A,TFRAME ; CORRCT TYPE
182 MOVE A,PVSTOR+1 ; GET PROCESS
183 ADD A,[PROCID,,PROCID] ; POINT TO ID (ALSO LEVEL)
187 ADDI A,1 ; BUMP ERROR LEVEL
189 PUSH TP,PROCID+1(PVP)
192 MOVE B,IMQUOTE READ-TABLE
195 PUSH TP,IMQUOTE READ-TABLE
196 GETYP C,A ; TO GVAL OF READ-TABLE ON ERROR AND
197 CAIE C,TVEC ; TOP ERRET'S
207 PUSHJ P,SPECBIND ;BIND THE CRETANS
208 MOVE A,-1(P) ;RESTORE SWITHC
209 JUMPE A,NOERR ;IF 0, DONT PRINT ERROR MESS
211 PUSH TP,EQUOTE *ERROR*
213 MCALL 1,PRINC ;PRINT THE MESSAGE
214 NOERR: MOVE C,AB ;GET A COPY OF AB
216 ERRLP: JUMPGE C,LEVPRT ;IF NONE, RE-ENTER READ-EVAL-PRINT LOOP
220 GETYP A,(C) ; GET ARGS TYPE
223 MOVE A,1(C) ; GET ATOM
225 CAME A,[-1,,ERROBL+1]
226 CAMN A,ERROBL+1 ; DONT SKIP IF IN ERROR OBLIST
227 MOVEI B,PRINC ; DONT PRINT TRAILER
228 ERROK: PUSH P,B ; SAVE ROUTINE POINTER
231 MCALL 0,TERPRI ; CRLF
232 POP P,B ; GET ROUTINE BACK
236 ADD C,[2,,2] ;BUMP SAVED AB
237 JRST ERRLP ;AND CONTINUE
240 LEVPRT: XCT INITFL ;LOAD MUDDLE INIT FILE IF FIRST TIME
243 PUSH TP,EQUOTE [LISTENING-AT-LEVEL ]
244 MCALL 1,PRINC ;PRINT LEVEL
245 PUSH TP,$TFIX ;READY TO PRINT LEVEL
246 HRRZ A,(P) ;GET LEVEL
247 SUB P,[2,,2] ;AND POP STACK
249 MCALL 1,PRIN1 ;PRINT WITHOUT SPACES ETC.
250 PUSH TP,$TATOM ;NOW PROCESS
251 PUSH TP,EQUOTE [ PROCESS ]
252 MCALL 1,PRINC ;DONT SLASHIFY SPACES
254 PUSH TP,PROCID(PVP) ;NOW ID
255 PUSH TP,PROCID+1(PVP)
262 PUSH TP,EQUOTE [ INT-LEVEL ]
265 JRST MAINLP ; FALL INTO MAIN LOOP
267 \f;ROUTINES FOR ERROR-LISTEN
271 JRST CPOPJ1 ; WIN FOR SINGLE OBLIST
272 CAIE 0,TLIST ; IF LIST, MAKE SURE EACH IS AN OBLIST
273 JRST CPOPJ ; ELSE, LOSE
275 JUMPE B,CPOPJ ; NIL ,LOSE
278 PUSH P,[0] ;FLAG FOR DEFAULT CHECKING
279 MOVEI 0,1000 ; VERY BIG NUMBER FOR CIRCULARITY TEST
282 SOJE 0,OBLOSE ; CIRCULARITY TEST
283 HRRZ B,(TP) ; GET LIST POINTER
285 CAIE A,TOBLS ; SKIP IF WINNER
286 JRST DEFCHK ; CHECK FOR SPECIAL ATOM DEFAULT
291 OBLOSE: SUB TP,[2,,2]
295 DEFCHK: SKIPN (P) ; BEEN HERE BEFORE ?
296 CAIE A,TATOM ; OR, NOT AN ATOM ?
297 JRST OBLOSE ; YES, LOSE
299 CAME A,MQUOTE DEFAULT
302 HRRZ B,(B) ; CHECK FOR END OF LIST
304 JUMPN B,OBCHK0 ; NOT THE END, CONTINUE LOOKING
305 JRST OBLOSE ; LOSE FOR DEFAULT AT THE END
309 PUSH6: PUSH TP,[TATOM,,-1]
318 MAKOB: PUSH TP,INITIAL
324 PUSH TP,IMQUOTE OBLIST
329 PUSH TP,IMQUOTE OBLIST
337 ;THIS IS IT FOLKS...THE MAIN LOOP. READ, EVAL, PRINT
339 MAINLP: MOVE A,$TATOM ;KLUDGE BY NDR LIKE ERROR TO LET LOOSER REDEFINE
341 PUSHJ P,ILVAL ;GET ITS LVAL TO SEE IF REDEFINED
345 MOVE A,$TATOM ;SEE IF IT HAS GVAL SINCE NO LVAL
360 MCALL 1,APPLY ;LOOSER HAS REDEFINED SO CALL HIS
362 IREPER: PUSH P,[0] ;INDICATE FALL THROUGH
365 ERRREP: PUSH TP,[TATOM,,-1]
373 PUSH TP,EQUOTE NON-APPLICABLE-REP
382 IMFUNCTION REPER,SUBR,REP
384 PUSH P,[1] ;INDICATE DIRECT CALL
385 REPERF: MCALL 0,TERPRI
390 PUSHJ P,ILVAL ; ASSIGNED?
394 PUSHJ P,LSTTOF ; PUT LAST AS FIRST
397 MOVE C,IMQUOTE LAST-OUT
401 MOVE B,IMQUOTE L-OUTS
402 PUSHJ P,ILVAL ; ASSIGNED?
406 CAME B,(TP) ; DONT STUFF IT INTO ITSELF
407 JRST STUFIT ; STUFF IT IN
409 CAIE 0,TLIST ; IF A LIST THE L-OUTS
410 STUFIT: PUSHJ P,LSTTOF ; PUT LAST AS FIRST
412 POP P,C ;FLAG FOR FALL THROUGH OR CALL
413 JUMPN C,FINIS ;IN CASE LOOSER CALLED REP
421 MOVEI D,(C) ; SAVE PTR TO 2ND ELEMENT
422 MOVEI 0,-1 ; LET THE LOSER LOSE (HA HA HA)
424 LSTTO1: HRRZ C,(C) ; START SCAN
431 CAIE D,(C) ; AVOID CIRCULARITY
439 LSTTO2: MOVSI A,TLIST
444 ;FUNCTION TO RETRY A PREVIOUS FUNCTION CALL
449 JUMPGE AB,RETRY1 ; USE MOST RECENT
452 GETYP A,(AB) ; CHECK TYPE
455 MOVEI B,(AB) ; POINT TO ARG
457 RETRY1: MOVE B,IMQUOTE LER,[LERR ]INTRUP
458 PUSHJ P,ILOC ; LOCATIVE TO FRAME
459 RETRY2: PUSHJ P,CHFSWP ; CHECK VALIDITY AND SWAP IF NECESSARY
460 HRRZ 0,OTBSAV(B) ; CHECK FOR TOP
461 JUMPE 0,RESTAR ; YES RE-ENTER TOP LEVEL
463 PUSH TP,B ; SAVE FRAME
464 MOVE B,OTBSAV(B) ; GET PRVIOUS FOR UNBIND HACK
466 PUSHJ P,CHUNW ; CHECK ANY UNWINDING
467 CAME SP,SPSAV(TB) ; UNBINDING NEEDED?
469 MOVE P,PSAV(TB) ; GET OTHER STUFF
471 HLRE A,AB ; COMPUTE # OF ARGS
472 MOVNI A,-FRAMLN(A) ; MAKE TP POINT PAST FRAME
474 MOVE C,TPSAV(TB) ; COMPUTE TP
477 MOVE TB,B ; FIX UP TB
478 HRRZ C,FSAV(TB) ; GET FUNCTION
481 GETYP 0,(C) ; RSUBR OR ENTRY?
485 MOVS R,(C) ; SET UP R
490 RETRNT: CAIE 0,TRSUBR
493 RETRN4: HRRZ C,2(C) ; OFFSET
499 RETRN5: MOVEI D,(M) ; TOTAL OFFSET
517 RETRN1: HRL C,(C) ; FIX LH
530 RETRN2: ERRUUO EQUOTE CANT-RETRY-ENTRY-GONE
532 RETRER: ERRUUO EQUOTE PURE-LOAD-FAILURE
535 ;FUNCTION TO DO ERROR RETURN
537 IMFUNCTION ERRET,SUBR
540 HLRE A,AB ; -2*# OF ARGS
541 JUMPGE A,STP ; RESTART PROCESS
542 ASH A,-1 ; -# OF ARGS
543 AOJE A,ERRET2 ; NO FRAME SUPPLIED
549 PUSHJ P,CHPROC ; POINT TO FRAME SLOT
551 ERRET2: MOVE B,IMQUOTE LER,[LERR ]INTRUP
552 PUSHJ P,ILVAL ; GET ITS VALUE
556 PUSHJ P,CHFSWP ; CHECK VALIDITY AND SWAP IF NECESSARY
557 HRRZ 0,OTBSAV(B) ; TOP LEVEL?
559 PUSHJ P,CHUNW ; ANY UNWINDING
563 ; FUNCTION TO RETURN LAST ERROR FRAME OR PREVIOUS FRAME
565 IMFUNCTION FRAME,SUBR
568 JUMPGE AB,FRM1 ; DEFAULT CASE
569 CAMG AB,[-3,,0] ; SKIP IF OK ARGS
571 PUSHJ P,OKFRT ; A FRAME OR SIMILAR THING?
574 FRM1: PUSHJ P,CFRAME ; GO TO INTERNAL
577 CFRAME: JUMPN A,FRM2 ; ARG SUPPLIED?
578 MOVE B,IMQUOTE LER,[LERR ]INTRUP
581 FRM2: PUSHJ P,CHPROC ; CHECK FOR PROCESS
584 MOVEI B,-1(TP) ; POINT TO SLOT
585 PUSHJ P,CHFRM ; CHECK IT
586 MOVE C,(TP) ; GET FRAME BACK
587 MOVE B,OTBSAV(C) ;GET PREVIOUS FRAME
589 TRNN B,-1 ; SKIP IF OK
592 FRM3: JUMPN B,FRM4 ; JUMP IF WINNER
593 MOVE B,IMQUOTE THIS-PROCESS
594 PUSHJ P,ILVAL ; GET PROCESS OF INTEREST
597 MOVE B,PVSTOR+1 ; USE CURRENT
598 MOVEI A,PVLNT*2+1(B) ; POINT TO DOPE WORDS
599 MOVE B,TBINIT+1(B) ; AND BASE FRAME
600 FRM4: HLL B,OTBSAV(B) ;TIME
604 OKFRT: AOS (P) ;ASSUME WINNAGE
617 CHPROC: GETYP 0,A ; TYPE
621 CAMN B,PVSTOR+1 ; THIS PROCESS?
626 CHPRO1: MOVE B,OTBSAV(TB)
629 ; FUNCTION TO RETURN ARGS TUPLE FOR A FRAME
633 PUSHJ P,OKFRT ; CHECK FRAME TYPE
638 CARGS: PUSHJ P,CHPROC
641 MOVEI B,-1(TP) ; POINT TO FRAME SLOT
642 PUSHJ P,CHFRM ; AND CHECK FOR VALIDITY
643 MOVE C,(TP) ; FRAME BACK
645 CARGS1: GETYP 0,FSAV(C) ; IS THIS A FUNNY ONE
646 CAIE 0,TCBLK ; SKIP IF FUNNY
648 MOVE C,OTBSAV(C) ; ASSOCIATE WITH PREVIOUS FRAME
650 HLR A,OTBSAV(C) ; TIME IT AND
651 MOVE B,ABSAV(C) ; GET POINTER
652 SUB TP,[2,,2] ; FLUSH CRAP
655 ; FUNCTION TO RETURN FUNCTION ASSOCIATED WITH A FRAME
658 ENTRY 1 ; FRAME ARGUMENT
659 PUSHJ P,OKFRT ; CHECK TYPE
664 CFUNCT: PUSHJ P,CHPROC
668 PUSHJ P,CHFRM ; CHECK IT
669 MOVE C,(TP) ; RESTORE FRAME
670 HRRZ A,FSAV(C) ;FUNCTION POINTER
672 SKIPA B,@-1(A) ;NO, GET SUBR'S NAME POINTER
673 MOVE B,(A)+3 ;YES, GET RSUBR'S NAME ENTRY
679 ERRUUO EQUOTE FRAME-NO-LONGER-EXISTS
683 ERRUUO EQUOTE TOP-LEVEL-FRAME
688 ; ROUTINE TO HANG INDEFINITELY WITH INTERRUPTS ENABLED
694 JUMPGE AB,HANG1 ; NO PREDICATE
700 REHANG: MOVE A,[PUSHJ P,CHKPRH]
701 MOVEM A,ONINT ; CHECK PREDICATE AFTER ANY INTERRUPT
702 HANG1: ENABLE ;LET OURSELVES BE INTERRUPTED OUT
704 DISABLE ;PREVENT INTERRUPTS AT RANDOM TIMES
711 ; ROUTINE TO SLEEP FOR POSITIVE NUMBER OF SECONDS WITH INTERRUPTS ENABLED
712 ; ARGUMENT SHOULD BE OF TYPE FIX OR FLOAT AND NON-NEGATIVE
730 JUMPL B,OUTRNG ;ARG SHOULDNT BE NEGATIVE
731 IMULI B,30. ;CONVERT TO # OF THIRTIETHS OF A SECOND
732 JRST SLEEPR ;GO SLEEP
733 CAIE 0,TFLOAT ;IF IT WASNT FIX MAKE SURE IT IS FLOAT
734 JRST WTYP1 ;WRONG TYPE ARG
736 FMPR B,[30.0] ;CONVERT TO FLOATING # OF THIRTIETHS OF A SECOND
737 MULI B,400 ;KLUDGE TO FIX IT
740 MOVE B,C ;MOVE THE FIXED NUMBER INTO B
741 JUMPL B,OUTRNG ;CHECK TO SEE THAT WE HAVE POSITIVE NUMBER
743 RESLEE: MOVE B,[PUSHJ P,CHKPRS]
761 SETZM ONINT ; TURN OFF FEATURE FOR NOW
765 HANGP: SKIPA B,[REHANG]
766 SLEEPP: MOVEI B,RESLEE
779 MFUNCTION VALRET,SUBR
780 ; SUBR TO VALRET A STRING TO SUPERIOR ITS PROCESS
783 GETYP A,(AB) ; GET TYPE OF ARGUMENT
786 CAIE A,TCHSTR ; IS IT A CHR STRING?
787 JRST WTYP1 ; NO...ERROR WRONG TYPE
788 PUSHJ P,CSTACK ; COPY THE CHR STRING TO THE STACK
789 ; CSTACK IS IN ATOMHK
790 MOVEI B,0 ; ASCIZ TERMINATOR
791 EXCH B,(P) ; STORE AND RETRIEVE COUNT
793 ; CALCULATE THE BEGINNING ADDR OF THE STRING
794 MOVEI A,-1(P) ; GET ADDR OF TOP OF STACK
795 SUBI A,-1(B) ; GET STARTING ADDR
796 PUSHJ P,%VALRE ; PASS UP TO MONITOR
797 JRST IFALSE ; IF HE RETURNS, RETURN FALSE
803 MFUNCTION LOGOUT,SUBR
805 ; SUBR TO DO A .LOGOUT (VALID ONLY AT TOP LEVEL)
807 PUSHJ P,%TOPLQ ; SKIP IF AT TOP LEVEL
810 PUSHJ P,%LOGOUT ; TRY TO FLUSH
811 JRST IFALSE ; COULDN'T DO IT...RETURN FALSE
813 ; FUNCTS TO GET UNAME AND JNAME
815 ; GET XUNAME (REAL UNAME)
816 MFUNCTION XUNAME,SUBR
822 JRST FINIS ; 10X ROUTINES SKIP
833 MFUNCTION XJNAME,SUBR
847 ; FUNCTION TO SET AND READ GLOBAL SNAME
856 GETYP A,(AB) ; ARG MUST BE STRING
866 SNAME1: MOVE B,IMQUOTE SNM
875 RSUJNM: PUSHJ P,6TOCHS ; CONVERT IT
879 SGSNAM: MOVE B,IMQUOTE SNM
893 PUSHJ P,%SSNAM ; SET SNAME IN SYSTEM
898 ;THIS SUBROUTINE ALLOCATES A NEW PROCESS
899 ;TAKES TP-STACK SIZE (2*WORDS) IN A AND P-STACK SIZE (WORDS) IN B
900 ;IS CALLED BY PUSHJ P,. RETURNS IN A AND B A NEW PROCESS.
904 MOVEI A,PVLNT ;SETUP CALL TO VECTOR FOR PVP
905 PUSHJ P,IVECT ;GOBBLE A VECTOR
906 HRLI C,PVBASE ;SETUP A BLT POINTER
907 HRRI C,(B) ;GET INTO ADDRESS
908 BLT C,PVLNT*2-1(B) ;COPY A PROTOTYPE INTO NEW PVP
909 MOVSI C,400000+SPVP+.VECT. ;SET SPECIAL TYPE
910 MOVEM C,PVLNT*2(B) ;CLOBBER IT IN
911 PUSH TP,A ;SAVE THE RESULTS OF VECTOR
914 PUSH TP,$TFIX ;GET A UNIFORM VECTOR
918 ADD B,[PDLBUF-2,,-1] ;FUDGE WITH BUFFER
919 MOVE C,(TP) ;REGOBBLE PROCESS POINTER
920 MOVEM B,PSTO+1(C) ;STORE IN ALL HOMES
924 POP P,A ;PREPARE TO CREATE A TEMPORARY PDL
925 PUSHJ P,IVECT ;GET THE TEMP PDL
926 ADD B,[PDLBUF,,0] ;PDL GROWTH HACK
927 MOVE C,(TP) ;RE-GOBBLE NEW PVP
928 SUB B,[1,,1] ;FIX FOR STACK
931 ;SETUP INITIAL BINDING
934 MOVEM B,SPBASE+1(C) ;SAVE AS BASE OF SP
935 MOVEM B,SPSTO+1(C) ;AND CURRENT THEREOF
936 MOVEM B,CURFCN+1(C) ; AND AS CURRENT FCN FOR SPEC/UNSPEC LOGIC
937 PUSH B,IMQUOTE THIS-PROCESS
938 PUSH B,$TPVP ;GIVE IT PROCESS AS VALUE
940 ADD B,[2,,2] ;FINISH FRAME
941 MOVEM B,TPSTO+1(C) ;MAKE THIS THE CURRENT STACK POINTER
942 MOVEM C,PVPSTO+1(C) ;SAVE THE NEW PVP ITSELF
943 AOS A,IDPROC ;GOBBLE A UNIQUE PROCESS I.D.
944 MOVEM A,PROCID+1(C) ;SAVE THAT ALSO
945 AOS A,PTIME ; GET A UNIQUE BINDING ID
948 MOVSI A,TPVP ;CLOBBER THE TYPE
949 MOVE B,(TP) ;AND POINTER TO PROCESS
953 ;MINI ROUTINE TO CALL VECTOR WITH COUNT IN A
957 MCALL 1,VECTOR ;GOBBLE THE VECTOR
961 ;SUBROUTINE TO SWAP A PROCESS IN
962 ;CALLED WITH JSP A,SWAP AND NEW PVP IN B
964 SWAP: ;FIRST STORE ALL THE ACS
967 MOVE SP,$TSP ; STORE SPSAVE
970 IRP A,,[SP,AB,TB,TP,P,M,R,FRM]
974 SETOM 1(TP) ; FENCE POST MAIN STACK
975 MOVEM TP,TPSAV(TB) ; CORRECT FRAME
976 SETZM PSAV(TB) ; CLEAN UP CURRENT FRAME
980 MOVE E,PVP ;RETURN OLD PROCESS IN E
981 MOVE PVP,D ;AND MAKE NEW ONE BE D
985 ;NOW RESTORE NEW PROCESSES AC'S
988 IRP A,,[AB,TB,SP,TP,P,M,R,FRM]
999 ;SUBRS ASSOCIATED WITH TYPES
1001 ;TYPE (ITYPE) ARE FUNCTIONS TO RETURN THE ATOMIC NAME OF THE
1002 ;TYPE OF A GOODIE. TYPE TAKES ITS ARGS ON AP AND RETURNS IN A AND B.
1003 ;ITYPE TAKES ITS ARGS IN A AND B AND RETURNS IN SAME (B=0) FOR INVALID
1008 GETYP A,(AB) ;TYPE INTO A
1009 TYPE1: PUSHJ P,ITYPE ;GO TO INTERNAL
1010 JUMPN B,FINIS ;GOOD RETURN
1011 TYPERR: ERRUUO EQUOTE TYPE-UNDEFINED
1013 CITYPE: GETYP A,A ; GET TYPE FOR COMPILER CALL
1014 ITYPE: LSH A,1 ;TIMES 2
1015 HRLS A ;TO BOTH SIDES
1016 ADD A,TYPVEC+1 ;GET ACTUAL LOCATION
1017 JUMPGE A,TYPERR ;LOST, TYPE OUT OF BOUNDS
1018 MOVE B,1(A) ;PICKUP TYPE
1022 ; PREDICATE -- IS OBJECT OF TYPE SPECIFIED
1024 MFUNCTION %TYPEQ,SUBR,[TYPE?]
1028 MOVE D,AB ; GET ARGS
1035 PUSHJ P,ITYPQ ; GO INTERNAL
1039 ITYPQ: GETYP A,A ; OBJECT
1041 TYPEQ0: SOJL C,CIFALS
1043 CAIE 0,TATOM ; Type name must be an atom
1045 CAMN B,1(D) ; Same as the OBJECT?
1046 JRST CPOPJ1 ; Yes, return type name
1048 JRST TYPEQ0 ; No, continue comparing
1054 CTYPEQ: SOJE A,CIFALS ; TREAT NO ARGS AS FALSE
1055 MOVEI D,1(A) ; FIND BASE OF ARGS
1058 SUBM TP,D ; D POINTS TO BASE
1059 MOVE E,D ; SAVE FOR TP RESTORE
1060 ADD D,[3,,3] ; FUDGE
1061 MOVEI C,(A) ; NUMBER OF TYPES
1064 JFCL ; IGNORE SKIP FOR NOW
1065 MOVE TP,E ; SET TP BACK
1066 JUMPL B,CPOPJ1 ; SKIP
1069 ; Entries to get type codes for types for fixing up RSUBRs and assembling
1071 MFUNCTION %TYPEC,SUBR,[TYPE-C]
1080 CAMGE AB,[-3,,0] ; skip if only type name given
1084 TYPEC1: PUSHJ P,CTYPEC ; go to internal
1087 GTPTYP: CAMGE AB,[-5,,0]
1095 CTYPEC: PUSH P,C ; save primtype checker
1096 PUSHJ P,TYPFND ; search type vector
1097 JRST CTPEC2 ; create the poor loser
1101 CAMN B,IMQUOTE TEMPLATE
1117 TCHK: PUSH P,D ; SAVE TYPE
1118 MOVE A,D ; GO TO SAT
1120 CAIG A,NUMSAT ; SKIP IF A TEMPLATE
1122 POP P,D ; RESTORE TYPE
1125 CTPEC2: POP P,C ; GET BACK PRIMTYPE
1133 MCALL 2,NEWTYPE ; CREATE THE POOR GUY
1135 SUBM M,(P) ; UNRELATIVIZE
1138 CTPEC3: HRRZ 0,FSAV(TB)
1146 MFUNCTION %TYPEW,SUBR,[TYPE-W]
1160 CTYPW3: PUSHJ P,CTYPEW
1163 CTYPW1: GETYP 0,2(AB)
1166 CAMGE AB,[-5,,0] ; JUMP IF RH IS GIVEN
1168 CTYPW5: MOVE C,3(AB)
1171 CTYPW2: CAMGE AB,[-7,,0]
1180 PUSHJ P,CTYPEC ; GET CODE IN B
1186 MFUNCTION %VTYPE,SUBR,[VALID-TYPE?]
1199 CVTYPE: PUSHJ P,TYPFND ; LOOK IT UP
1210 ;PRIMTTYPE RETURNS THE TYPE ATOM OF A PRIMITIVE TYPE IN A CLASS
1212 STBL: REPEAT NUMSAT,SETZ MQUOTE INTERNAL-TYPE
1216 IRP A,,[[1WORD,WORD],[2WORD,LIST],[NWORD,UVECTOR],[2NWORD,VECTOR],[STORE,STORAGE]
1217 [ARGS,TUPLE],[FRAME,FRAME],[ATOM,ATOM],[LOCID,LOCD],[CHSTR,STRING],[OFFS,OFFSET,1]
1218 [PVP,PROCESS,1],[ASOC,ASOC,1],[LOCA,LOCA],[LOCS,LOCS],[LOCU,LOCU],[LOCV,LOCV]
1219 [LOCL,LOCL],[LOCN,LOCAS],[LOCT,LOCT,1],[LOCR,LOCR],[LOCB,LOCB,1],[BYTE,BYTES,1]]
1223 IFSE [Y],SETZ IMQUOTE X
1224 IFSN [Y],SETZ MQUOTE X
1235 MFUNCTION TYPEPRIM,SUBR
1245 CTYPEP: PUSHJ P,TYPLOO ; CONVERT ATOM TO CODE
1246 HRRZ A,(A) ; SAT TO A
1250 MFUNCTION PTSATC,SUBR,[PRIMTYPE-C]
1261 CPRTYC: PUSHJ P,TYPLOO
1268 IMFUNCTION PRIMTYPE,SUBR
1272 MOVE A,(AB) ;GET TYPE
1277 PUSHJ P,SAT ;GET SAT
1278 PTYP1: JUMPE A,TYPERR
1279 MOVE B,IMQUOTE TEMPLATE
1280 CAIG A,NUMSAT ; IF BIG SAT, THEN TEMPLATE
1286 ; RSUBR MAKES A VECTOR INTO AN OBJECT OF TYPE RSUBR, ALSO SLIGHTLY MUNGING IT
1288 IMFUNCTION RSUBR,SUBR
1292 CAIE A,TVEC ; MUST BE VECTOR
1294 MOVE B,1(AB) ; GET IT
1295 GETYP A,(B) ; CHECK 1ST ELEMENTS TYPE
1296 CAIN A,TPCODE ; PURE CODE
1300 HLRM B,(B) ; CLOBEER SPECIAL COUNT FIELD
1304 NRSUBR: ERRUUO EQUOTE FIRST-ELEMENT-OF-VECTOR-NOT-CODE
1306 ; ROUTINE TO GENERATE ENTRYY OTHER THAN FIRST TO RSUBRR
1308 IMFUNCTION MENTRY,SUBR,[RSUBR-ENTRY]
1312 GETYP 0,(AB) ; TYPE OF ARG
1313 CAIE 0,TVEC ; BETTER BE VECTOR
1318 MOVE B,1(AB) ; GET VECTOR
1321 GETYP 0,(B) ; FIRST ELEMENT
1324 MENTR2: GETYP 0,2(B)
1328 HRRM C,2(B) ; OFFSET INTO VECTOR
1333 MENTR1: CAIE 0,TATOM
1335 MOVE B,1(B) ; GET ATOM
1336 PUSHJ P,IGVAL ; GET VAL
1340 MOVE C,1(AB) ; RESTORE B
1346 BENTRY: ERRUUO EQUOTE BAD-VECTOR
1348 ; SUBR TO GET ENTRIES OFFSET
1350 MFUNCTION LENTRY,SUBR,[ENTRY-LOC]
1364 RTFALS: MOVSI A,TFALSE
1368 ;SUBROUTINE CALL FOR RSUBRs
1369 RCALL: SUBM M,(P) ;CALCULATE PC's OFFSET IN THE RSUBR
1370 HRLI 0,400000 ; DONT LOSE IN MULTI SEG MODE
1372 PUSHJ P,@0 ;GO TO THE PROPER SUBROUTINE
1373 SUBM M,(P) ;RECONSTITUTE THE RSUBR's PC
1378 ;CHTYPE TAKES TWO ARGUMENTS. ANY GOODIE AND A AN ATOMIC TYPE NAME
1379 ;IT CHECKS THE STORAGE ALLOCATION TYPES OF THE TWO ARE THE SAME AND
1380 ;IF THEY ARE CHANGES THE TYPE OF THE FIRST TO THAT NAME D IN THE SECOND
1382 MFUNCTION CHTYPE,SUBR
1385 GETYP A,2(AB) ;FIRST CHECK THAT ARG 2 IS AN ATOM
1388 MOVE B,3(AB) ;AND TYPE NAME
1389 PUSHJ P,TYPLOO ;GO LOOKUP TYPE
1390 TFOUND: HRRZ B,(A) ;GOBBLE THE SAT
1391 TRNE B,CHBIT ; SKIP IF CHTYPABLE
1393 TRNE B,TMPLBT ; TEMPLAT
1396 GETYP A,(AB) ;NOW GET TYPE TO HACK
1397 PUSHJ P,SAT ;FIND OUT ITS SAT
1398 JUMPE A,TYPERR ;COMPLAIN
1400 JRST CHTMPL ; JUMP IF TEMPLATE DATA
1401 CAIE A,(B) ;DO THEY AGREE?
1402 JRST TYPDIF ;NO, COMPLAIN
1403 CHTMP1: MOVSI A,(D) ;GET NEW TYPE
1404 HRR A,(AB) ; FOR DEFERRED GOODIES
1405 JUMPL B,CHMATC ; CHECK IT
1406 MOVE B,1(AB) ;AND VALUE
1409 CHTMPL: MOVE E,1(AB) ; GET ARG
1412 MOVE 0,3(AB) ; SEE IF TO "TEMPLATE"
1413 CAMN 0,IMQUOTE TEMPLATE
1415 TLNN E,-1 ; SKIP IF RESTED
1421 PUSH TP,1(AB) ; SAVE GOODIE
1426 PUSHJ P,IGET ; FIND THE DECL
1430 MOVE D,1(AB) ; NOW GGO TO MATCH
1446 TYPLOO: PUSHJ P,TYPFND
1447 ERRUUO EQUOTE BAD-TYPE-NAME
1450 TYPFND: HLRE A,B ; FIND DOPE WORDS
1451 SUBM B,A ; A POINTS TO IT
1452 HRRE D,(A) ; TYPE-CODE TO D
1454 ANDI D,TYPMSK ; FLUSH FUNNY BITS
1464 MOVE A,TYPVEC+1 ;GOBBLE DOWN TYPE VECTOR
1465 MOVEI D,0 ;INITIALIZE TYPE COUNTER
1466 TLOOK: CAMN B,1(A) ;CHECK THIS ONE
1468 ADDI D,1 ;BUMP COUNTER
1469 AOBJP A,.+2 ;COUTN DOWN ON VECTOR
1476 TYPDIF: ERRUUO EQUOTE STORAGE-TYPES-DIFFER
1479 TMPLVI: ERRUUO EQUOTE DECL-VIOLATION
1482 ; FUNCTION TO ADD A NEW TYPE TO THE WORLD WITH GIVEN PRIMITIVE TYPE
1484 MFUNCTION NEWTYPE,SUBR
1488 HLRZ 0,AB ; CHEC # OF ARGS
1489 CAILE 0,-4 ; AT LEAST 2
1492 JRST TMA ; NOT MORE THAN 3
1493 GETYP A,(AB) ; GET 1ST ARGS TYPE (SHOULD BE ATOM)
1494 GETYP C,2(AB) ; SAME WITH SECOND
1495 CAIN A,TATOM ; CHECK
1499 MOVE B,3(AB) ; GET PRIM TYPE NAME
1500 PUSHJ P,TYPLOO ; LOOK IT UP
1501 HRRZ A,(A) ; GOBBLE SAT
1503 HRLI A,TATOM ; MAKE NEW TYPE
1505 MOVE B,1(AB) ; SEE IF PREV EXISTED
1507 JRST NEWTOK ; DID NOT EXIST BEFORE
1508 MOVEI B,2(A) ; FOR POSSIBLE TMPLAT BIT
1509 HRRZ A,(A) ; GET SAT
1510 HRRZ 0,(P) ; AND PROPOSED
1513 CAIN 0,(A) ; SKIP IF LOSER
1516 ERRUUO EQUOTE TYPE-ALREADY-EXISTS
1519 MOVE B,1(AB) ; NEWTYPE NAME
1520 PUSHJ P,INSNT ; MUNG IN NEW TYPE
1522 NEWTFN: CAML AB,[-5,,] ; SKIP IF TEMPLAT SUPPLIED
1524 MOVEI 0,TMPLBT ; GET THE BIT
1525 IORM 0,-2(B) ; INTO WORD
1526 MOVE A,(AB) ; GET TYPE NAME
1530 PUSH TP,4(AB) ; GET TEMLAT
1534 MOVE B,1(AB) ; RETURN NAME
1537 ; SET UP GROWTH FIELDS
1539 IGROWT: SKIPA A,[111100,,(C)]
1540 IGROWB: MOVE A,[001100,,(C)]
1542 SUB C,B ; POINT TO DOPE WORD
1543 MOVE B,TYPIC ; INDICATED GROW BLOCK
1548 PUSH TP,B ; SAVE NAME OF NEWTYPE
1549 MOVE C,TYPBOT+1 ; CHECK GROWTH NEED
1551 JRST ADDIT ; STILL ROOM
1552 GAGN: PUSHJ P,IGROWB ; SETUP BOTTOM GROWTH
1554 PUSHJ P,IGROWT ; SET UP TOP GROWTH
1559 MOVE C,[11.,,5] ; SET UP INDICATOR FOR AGC
1560 PUSHJ P,AGC ; GROW THE WORLD
1561 AOJL A,GAGN ; BAD AGC LOSSAGE
1563 ADDM 0,TYPBOT+1 ; FIX UP POINTER
1565 ADDIT: MOVE C,TYPVEC+1
1566 SUB C,[2,,2] ; ALLOCATE ROOM
1568 HLRE B,C ; PREPARE TO BLT
1569 SUBM C,B ; C POINTS DOPE WORD END
1570 HRLI C,2(C) ; GET BLT AC READY
1572 POP TP,-1(B) ; CLOBBER IT IN
1574 HLRE C,TYPVEC+1 ; GET CODE
1578 MOVE D,-1(B) ; B HAS POINTER TO TYPE VECTOR DOPE WORDS
1580 CAIG 0,HIBOT ; IS ATOM PURE?
1581 JRST ADDNOI ; NO, SO NO HACKING REQUIRED
1584 PUSHJ P,IMPURIF ; DO IMPURE OF ATOM
1587 SUBM C,B ; RESTORE B
1589 MOVE D,-1(B) ; RESTORE D
1593 HRRM C,(A) ; INTO "GROWTH" FIELD
1597 ; Interface to interpreter for setting up tables associated with
1598 ; template data structures.
1599 ; A/ <
\b-name of type>
\b-
1600 ; B/ <
\b-length ins>
\b-
1601 ; C/ <
\b-uvector of garbage collector code or 0>
1602 ; D/ <
\b-uvector of GETTERs>
\b-
1603 ; E/ <
\b-uvector of PUTTERs>
\b-
1605 CTMPLT: SUBM M,(P) ; could possibly gc during this stuff
1606 PUSH TP,$TATOM ; save name of type
1608 PUSH P,B ; save length instr
1609 HLRE A,TD.LNT+1 ; check for template slots left?
1611 SUB B,A ; point to dope words
1612 HLRZ B,1(B) ; get real length
1614 JUMPG A,GOODRM ; jump if ok
1616 PUSH TP,$TUVEC ; save getters and putters
1618 PUSH TP,$TUVEC ; save getters and putters
1622 MOVEI A,10-2(B) ; grow it 10 by copying remember d.w. length
1623 PUSH P,A ; save new length
1624 PUSHJ P,CAFRE1 ; get frozen uvector
1625 ADD B,[10,,10] ; rest it down some
1626 HRL C,TD.LNT+1 ; prepare to BLT in
1627 MOVEM B,TD.LNT+1 ; and save as new length vector
1628 HRRI C,(B) ; destination
1629 ADD B,(P) ; final destination address
1631 MOVE A,(P) ; length for new getters
1633 HRL C,TD.GET+1 ; get old for copy
1635 PUSHJ P,DOBLTS ; go fixup new uvector
1636 MOVE A,(P) ; finally putters
1640 PUSHJ P,DOBLTS ; go fixup new uvector
1641 MOVE A,(P) ; finally putters
1645 PUSHJ P,DOBLTS ; go fixup new uvector
1646 SUB P,[1,,1] ; flush stack craft
1649 MOVE C,-4(TP) ;GET TD.AGC
1652 GOODRM: MOVE B,TD.LNT+1 ; move down to fit new guy
1653 SUB B,[1,,1] ; will always win due to prev checks
1658 ADDI A,-1(B) ; A/ final destination
1660 POP P,(A) ; new length ins munged in
1662 MOVNS A ; A/ offset for other guys
1664 ADD A,TD.GET+1 ; point for storing uvs of ins
1668 MOVEM E,-1(A) ; store putter also
1671 MOVEM C,-1(A) ; store putter also
1672 POP P,A ; compute primtype
1675 MOVE B,(TP) ; ready to mung type vector
1677 PUSHJ P,TYPFND ; CHECK TO SEE WHETHER TEMPLATE EXISTS
1682 NOTEM: POP P,A ; RESTORE SAT
1683 HRLI A,TATOM ; GET TYPE
1684 PUSHJ P,INSNT ; INSERT INTO VECTOR
1687 ; this routine copies GET and PUT vectors into new ones
1691 BLT C,-11(B) ; zap those guys in
1692 MOVEI A,TUVEC ; mung in uniform type
1694 MOVEI C,-7(B) ; zero out remainder of uvector
1701 ; FUNCTIONS TO SET UP EVALUATION AND APPLICATION RULES FOR DATA TYPES
1703 MFUNCTION EVALTYPE,SUBR
1707 PUSHJ P,CHKARG ; VERIFY WINNAGE IN ARGS
1708 MOVEI A,EVATYP ; POINT TO TABLE
1709 MOVEI E,EVTYPE ; POINT TO PURE VERSION
1711 TBLCAL: PUSHJ P,TBLSET ; SETUP TABLE ENTRY
1714 MFUNCTION APPLYTYPE,SUBR
1719 MOVEI A,APLTYP ; POINT TO APPLY TABLE
1720 MOVEI E,APTYPE ; PURE TABLE
1725 MFUNCTION PRINTTYPE,SUBR
1730 MOVEI A,PRNTYP ; POINT TO APPLY TABLE
1731 MOVEI E,PRTYPE ; PURE TABLE
1735 ; CHECK ARGS AND SETUP FOR TABLE HACKER
1737 CHKARG: JUMPGE AB,TFA
1740 GETYP A,(AB) ; 1ST MUST BE TYPE NAME
1743 MOVE B,1(AB) ; GET ATOM
1744 PUSHJ P,TYPLOO ; VERIFY THAT IT IS A TYPE
1745 PUSH P,D ; SAVE TYPE NO.
1746 MOVEI D,-1 ; INDICATE FUNNYNESS
1747 CAML AB,[-3,,] ; SKIP IF 2 OR MORE
1749 HRRZ A,(A) ; GET SAT
1752 GETYP A,2(AB) ; GET 2D TYPE
1753 CAIE A,TATOM ; EITHER TYPE OR APPLICABLE
1754 JRST TRYAPL ; TRY APPLICABLE
1755 MOVE B,3(AB) ; VERIFY IT IS A TYPE
1757 HRRZ A,(A) ; GET SAT
1759 POP P,C ; RESTORE SAVED SAT
1760 CAIE A,(C) ; SKIP IF A WINNER
1761 JRST TYPDIF ; REPORT ERROR
1762 TY1AR: POP P,C ; GET SAVED TYPE
1763 MOVEI B,0 ; TELL THAT WE ARE A TYPE
1766 TRYAPL: PUSHJ P,APLQ ; IS THIS APPLICABLE
1769 MOVE B,2(AB) ; RETURN SAME
1775 ; HERE TO PUT ENTRY IN APPROPRIATE TABLE
1778 PUSH TP,D ; SAVE VALUE
1781 PUSH P,C ; SAVE TYPE BEING HACKED
1783 SKIPE B,1(A) ; SKIP IF VECTOR DOESN'T EXIST YET
1785 MOVE B,-2(TP) ; CHECK FOR RETURN IT HACK
1790 HLRE A,TYPBOT+1 ; GET CURRENT TABLE LNTH
1794 PUSHJ P,IVECT ; GET VECTOR
1796 MOVE C,(TP) ; POINT TO RETURN POINT
1797 MOVEM B,1(C) ; SAVE VECTOR
1800 POP P,C ; RESTORE TYPE
1804 JUMPN A,TBLOK1 ; JUMP IF FUNCTION ETC. SUPPLIED
1807 CAILE D,NUMPRI ; SKIP IF ORIGINAL TYPE
1808 MOVNI E,(D) ; CAUSE E TO ENDUP 0
1809 ADDI E,(D) ; POINT TO PURE SLOT
1810 TBLOK1: ADDI C,(C) ; POINT TO VECTOR SLOT
1814 JUMPN A,OK.SET ; OK TO CLOBBER
1815 ADDI B,(D) ; POINT TO TARGET TYPE'S SLOT
1816 ADDI B,(D) ; POINT TO TARGET TYPE'S SLOT
1817 SKIPN A,(B) ; SKIP IF WINNER
1818 SKIPE 1(B) ; SKIP IF LOSER
1819 SKIPA D,1(B) ; SETUP D
1820 JRST CH.PTB ; CHECK PURE TABLE
1822 OK.SET: CAIN 0,(D) ; SKIP ON RESET
1826 RETAR1: MOVE A,(AB) ; RET TYPE
1836 RETPM2: SUB TP,[4,,4]
1854 RETPM3: ADD A,TYPVEC+1
1859 RETPRM: SUBI C,(B) ; UNDO BADNESS
1860 RETPM4: CAIG C,NUMPRI*2
1867 CALLTY: MOVE A,TYPVEC
1871 MFUNCTION ALLTYPES,SUBR
1881 ;FUNCTION TO RETURN TYPE OF ELEMENTS IN A UVECTOR
1883 MFUNCTION UTYPE,SUBR
1887 GETYP A,(AB) ;GET U VECTOR
1891 MOVE B,1(AB) ; GET UVECTOR
1895 CUTYPE: HLRE A,B ;GET -LENGTH
1897 SUB B,A ;POINT TO TYPE WORD
1899 JRST ITYPE ; GET NAME OF TYPE
1901 ; FUNCTION TO CHANGE UNIFORM TYPE OF A VECTOR
1903 MFUNCTION CHUTYPE,SUBR
1907 GETYP A,2(AB) ;GET 2D TYPE
1910 GETYP A,(AB) ; CALL WITH UVECTOR?
1914 MOVE A,1(AB) ; GET UV POINTER
1915 MOVE B,3(AB) ;GET ATOM
1917 MOVE A,(AB) ; RETURN UVECTOR
1921 CCHUTY: PUSH TP,$TUVEC
1923 PUSHJ P,TYPLOO ;LOOK IT UP
1930 HLRE C,(TP) ;-LENGTH
1932 SUB E,C ;POINT TO TYPE
1933 GETYP A,(E) ;GET TYPE
1934 JUMPE A,WIN0 ;ALLOW TYPE "LOSE" TO CHANGE TO ANYTHING
1935 PUSHJ P,SAT ;GET SAT
1940 HRLM D,(E) ;CLOBBER NEW ONE
1945 CANTCH: PUSH TP,$TATOM
1946 PUSH TP,EQUOTE CANT-CHTYPE-INTO
1954 PUSH TP,EQUOTE NON-ATOMIC-ARGUMENT
1962 ; SUBROUTINE TO LEAVE MUDDLE CLOSING ALL CHANNELS ON THE WAY
1969 PUSHJ P,CLOSAL ; DO THE CLOSES
1971 JRST IFALSE ; JUST IN CASE
1973 CLOSAL: MOVEI B,CHNL0+2 ; POINT TO 1ST (NOT INCLUDING TTY I/O)
1975 MOVE TVP,REALTV+1(PVP)
1981 PUSH P,[N.CHNS-1] ; MAX NO. OF CHANS
1987 SKIPN C,-1(B) ; THIS ONE OPEN?
1992 PUSH TP,-2(B) ; PUSH IT
1994 MCALL 1,FCLOSE ; CLOSE IT
1995 CLOSA4: SOSLE (P) ; COUNT DOWN
2002 CLOSA3: SKIPN B,CHNL0+1
2015 WHOAMI: 0 ; SYAYS WHETHER I AM REALLY A MUDDLE OR SOME HACK
2018 ;GARBAGE COLLECTORS PDLS
2021 GCPDL: -GCPLNT,,GCPDL
2028 MUDSTR: ASCII /MUDDLE
\7f\7f\7f/
2032 ASCIZ / IN OPERATION./
2034 ;MARKED PDLS FOR GC PROCESS
2037 ; DUMMY FRAME FOR INITIALIZER CALLS
2047 TPBAS: BLOCK ITPLNT+PDLBUF
2049 ITPLNT+2+PDLBUF+7,,0