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
697 REHANG: MOVE A,[PUSHJ P,CHKPRH]
698 MOVEM A,ONINT ; CHECK PREDICATE AFTER ANY INTERRUPT
701 HANG1: ENABLE ;LET OURSELVES BE INTERRUPTED OUT
703 DISABLE ;PREVENT INTERRUPTS AT RANDOM TIMES
710 ; ROUTINE TO SLEEP FOR POSITIVE NUMBER OF SECONDS WITH INTERRUPTS ENABLED
711 ; ARGUMENT SHOULD BE OF TYPE FIX OR FLOAT AND NON-NEGATIVE
728 JUMPL B,OUTRNG ;ARG SHOULDNT BE NEGATIVE
729 IMULI B,30. ;CONVERT TO # OF THIRTIETHS OF A SECOND
730 JRST SLEEPR ;GO SLEEP
731 CAIE 0,TFLOAT ;IF IT WASNT FIX MAKE SURE IT IS FLOAT
732 JRST WTYP1 ;WRONG TYPE ARG
734 FMPR B,[30.0] ;CONVERT TO FLOATING # OF THIRTIETHS OF A SECOND
735 MULI B,400 ;KLUDGE TO FIX IT
738 MOVE B,C ;MOVE THE FIXED NUMBER INTO B
739 JUMPL B,OUTRNG ;CHECK TO SEE THAT WE HAVE POSITIVE NUMBER
741 RESLEE: MOVE B,[PUSHJ P,CHKPRS]
759 SETZM ONINT ; TURN OFF FEATURE FOR NOW
763 HANGP: SKIPA B,[REHANG]
764 SLEEPP: MOVEI B,RESLEE
777 MFUNCTION VALRET,SUBR
778 ; SUBR TO VALRET A STRING TO SUPERIOR ITS PROCESS
781 GETYP A,(AB) ; GET TYPE OF ARGUMENT
784 CAIE A,TCHSTR ; IS IT A CHR STRING?
785 JRST WTYP1 ; NO...ERROR WRONG TYPE
786 PUSHJ P,CSTACK ; COPY THE CHR STRING TO THE STACK
787 ; CSTACK IS IN ATOMHK
788 MOVEI B,0 ; ASCIZ TERMINATOR
789 EXCH B,(P) ; STORE AND RETRIEVE COUNT
791 ; CALCULATE THE BEGINNING ADDR OF THE STRING
792 MOVEI A,-1(P) ; GET ADDR OF TOP OF STACK
793 SUBI A,-1(B) ; GET STARTING ADDR
794 PUSHJ P,%VALRE ; PASS UP TO MONITOR
795 JRST IFALSE ; IF HE RETURNS, RETURN FALSE
801 MFUNCTION LOGOUT,SUBR
803 ; SUBR TO DO A .LOGOUT (VALID ONLY AT TOP LEVEL)
805 PUSHJ P,%TOPLQ ; SKIP IF AT TOP LEVEL
808 PUSHJ P,%LOGOUT ; TRY TO FLUSH
809 JRST IFALSE ; COULDN'T DO IT...RETURN FALSE
811 ; FUNCTS TO GET UNAME AND JNAME
813 ; GET XUNAME (REAL UNAME)
814 MFUNCTION XUNAME,SUBR
820 JRST FINIS ; 10X ROUTINES SKIP
831 MFUNCTION XJNAME,SUBR
845 ; FUNCTION TO SET AND READ GLOBAL SNAME
854 GETYP A,(AB) ; ARG MUST BE STRING
864 SNAME1: MOVE B,IMQUOTE SNM
873 RSUJNM: PUSHJ P,6TOCHS ; CONVERT IT
877 SGSNAM: MOVE B,IMQUOTE SNM
891 PUSHJ P,%SSNAM ; SET SNAME IN SYSTEM
896 ;THIS SUBROUTINE ALLOCATES A NEW PROCESS
897 ;TAKES TP-STACK SIZE (2*WORDS) IN A AND P-STACK SIZE (WORDS) IN B
898 ;IS CALLED BY PUSHJ P,. RETURNS IN A AND B A NEW PROCESS.
902 MOVEI A,PVLNT ;SETUP CALL TO VECTOR FOR PVP
903 PUSHJ P,IVECT ;GOBBLE A VECTOR
904 HRLI C,PVBASE ;SETUP A BLT POINTER
905 HRRI C,(B) ;GET INTO ADDRESS
906 BLT C,PVLNT*2-1(B) ;COPY A PROTOTYPE INTO NEW PVP
907 MOVSI C,400000+SPVP+.VECT. ;SET SPECIAL TYPE
908 MOVEM C,PVLNT*2(B) ;CLOBBER IT IN
909 PUSH TP,A ;SAVE THE RESULTS OF VECTOR
912 PUSH TP,$TFIX ;GET A UNIFORM VECTOR
916 ADD B,[PDLBUF-2,,-1] ;FUDGE WITH BUFFER
917 MOVE C,(TP) ;REGOBBLE PROCESS POINTER
918 MOVEM B,PSTO+1(C) ;STORE IN ALL HOMES
922 POP P,A ;PREPARE TO CREATE A TEMPORARY PDL
923 PUSHJ P,IVECT ;GET THE TEMP PDL
924 ADD B,[PDLBUF,,0] ;PDL GROWTH HACK
925 MOVE C,(TP) ;RE-GOBBLE NEW PVP
926 SUB B,[1,,1] ;FIX FOR STACK
929 ;SETUP INITIAL BINDING
932 MOVEM B,SPBASE+1(C) ;SAVE AS BASE OF SP
933 MOVEM B,SPSTO+1(C) ;AND CURRENT THEREOF
934 MOVEM B,CURFCN+1(C) ; AND AS CURRENT FCN FOR SPEC/UNSPEC LOGIC
935 PUSH B,IMQUOTE THIS-PROCESS
936 PUSH B,$TPVP ;GIVE IT PROCESS AS VALUE
938 ADD B,[2,,2] ;FINISH FRAME
939 MOVEM B,TPSTO+1(C) ;MAKE THIS THE CURRENT STACK POINTER
940 MOVEM C,PVPSTO+1(C) ;SAVE THE NEW PVP ITSELF
941 AOS A,IDPROC ;GOBBLE A UNIQUE PROCESS I.D.
942 MOVEM A,PROCID+1(C) ;SAVE THAT ALSO
943 AOS A,PTIME ; GET A UNIQUE BINDING ID
946 MOVSI A,TPVP ;CLOBBER THE TYPE
947 MOVE B,(TP) ;AND POINTER TO PROCESS
951 ;MINI ROUTINE TO CALL VECTOR WITH COUNT IN A
955 MCALL 1,VECTOR ;GOBBLE THE VECTOR
959 ;SUBROUTINE TO SWAP A PROCESS IN
960 ;CALLED WITH JSP A,SWAP AND NEW PVP IN B
962 SWAP: ;FIRST STORE ALL THE ACS
965 MOVE SP,$TSP ; STORE SPSAVE
968 IRP A,,[SP,AB,TB,TP,P,M,R,FRM]
972 SETOM 1(TP) ; FENCE POST MAIN STACK
973 MOVEM TP,TPSAV(TB) ; CORRECT FRAME
974 SETZM PSAV(TB) ; CLEAN UP CURRENT FRAME
978 MOVE E,PVP ;RETURN OLD PROCESS IN E
979 MOVE PVP,D ;AND MAKE NEW ONE BE D
983 ;NOW RESTORE NEW PROCESSES AC'S
986 IRP A,,[AB,TB,SP,TP,P,M,R,FRM]
997 ;SUBRS ASSOCIATED WITH TYPES
999 ;TYPE (ITYPE) ARE FUNCTIONS TO RETURN THE ATOMIC NAME OF THE
1000 ;TYPE OF A GOODIE. TYPE TAKES ITS ARGS ON AP AND RETURNS IN A AND B.
1001 ;ITYPE TAKES ITS ARGS IN A AND B AND RETURNS IN SAME (B=0) FOR INVALID
1006 GETYP A,(AB) ;TYPE INTO A
1007 TYPE1: PUSHJ P,ITYPE ;GO TO INTERNAL
1008 JUMPN B,FINIS ;GOOD RETURN
1009 TYPERR: ERRUUO EQUOTE TYPE-UNDEFINED
1011 CITYPE: GETYP A,A ; GET TYPE FOR COMPILER CALL
1012 ITYPE: LSH A,1 ;TIMES 2
1013 HRLS A ;TO BOTH SIDES
1014 ADD A,TYPVEC+1 ;GET ACTUAL LOCATION
1015 JUMPGE A,TYPERR ;LOST, TYPE OUT OF BOUNDS
1016 MOVE B,1(A) ;PICKUP TYPE
1020 ; PREDICATE -- IS OBJECT OF TYPE SPECIFIED
1022 MFUNCTION %TYPEQ,SUBR,[TYPE?]
1026 MOVE D,AB ; GET ARGS
1033 PUSHJ P,ITYPQ ; GO INTERNAL
1037 ITYPQ: GETYP A,A ; OBJECT
1039 TYPEQ0: SOJL C,CIFALS
1041 CAIE 0,TATOM ; Type name must be an atom
1043 CAMN B,1(D) ; Same as the OBJECT?
1044 JRST CPOPJ1 ; Yes, return type name
1046 JRST TYPEQ0 ; No, continue comparing
1052 CTYPEQ: SOJE A,CIFALS ; TREAT NO ARGS AS FALSE
1053 MOVEI D,1(A) ; FIND BASE OF ARGS
1056 SUBM TP,D ; D POINTS TO BASE
1057 MOVE E,D ; SAVE FOR TP RESTORE
1058 ADD D,[3,,3] ; FUDGE
1059 MOVEI C,(A) ; NUMBER OF TYPES
1062 JFCL ; IGNORE SKIP FOR NOW
1063 MOVE TP,E ; SET TP BACK
1064 JUMPL B,CPOPJ1 ; SKIP
1067 ; Entries to get type codes for types for fixing up RSUBRs and assembling
1069 MFUNCTION %TYPEC,SUBR,[TYPE-C]
1078 CAMGE AB,[-3,,0] ; skip if only type name given
1082 TYPEC1: PUSHJ P,CTYPEC ; go to internal
1085 GTPTYP: CAMGE AB,[-5,,0]
1093 CTYPEC: PUSH P,C ; save primtype checker
1094 PUSHJ P,TYPFND ; search type vector
1095 JRST CTPEC2 ; create the poor loser
1099 CAMN B,IMQUOTE TEMPLATE
1115 TCHK: PUSH P,D ; SAVE TYPE
1116 MOVE A,D ; GO TO SAT
1118 CAIG A,NUMSAT ; SKIP IF A TEMPLATE
1120 POP P,D ; RESTORE TYPE
1123 CTPEC2: POP P,C ; GET BACK PRIMTYPE
1131 MCALL 2,NEWTYPE ; CREATE THE POOR GUY
1133 SUBM M,(P) ; UNRELATIVIZE
1136 CTPEC3: HRRZ 0,FSAV(TB)
1144 MFUNCTION %TYPEW,SUBR,[TYPE-W]
1158 CTYPW3: PUSHJ P,CTYPEW
1161 CTYPW1: GETYP 0,2(AB)
1164 CAMGE AB,[-5,,0] ; JUMP IF RH IS GIVEN
1166 CTYPW5: MOVE C,3(AB)
1169 CTYPW2: CAMGE AB,[-7,,0]
1178 PUSHJ P,CTYPEC ; GET CODE IN B
1184 MFUNCTION %VTYPE,SUBR,[VALID-TYPE?]
1197 CVTYPE: PUSHJ P,TYPFND ; LOOK IT UP
1208 ;PRIMTTYPE RETURNS THE TYPE ATOM OF A PRIMITIVE TYPE IN A CLASS
1210 STBL: REPEAT NUMSAT,SETZ MQUOTE INTERNAL-TYPE
1214 IRP A,,[[1WORD,WORD],[2WORD,LIST],[NWORD,UVECTOR],[2NWORD,VECTOR],[STORE,STORAGE]
1215 [ARGS,TUPLE],[FRAME,FRAME],[ATOM,ATOM],[LOCID,LOCD],[CHSTR,STRING],[OFFS,OFFSET,1]
1216 [PVP,PROCESS,1],[ASOC,ASOC,1],[LOCA,LOCA],[LOCS,LOCS],[LOCU,LOCU],[LOCV,LOCV]
1217 [LOCL,LOCL],[LOCN,LOCAS],[LOCT,LOCT,1],[LOCR,LOCR],[LOCB,LOCB,1],[BYTE,BYTES,1]]
1221 IFSE [Y],SETZ IMQUOTE X
1222 IFSN [Y],SETZ MQUOTE X
1233 MFUNCTION TYPEPRIM,SUBR
1243 CTYPEP: PUSHJ P,TYPLOO ; CONVERT ATOM TO CODE
1244 HRRZ A,(A) ; SAT TO A
1248 MFUNCTION PTSATC,SUBR,[PRIMTYPE-C]
1259 CPRTYC: PUSHJ P,TYPLOO
1266 IMFUNCTION PRIMTYPE,SUBR
1270 MOVE A,(AB) ;GET TYPE
1275 PUSHJ P,SAT ;GET SAT
1276 PTYP1: JUMPE A,TYPERR
1277 MOVE B,IMQUOTE TEMPLATE
1278 CAIG A,NUMSAT ; IF BIG SAT, THEN TEMPLATE
1284 ; RSUBR MAKES A VECTOR INTO AN OBJECT OF TYPE RSUBR, ALSO SLIGHTLY MUNGING IT
1286 IMFUNCTION RSUBR,SUBR
1290 CAIE A,TVEC ; MUST BE VECTOR
1292 MOVE B,1(AB) ; GET IT
1293 GETYP A,(B) ; CHECK 1ST ELEMENTS TYPE
1294 CAIN A,TPCODE ; PURE CODE
1298 HLRM B,(B) ; CLOBEER SPECIAL COUNT FIELD
1302 NRSUBR: ERRUUO EQUOTE FIRST-ELEMENT-OF-VECTOR-NOT-CODE
1304 ; ROUTINE TO GENERATE ENTRYY OTHER THAN FIRST TO RSUBRR
1306 IMFUNCTION MENTRY,SUBR,[RSUBR-ENTRY]
1310 GETYP 0,(AB) ; TYPE OF ARG
1311 CAIE 0,TVEC ; BETTER BE VECTOR
1316 MOVE B,1(AB) ; GET VECTOR
1319 GETYP 0,(B) ; FIRST ELEMENT
1322 MENTR2: GETYP 0,2(B)
1326 HRRM C,2(B) ; OFFSET INTO VECTOR
1331 MENTR1: CAIE 0,TATOM
1333 MOVE B,1(B) ; GET ATOM
1334 PUSHJ P,IGVAL ; GET VAL
1338 MOVE C,1(AB) ; RESTORE B
1344 BENTRY: ERRUUO EQUOTE BAD-VECTOR
1346 ; SUBR TO GET ENTRIES OFFSET
1348 MFUNCTION LENTRY,SUBR,[ENTRY-LOC]
1362 RTFALS: MOVSI A,TFALSE
1366 ;SUBROUTINE CALL FOR RSUBRs
1367 RCALL: SUBM M,(P) ;CALCULATE PC's OFFSET IN THE RSUBR
1368 HRLI 0,400000 ; DONT LOSE IN MULTI SEG MODE
1370 PUSHJ P,@0 ;GO TO THE PROPER SUBROUTINE
1371 SUBM M,(P) ;RECONSTITUTE THE RSUBR's PC
1376 ;CHTYPE TAKES TWO ARGUMENTS. ANY GOODIE AND A AN ATOMIC TYPE NAME
1377 ;IT CHECKS THE STORAGE ALLOCATION TYPES OF THE TWO ARE THE SAME AND
1378 ;IF THEY ARE CHANGES THE TYPE OF THE FIRST TO THAT NAME D IN THE SECOND
1380 MFUNCTION CHTYPE,SUBR
1383 GETYP A,2(AB) ;FIRST CHECK THAT ARG 2 IS AN ATOM
1386 MOVE B,3(AB) ;AND TYPE NAME
1387 PUSHJ P,TYPLOO ;GO LOOKUP TYPE
1388 TFOUND: HRRZ B,(A) ;GOBBLE THE SAT
1389 TRNE B,CHBIT ; SKIP IF CHTYPABLE
1391 TRNE B,TMPLBT ; TEMPLAT
1394 GETYP A,(AB) ;NOW GET TYPE TO HACK
1395 PUSHJ P,SAT ;FIND OUT ITS SAT
1396 JUMPE A,TYPERR ;COMPLAIN
1398 JRST CHTMPL ; JUMP IF TEMPLATE DATA
1399 CAIE A,(B) ;DO THEY AGREE?
1400 JRST TYPDIF ;NO, COMPLAIN
1401 CHTMP1: MOVSI A,(D) ;GET NEW TYPE
1402 HRR A,(AB) ; FOR DEFERRED GOODIES
1403 JUMPL B,CHMATC ; CHECK IT
1404 MOVE B,1(AB) ;AND VALUE
1407 CHTMPL: MOVE E,1(AB) ; GET ARG
1410 MOVE 0,3(AB) ; SEE IF TO "TEMPLATE"
1411 CAMN 0,IMQUOTE TEMPLATE
1413 TLNN E,-1 ; SKIP IF RESTED
1419 PUSH TP,1(AB) ; SAVE GOODIE
1424 PUSHJ P,IGET ; FIND THE DECL
1428 MOVE D,1(AB) ; NOW GGO TO MATCH
1444 TYPLOO: PUSHJ P,TYPFND
1445 ERRUUO EQUOTE BAD-TYPE-NAME
1448 TYPFND: HLRE A,B ; FIND DOPE WORDS
1449 SUBM B,A ; A POINTS TO IT
1450 HRRE D,(A) ; TYPE-CODE TO D
1452 ANDI D,TYPMSK ; FLUSH FUNNY BITS
1462 MOVE A,TYPVEC+1 ;GOBBLE DOWN TYPE VECTOR
1463 MOVEI D,0 ;INITIALIZE TYPE COUNTER
1464 TLOOK: CAMN B,1(A) ;CHECK THIS ONE
1466 ADDI D,1 ;BUMP COUNTER
1467 AOBJP A,.+2 ;COUTN DOWN ON VECTOR
1474 TYPDIF: ERRUUO EQUOTE STORAGE-TYPES-DIFFER
1477 TMPLVI: ERRUUO EQUOTE DECL-VIOLATION
1480 ; FUNCTION TO ADD A NEW TYPE TO THE WORLD WITH GIVEN PRIMITIVE TYPE
1482 MFUNCTION NEWTYPE,SUBR
1486 HLRZ 0,AB ; CHEC # OF ARGS
1487 CAILE 0,-4 ; AT LEAST 2
1490 JRST TMA ; NOT MORE THAN 3
1491 GETYP A,(AB) ; GET 1ST ARGS TYPE (SHOULD BE ATOM)
1492 GETYP C,2(AB) ; SAME WITH SECOND
1493 CAIN A,TATOM ; CHECK
1497 MOVE B,3(AB) ; GET PRIM TYPE NAME
1498 PUSHJ P,TYPLOO ; LOOK IT UP
1499 HRRZ A,(A) ; GOBBLE SAT
1501 HRLI A,TATOM ; MAKE NEW TYPE
1503 MOVE B,1(AB) ; SEE IF PREV EXISTED
1505 JRST NEWTOK ; DID NOT EXIST BEFORE
1506 MOVEI B,2(A) ; FOR POSSIBLE TMPLAT BIT
1507 HRRZ A,(A) ; GET SAT
1508 HRRZ 0,(P) ; AND PROPOSED
1511 CAIN 0,(A) ; SKIP IF LOSER
1514 ERRUUO EQUOTE TYPE-ALREADY-EXISTS
1517 MOVE B,1(AB) ; NEWTYPE NAME
1518 PUSHJ P,INSNT ; MUNG IN NEW TYPE
1520 NEWTFN: CAML AB,[-5,,] ; SKIP IF TEMPLAT SUPPLIED
1522 MOVEI 0,TMPLBT ; GET THE BIT
1523 IORM 0,-2(B) ; INTO WORD
1524 MOVE A,(AB) ; GET TYPE NAME
1528 PUSH TP,4(AB) ; GET TEMLAT
1532 MOVE B,1(AB) ; RETURN NAME
1535 ; SET UP GROWTH FIELDS
1537 IGROWT: SKIPA A,[111100,,(C)]
1538 IGROWB: MOVE A,[001100,,(C)]
1540 SUB C,B ; POINT TO DOPE WORD
1541 MOVE B,TYPIC ; INDICATED GROW BLOCK
1546 PUSH TP,B ; SAVE NAME OF NEWTYPE
1547 MOVE C,TYPBOT+1 ; CHECK GROWTH NEED
1549 JRST ADDIT ; STILL ROOM
1550 GAGN: PUSHJ P,IGROWB ; SETUP BOTTOM GROWTH
1552 PUSHJ P,IGROWT ; SET UP TOP GROWTH
1557 MOVE C,[11.,,5] ; SET UP INDICATOR FOR AGC
1558 PUSHJ P,AGC ; GROW THE WORLD
1559 AOJL A,GAGN ; BAD AGC LOSSAGE
1561 ADDM 0,TYPBOT+1 ; FIX UP POINTER
1563 ADDIT: MOVE C,TYPVEC+1
1564 SUB C,[2,,2] ; ALLOCATE ROOM
1566 HLRE B,C ; PREPARE TO BLT
1567 SUBM C,B ; C POINTS DOPE WORD END
1568 HRLI C,2(C) ; GET BLT AC READY
1570 POP TP,-1(B) ; CLOBBER IT IN
1572 HLRE C,TYPVEC+1 ; GET CODE
1576 MOVE D,-1(B) ; B HAS POINTER TO TYPE VECTOR DOPE WORDS
1578 CAIG 0,HIBOT ; IS ATOM PURE?
1579 JRST ADDNOI ; NO, SO NO HACKING REQUIRED
1582 PUSHJ P,IMPURIF ; DO IMPURE OF ATOM
1585 SUBM C,B ; RESTORE B
1587 MOVE D,-1(B) ; RESTORE D
1591 HRRM C,(A) ; INTO "GROWTH" FIELD
1595 ; Interface to interpreter for setting up tables associated with
1596 ; template data structures.
1597 ; A/ <
\b-name of type>
\b-
1598 ; B/ <
\b-length ins>
\b-
1599 ; C/ <
\b-uvector of garbage collector code or 0>
1600 ; D/ <
\b-uvector of GETTERs>
\b-
1601 ; E/ <
\b-uvector of PUTTERs>
\b-
1603 CTMPLT: SUBM M,(P) ; could possibly gc during this stuff
1604 PUSH TP,$TATOM ; save name of type
1606 PUSH P,B ; save length instr
1607 HLRE A,TD.LNT+1 ; check for template slots left?
1609 SUB B,A ; point to dope words
1610 HLRZ B,1(B) ; get real length
1612 JUMPG A,GOODRM ; jump if ok
1614 PUSH TP,$TUVEC ; save getters and putters
1616 PUSH TP,$TUVEC ; save getters and putters
1620 MOVEI A,10-2(B) ; grow it 10 by copying remember d.w. length
1621 PUSH P,A ; save new length
1622 PUSHJ P,CAFRE1 ; get frozen uvector
1623 ADD B,[10,,10] ; rest it down some
1624 HRL C,TD.LNT+1 ; prepare to BLT in
1625 MOVEM B,TD.LNT+1 ; and save as new length vector
1626 HRRI C,(B) ; destination
1627 ADD B,(P) ; final destination address
1629 MOVE A,(P) ; length for new getters
1631 HRL C,TD.GET+1 ; get old for copy
1633 PUSHJ P,DOBLTS ; go fixup new uvector
1634 MOVE A,(P) ; finally putters
1638 PUSHJ P,DOBLTS ; go fixup new uvector
1639 MOVE A,(P) ; finally putters
1643 PUSHJ P,DOBLTS ; go fixup new uvector
1644 SUB P,[1,,1] ; flush stack craft
1647 MOVE C,-4(TP) ;GET TD.AGC
1650 GOODRM: MOVE B,TD.LNT+1 ; move down to fit new guy
1651 SUB B,[1,,1] ; will always win due to prev checks
1656 ADDI A,-1(B) ; A/ final destination
1658 POP P,(A) ; new length ins munged in
1660 MOVNS A ; A/ offset for other guys
1662 ADD A,TD.GET+1 ; point for storing uvs of ins
1666 MOVEM E,-1(A) ; store putter also
1669 MOVEM C,-1(A) ; store putter also
1670 POP P,A ; compute primtype
1673 MOVE B,(TP) ; ready to mung type vector
1675 PUSHJ P,TYPFND ; CHECK TO SEE WHETHER TEMPLATE EXISTS
1680 NOTEM: POP P,A ; RESTORE SAT
1681 HRLI A,TATOM ; GET TYPE
1682 PUSHJ P,INSNT ; INSERT INTO VECTOR
1685 ; this routine copies GET and PUT vectors into new ones
1689 BLT C,-11(B) ; zap those guys in
1690 MOVEI A,TUVEC ; mung in uniform type
1692 MOVEI C,-7(B) ; zero out remainder of uvector
1699 ; FUNCTIONS TO SET UP EVALUATION AND APPLICATION RULES FOR DATA TYPES
1701 MFUNCTION EVALTYPE,SUBR
1705 PUSHJ P,CHKARG ; VERIFY WINNAGE IN ARGS
1706 MOVEI A,EVATYP ; POINT TO TABLE
1707 MOVEI E,EVTYPE ; POINT TO PURE VERSION
1709 TBLCAL: PUSHJ P,TBLSET ; SETUP TABLE ENTRY
1712 MFUNCTION APPLYTYPE,SUBR
1717 MOVEI A,APLTYP ; POINT TO APPLY TABLE
1718 MOVEI E,APTYPE ; PURE TABLE
1723 MFUNCTION PRINTTYPE,SUBR
1728 MOVEI A,PRNTYP ; POINT TO APPLY TABLE
1729 MOVEI E,PRTYPE ; PURE TABLE
1733 ; CHECK ARGS AND SETUP FOR TABLE HACKER
1735 CHKARG: JUMPGE AB,TFA
1738 GETYP A,(AB) ; 1ST MUST BE TYPE NAME
1741 MOVE B,1(AB) ; GET ATOM
1742 PUSHJ P,TYPLOO ; VERIFY THAT IT IS A TYPE
1743 PUSH P,D ; SAVE TYPE NO.
1744 MOVEI D,-1 ; INDICATE FUNNYNESS
1745 CAML AB,[-3,,] ; SKIP IF 2 OR MORE
1747 HRRZ A,(A) ; GET SAT
1750 GETYP A,2(AB) ; GET 2D TYPE
1751 CAIE A,TATOM ; EITHER TYPE OR APPLICABLE
1752 JRST TRYAPL ; TRY APPLICABLE
1753 MOVE B,3(AB) ; VERIFY IT IS A TYPE
1755 HRRZ A,(A) ; GET SAT
1757 POP P,C ; RESTORE SAVED SAT
1758 CAIE A,(C) ; SKIP IF A WINNER
1759 JRST TYPDIF ; REPORT ERROR
1760 TY1AR: POP P,C ; GET SAVED TYPE
1761 MOVEI B,0 ; TELL THAT WE ARE A TYPE
1764 TRYAPL: PUSHJ P,APLQ ; IS THIS APPLICABLE
1767 MOVE B,2(AB) ; RETURN SAME
1773 ; HERE TO PUT ENTRY IN APPROPRIATE TABLE
1776 PUSH TP,D ; SAVE VALUE
1779 PUSH P,C ; SAVE TYPE BEING HACKED
1781 SKIPE B,1(A) ; SKIP IF VECTOR DOESN'T EXIST YET
1783 MOVE B,-2(TP) ; CHECK FOR RETURN IT HACK
1788 HLRE A,TYPBOT+1 ; GET CURRENT TABLE LNTH
1792 PUSHJ P,IVECT ; GET VECTOR
1794 MOVE C,(TP) ; POINT TO RETURN POINT
1795 MOVEM B,1(C) ; SAVE VECTOR
1798 POP P,C ; RESTORE TYPE
1802 JUMPN A,TBLOK1 ; JUMP IF FUNCTION ETC. SUPPLIED
1805 CAILE D,NUMPRI ; SKIP IF ORIGINAL TYPE
1806 MOVNI E,(D) ; CAUSE E TO ENDUP 0
1807 ADDI E,(D) ; POINT TO PURE SLOT
1808 TBLOK1: ADDI C,(C) ; POINT TO VECTOR SLOT
1812 JUMPN A,OK.SET ; OK TO CLOBBER
1813 ADDI B,(D) ; POINT TO TARGET TYPE'S SLOT
1814 ADDI B,(D) ; POINT TO TARGET TYPE'S SLOT
1815 SKIPN A,(B) ; SKIP IF WINNER
1816 SKIPE 1(B) ; SKIP IF LOSER
1817 SKIPA D,1(B) ; SETUP D
1818 JRST CH.PTB ; CHECK PURE TABLE
1820 OK.SET: CAIN 0,(D) ; SKIP ON RESET
1824 RETAR1: MOVE A,(AB) ; RET TYPE
1834 RETPM2: SUB TP,[4,,4]
1852 RETPM3: ADD A,TYPVEC+1
1857 RETPRM: SUBI C,(B) ; UNDO BADNESS
1858 RETPM4: CAIG C,NUMPRI*2
1865 CALLTY: MOVE A,TYPVEC
1869 MFUNCTION ALLTYPES,SUBR
1879 ;FUNCTION TO RETURN TYPE OF ELEMENTS IN A UVECTOR
1881 MFUNCTION UTYPE,SUBR
1885 GETYP A,(AB) ;GET U VECTOR
1889 MOVE B,1(AB) ; GET UVECTOR
1893 CUTYPE: HLRE A,B ;GET -LENGTH
1895 SUB B,A ;POINT TO TYPE WORD
1897 JRST ITYPE ; GET NAME OF TYPE
1899 ; FUNCTION TO CHANGE UNIFORM TYPE OF A VECTOR
1901 MFUNCTION CHUTYPE,SUBR
1905 GETYP A,2(AB) ;GET 2D TYPE
1908 GETYP A,(AB) ; CALL WITH UVECTOR?
1912 MOVE A,1(AB) ; GET UV POINTER
1913 MOVE B,3(AB) ;GET ATOM
1915 MOVE A,(AB) ; RETURN UVECTOR
1919 CCHUTY: PUSH TP,$TUVEC
1921 PUSHJ P,TYPLOO ;LOOK IT UP
1928 HLRE C,(TP) ;-LENGTH
1930 SUB E,C ;POINT TO TYPE
1931 GETYP A,(E) ;GET TYPE
1932 JUMPE A,WIN0 ;ALLOW TYPE "LOSE" TO CHANGE TO ANYTHING
1933 PUSHJ P,SAT ;GET SAT
1938 HRLM D,(E) ;CLOBBER NEW ONE
1943 CANTCH: PUSH TP,$TATOM
1944 PUSH TP,EQUOTE CANT-CHTYPE-INTO
1952 PUSH TP,EQUOTE NON-ATOMIC-ARGUMENT
1960 ; SUBROUTINE TO LEAVE MUDDLE CLOSING ALL CHANNELS ON THE WAY
1967 PUSHJ P,CLOSAL ; DO THE CLOSES
1969 JRST IFALSE ; JUST IN CASE
1971 CLOSAL: MOVEI B,CHNL0+2 ; POINT TO 1ST (NOT INCLUDING TTY I/O)
1973 MOVE TVP,REALTV+1(PVP)
1979 PUSH P,[N.CHNS-1] ; MAX NO. OF CHANS
1985 SKIPN C,-1(B) ; THIS ONE OPEN?
1990 PUSH TP,-2(B) ; PUSH IT
1992 MCALL 1,FCLOSE ; CLOSE IT
1993 CLOSA4: SOSLE (P) ; COUNT DOWN
2000 CLOSA3: SKIPN B,CHNL0+1
2013 WHOAMI: 0 ; SYAYS WHETHER I AM REALLY A MUDDLE OR SOME HACK
2016 ;GARBAGE COLLECTORS PDLS
2019 GCPDL: -GCPLNT,,GCPDL
2026 MUDSTR: ASCII /MUDDLE
\7f\7f\7f/
2030 ASCIZ / IN OPERATION./
2032 ;MARKED PDLS FOR GC PROCESS
2035 ; DUMMY FRAME FOR INITIALIZER CALLS
2045 TPBAS: BLOCK ITPLNT+PDLBUF
2047 ITPLNT+2+PDLBUF+7,,0