1 TITLE MAIN LOOP AND GLOBALLY REFERENCED SUBROUTINES
\r
5 .GLOBAL PATCH,TBINIT,PIDSTO,PROCID,PTIME,GCPDL,PBASE,TYPTOP,RERR,FRMSTK,EMERGE
\r
6 .GLOBAL PAT,PDLBUF,INTINT,START,SWAP,ICR,SPBASE,TPBASE,TPBAS,SAT,CURPRI,CHFINI
\r
7 .GLOBAL TOPLEVEL,INTOBL,INITIA,ERROBL,MAINPR,RESFUN,STATUS,TYPVEC,ROOT,TTICHN,TTOCHN
\r
8 .GLOBAL TTYOPE,MOPEN,MCLOSE,MIOT,ILVAL,MESS,ERROR,CHFRM,IGVAL,TYPBOT,ASOVEC
\r
9 .GLOBAL PRINT,PRIN1,PRINC,MUDSTR,VECBOT,CSTACK,IFALSE,TYPLOO,RCALL,SWAPIN,CTMPLT
\r
10 .GLOBAL IDPROC,CHFSWP,ILOC,MAKACT,BNDV,SPECSTORE,BINDID,IGLOC,MTYO,MSGTYP,CAFRE1
\r
11 .GLOBAL EVATYP,EVTYPE,APLTYP,APTYPE,PRNTYP,PRTYPE,AGC,SGSNAM,NAPT,APLQ,STRTO6
\r
12 .GLOBAL 6TOCHS,TYPFND,STBL,CHNL0,N.CHNS,CLOSAL,%LOGOUT,%SSNAM,%RSNAM,%KILLM
\r
13 .GLOBAL MAKINF,%VALRET,COMPERR,IPUT,IGET,TMATCH,INITIZ,IPCINI,%UNAM,%JNAM,%RUNAM,%RJNAM
\r
14 .GLOBAL NOTTY,PATEND,CFRAME,CARGS,CFUNCT,CITYPE,CTYPEQ,CPTYPE,CTYPEP,CUTYPE,CCHUTY
\r
15 .GLOBAL RTFALS,PGINT,PURCLN,CTYPEC,CTYPEW,IDVAL1,CALLTY,MESSAG,INITFL,WHOAMI
\r
16 .GLOBAL %SLEEP,%HANG,%TOPLQ,ONINT,CHUNW,CURFCN,BUFRIN,TD.LNT,TD.GET,TD.PUT,MPOPJ
\r
17 .GLOBAL PURVEC,PLOAD,SSPECS,OUTRNG
\r
21 MONITS==1 ; SET TO 1 IF PC DEMON WANTED
\r
22 .VECT.==1 ; BIT TO INDICATE VECTORS FOR GCHACK
\r
24 ;MAIN LOOP AND STARTUP
\r
26 START: MOVEI 0,0 ; SET NO HACKS
\r
27 MOVEM 0,WHOAMI ; HACK FOR TS FOO linked to TS MUDDLE
\r
28 MOVE PVP,MAINPR ; MAKE SURE WE START IN THE MAIN PROCESS
\r
29 JUMPE 0,INITIZ ; MIGHT BE RESTART
\r
30 MOVE P,PSTO+1(PVP) ; SET UP FOR BOOTSTRAP HACK
\r
31 MOVE TP,TPSTO+1(PVP)
\r
32 INITIZ: SKIPN P ; IF NO CURRENT P
\r
33 MOVE P,PSTO+1(PVP) ; PDL TO GET OFF THE GROUND
\r
34 SKIPN TP ; SAME FOR TP
\r
35 MOVE TP,TPSTO+1(PVP) ; GET A TP TO WORK WITH
\r
36 MOVE TVP,TVPSTO+1(PVP) ; GET A TVP
\r
37 SETZB R,M ; RESET RSUBR AC'S
\r
40 PUSHJ P,TTYOPE ;OPEN THE TTY
\r
42 SKIPE WHOAMI ; SKIP IF THIS IS MUDDLE
\r
43 JRST .+3 ; ELSE NO MESSAGE
\r
44 SKIPN NOTTY ; IF NO TTY, IGNORE
\r
45 PUSHJ P,MSGTYP ;TYPE OUT TO USER
\r
47 XCT MESSAG ;MAYBE PRINT A MESSAGE
\r
48 PUSHJ P,INTINT ;INITIALIZE INTERRUPT HANDLER
\r
50 PUSHJ P,PURCLN ; CLEAN UP PURE SHARED AREA
\r
51 RESTART: ;RESTART A PROCESS
\r
53 MOVE B,TBINIT+1(PVP) ;POINT INTO STACK AT START
\r
54 PUSHJ P,CHUNW ; LEAVE WHILE DOING UNWIND CHECK
\r
56 MOVEI A,TFALSE ; IN CASE FALLS OFF PROCESS
\r
67 MFUNCTION LISTEN,SUBR
\r
70 PUSH P,[0] ;FLAG: DON'T PRINT ERROR MSG
\r
73 ; USER SUPPLIED ERROR HANDLER, TEMPORARY KLUDGE
\r
76 ERROR: MOVE B,IMQUOTE ERROR
\r
77 PUSHJ P,IGVAL ; GET VALUE
\r
79 CAIN C,TSUBR ; CHECK FOR NO CHANGE
\r
80 CAIE B,RERR1 ; SKIP IF NOT CHANGED
\r
82 JRST RERR1 ; GO TO THE DEFAULT
\r
83 PUSH TP,A ; SAVE VALUE
\r
86 MOVEI D,1 ; AND COUNTER
\r
87 USER1: PUSH TP,(C) ; PUSH THEM
\r
92 ACALL D,APPLY ; EVAL USERS ERROR
\r
96 TPSUBR==TSUBR+400000
\r
98 MFUNCTION ERROR%,PSUBR,ERROR
\r
100 RMT [EXPUNGE TPSUBR
\r
104 PUSH TP,MQUOTE ERROR,ERROR,INTRUP
\r
105 PUSHJ P,FRMSTK ; PUT ERROR'S FRAME ON STACK
\r
108 RERR2: JUMPGE C,RERR22
\r
113 RERR22: ACALL D,EMERGENCY
\r
118 PUSH P,[-1] ;PRINT ERROR FLAG
\r
120 ER1: MOVE B,IMQUOTE INCHAN
\r
121 PUSHJ P,ILVAL ; CHECK INPUT CHANNEL IS SOME KIND OF TTY
\r
123 CAIE A,TCHAN ; SKIP IF IT IS A CHANNEL
\r
124 JRST ER2 ; NO, MUST REBIND
\r
125 CAMN B,TTICHN+1(TVP)
\r
127 ER2: MOVE B,IMQUOTE INCHAN
\r
128 MOVEI C,TTICHN(TVP) ; POINT TO VALU
\r
129 PUSHJ P,PUSH6 ; PUSH THE BINDING
\r
130 MOVE B,TTICHN+1(TVP) ; GET IN CHAN
\r
131 NOTINC: SKIPE NOTTY
\r
137 MCALL 2,TTYECH ; ECHO INPUT
\r
138 NOECHO: MOVE B,IMQUOTE OUTCHAN
\r
139 PUSHJ P,ILVAL ; GET THE VALUE
\r
141 CAIE A,TCHAN ; SKIP IF OK CHANNEL
\r
142 JRST ER3 ; NOT CHANNEL, MUST REBIND
\r
143 CAMN B,TTOCHN+1(TVP)
\r
145 ER3: MOVE B,IMQUOTE OUTCHAN
\r
146 MOVEI C,TTOCHN(TVP)
\r
147 PUSHJ P,PUSH6 ; PUSH THE BINDINGS
\r
148 NOTOUT: MOVE B,IMQUOTE OBLIST
\r
149 PUSHJ P,ILVAL ; GET THE VALUE OF OBLIST
\r
150 PUSHJ P,OBCHK ; IS IT A WINNER ?
\r
151 SKIPA A,$TATOM ; NO, SKIP AND CONTINUE
\r
152 JRST NOTOBL ; YES, DO NOT DO REBINDING
\r
153 MOVE B,IMQUOTE OBLIST
\r
157 JRST MAKOB ; NO GLOBAL OBLIST, MAKE ONE
\r
158 MOVEI C,(B) ; COPY ADDRESS
\r
159 MOVE A,(C) ; GET THE GVAL
\r
161 PUSHJ P,OBCHK ; IS IT A WINNER ?
\r
162 JRST MAKOB ; NO, GO MAKE A NEW ONE
\r
163 MOVE B,IMQUOTE OBLIST
\r
166 NOTOBL: PUSH TP,[TATOM,,-1] ;FOR BINDING
\r
167 PUSH TP,IMQUOTE LER,[LERR ]INTRUP
\r
169 HRLI A,TFRAME ; CORRCT TYPE
\r
174 MOVE A,PVP ; GET PROCESS
\r
175 ADD A,[PROCID,,PROCID] ; POINT TO ID (ALSO LEVEL)
\r
179 ADDI A,1 ; BUMP ERROR LEVEL
\r
181 PUSH TP,PROCID+1(PVP)
\r
184 MOVE B,IMQUOTE READ-TABLE
\r
186 PUSH TP,[TATOM,,-1]
\r
187 PUSH TP,IMQUOTE READ-TABLE
\r
188 GETYP C,A ; TO GVAL OF READ-TABLE ON ERROR AND
\r
189 CAIE C,TVEC ; TOP ERRET'S
\r
199 PUSHJ P,SPECBIND ;BIND THE CRETANS
\r
200 MOVE A,-1(P) ;RESTORE SWITHC
\r
201 JUMPE A,NOERR ;IF 0, DONT PRINT ERROR MESS
\r
203 PUSH TP,EQUOTE *ERROR*
\r
205 MCALL 1,PRINC ;PRINT THE MESSAGE
\r
206 NOERR: MOVE C,AB ;GET A COPY OF AB
\r
208 ERRLP: JUMPGE C,LEVPRT ;IF NONE, RE-ENTER READ-EVAL-PRINT LOOP
\r
212 GETYP A,(C) ; GET ARGS TYPE
\r
215 MOVE A,1(C) ; GET ATOM
\r
218 CAMN A,ERROBL+1(TVP) ; DONT SKIP IF IN ERROR OBLIST
\r
219 MOVEI B,PRINC ; DONT PRINT TRAILER
\r
220 ERROK: PUSH P,B ; SAVE ROUTINE POINTER
\r
223 MCALL 0,TERPRI ; CRLF
\r
224 POP P,B ; GET ROUTINE BACK
\r
228 ADD C,[2,,2] ;BUMP SAVED AB
\r
229 JRST ERRLP ;AND CONTINUE
\r
232 LEVPRT: XCT INITFL ;LOAD MUDDLE INIT FILE IF FIRST TIME
\r
235 PUSH TP,EQUOTE [LISTENING-AT-LEVEL ]
\r
236 MCALL 1,PRINC ;PRINT LEVEL
\r
237 PUSH TP,$TFIX ;READY TO PRINT LEVEL
\r
238 HRRZ A,(P) ;GET LEVEL
\r
239 SUB P,[2,,2] ;AND POP STACK
\r
241 MCALL 1,PRIN1 ;PRINT WITHOUT SPACES ETC.
\r
242 PUSH TP,$TATOM ;NOW PROCESS
\r
243 PUSH TP,EQUOTE [ PROCESS ]
\r
244 MCALL 1,PRINC ;DONT SLASHIFY SPACES
\r
245 PUSH TP,PROCID(PVP) ;NOW ID
\r
246 PUSH TP,PROCID+1(PVP)
\r
253 PUSH TP,EQUOTE [ INT-LEVEL ]
\r
256 JRST MAINLP ; FALL INTO MAIN LOOP
\r
258 \f;ROUTINES FOR ERROR-LISTEN
\r
262 JRST CPOPJ1 ; WIN FOR SINGLE OBLIST
\r
263 CAIE 0,TLIST ; IF LIST, MAKE SURE EACH IS AN OBLIST
\r
264 JRST CPOPJ ; ELSE, LOSE
\r
266 JUMPE B,CPOPJ ; NIL ,LOSE
\r
269 PUSH P,[0] ;FLAG FOR DEFAULT CHECKING
\r
270 MOVEI 0,1000 ; VERY BIG NUMBER FOR CIRCULARITY TEST
\r
273 SOJE 0,OBLOSE ; CIRCULARITY TEST
\r
274 HRRZ B,(TP) ; GET LIST POINTER
\r
276 CAIE A,TOBLS ; SKIP IF WINNER
\r
277 JRST DEFCHK ; CHECK FOR SPECIAL ATOM DEFAULT
\r
282 OBLOSE: SUB TP,[2,,2]
\r
286 DEFCHK: SKIPN (P) ; BEEN HERE BEFORE ?
\r
287 CAIE A,TATOM ; OR, NOT AN ATOM ?
\r
288 JRST OBLOSE ; YES, LOSE
\r
290 CAME A,MQUOTE DEFAULT
\r
292 SETOM (P) ; SET FLAG
\r
293 HRRZ B,(B) ; CHECK FOR END OF LIST
\r
295 JUMPN B,OBCHK0 ; NOT THE END, CONTINUE LOOKING
\r
296 JRST OBLOSE ; LOSE FOR DEFAULT AT THE END
\r
300 PUSH6: PUSH TP,[TATOM,,-1]
\r
309 MAKOB: PUSH TP,INITIAL(TVP)
\r
310 PUSH TP,INITIAL+1(TVP)
\r
312 PUSH TP,ROOT+1(TVP)
\r
315 PUSH TP,IMQUOTE OBLIST
\r
319 PUSH TP,[TATOM,,-1]
\r
320 PUSH TP,IMQUOTE OBLIST
\r
328 ;THIS IS IT FOLKS...THE MAIN LOOP. READ, EVAL, PRINT
\r
330 MAINLP: MOVE A,$TATOM ;KLUDGE BY NDR LIKE ERROR TO LET LOOSER REDEFINE
\r
332 PUSHJ P,ILVAL ;GET ITS LVAL TO SEE IF REDEFINED
\r
336 MOVE A,$TATOM ;SEE IF IT HAS GVAL SINCE NO LVAL
\r
342 REPCHK: CAIN C,TSUBR
\r
351 MCALL 1,APPLY ;LOOSER HAS REDEFINED SO CALL HIS
\r
353 IREPER: PUSH P,[0] ;INDICATE FALL THROUGH
\r
356 ERRREP: PUSH TP,[TATOM,,-1]
\r
364 PUSH TP,EQUOTE NON-APPLICABLE-REP
\r
373 MFUNCTION REPER,SUBR,REP
\r
375 PUSH P,[1] ;INDICATE DIRECT CALL
\r
376 REPERF: MCALL 0,TERPRI
\r
383 PUSH TP,IMQUOTE LAST-OUT
\r
390 POP P,C ;FLAG FOR FALL THROUGH OR CALL
\r
391 JUMPN C,FINIS ;IN CASE LOOSER CALLED REP
\r
395 ;FUNCTION TO RETRY A PREVIOUS FUNCTION CALL
\r
397 MFUNCTION RETRY,SUBR
\r
400 JUMPGE AB,RETRY1 ; USE MOST RECENT
\r
403 GETYP A,(AB) ; CHECK TYPE
\r
406 MOVEI B,(AB) ; POINT TO ARG
\r
408 RETRY1: MOVE B,IMQUOTE LER,[LERR ]INTRUP
\r
409 PUSHJ P,ILOC ; LOCATIVE TO FRAME
\r
410 RETRY2: PUSHJ P,CHFSWP ; CHECK VALIDITY AND SWAP IF NECESSARY
\r
411 HRRZ 0,OTBSAV(B) ; CHECK FOR TOP
\r
412 JUMPE 0,RESTAR ; YES RE-ENTER TOP LEVEL
\r
414 PUSH TP,B ; SAVE FRAME
\r
415 MOVE B,OTBSAV(B) ; GET PRVIOUS FOR UNBIND HACK
\r
417 PUSHJ P,CHUNW ; CHECK ANY UNWINDING
\r
418 CAME SP,SPSAV(TB) ; UNBINDING NEEDED?
\r
420 MOVE P,PSAV(TB) ; GET OTHER STUFF
\r
422 HLRE A,AB ; COMPUTE # OF ARGS
\r
423 MOVNI A,-FRAMLN(A) ; MAKE TP POINT PAST FRAME
\r
425 MOVE C,TPSAV(TB) ; COMPUTE TP
\r
428 MOVE TB,B ; FIX UP TB
\r
429 HRRZ C,FSAV(TB) ; GET FUNCTION
\r
430 CAMGE C,VECTOP ; CHECK FOR RSUBR
\r
433 GETYP 0,(C) ; RSUBR OR ENTRY?
\r
437 MOVS R,(C) ; SET UP R
\r
442 RETRNT: CAIE 0,TRSUBR
\r
445 RETRN4: HRRZ C,2(C) ; OFFSET
\r
446 RETRN3: SKIPL M,1(R)
\r
451 RETRN5: MOVEI D,(M) ; TOTAL OFFSET
\r
453 ADD M,PURVEC+1(TVP)
\r
458 RETRN6: HLRZ A,1(R)
\r
462 JRST RETRER ; LOSER
\r
468 RETRN1: MOVE B,1(C)
\r
480 RETRN2: PUSH TP,$TATOM
\r
481 PUSH TP,EQUOTE CANT-RETRY-ENTRY-GONE
\r
484 RETRER: PUSH TP,$TATOM
\r
485 PUSH TP,EQUOTE PURE-LOAD-FAILURE
\r
489 ;FUNCTION TO DO ERROR RETURN
\r
491 MFUNCTION ERRET,SUBR
\r
494 HLRE A,AB ; -2*# OF ARGS
\r
495 JUMPGE A,STP ; RESTART PROCESS
\r
496 ASH A,-1 ; -# OF ARGS
\r
497 AOJE A,ERRET2 ; NO FRAME SUPPLIED
\r
503 PUSHJ P,CHPROC ; POINT TO FRAME SLOT
\r
505 ERRET2: MOVE B,IMQUOTE LER,[LERR ]INTRUP
\r
506 PUSHJ P,ILVAL ; GET ITS VALUE
\r
510 PUSHJ P,CHFSWP ; CHECK VALIDITY AND SWAP IF NECESSARY
\r
511 HRRZ 0,OTBSAV(B) ; TOP LEVEL?
\r
513 PUSHJ P,CHUNW ; ANY UNWINDING
\r
517 ; FUNCTION TO RETURN LAST ERROR FRAME OR PREVIOUS FRAME
\r
519 MFUNCTION FRAME,SUBR
\r
522 JUMPGE AB,FRM1 ; DEFAULT CASE
\r
523 CAMG AB,[-3,,0] ; SKIP IF OK ARGS
\r
525 PUSHJ P,OKFRT ; A FRAME OR SIMILAR THING?
\r
528 FRM1: PUSHJ P,CFRAME ; GO TO INTERNAL
\r
531 CFRAME: JUMPN A,FRM2 ; ARG SUPPLIED?
\r
532 MOVE B,IMQUOTE LER,[LERR ]INTRUP
\r
535 FRM2: PUSHJ P,CHPROC ; CHECK FOR PROCESS
\r
538 MOVEI B,-1(TP) ; POINT TO SLOT
\r
539 PUSHJ P,CHFRM ; CHECK IT
\r
540 MOVE C,(TP) ; GET FRAME BACK
\r
541 MOVE B,OTBSAV(C) ;GET PREVIOUS FRAME
\r
543 TRNN B,-1 ; SKIP IF OK
\r
546 FRM3: JUMPN B,FRM4 ; JUMP IF WINNER
\r
547 MOVE B,IMQUOTE THIS-PROCESS
\r
548 PUSHJ P,ILVAL ; GET PROCESS OF INTEREST
\r
549 GETYP A,A ; CHECK IT
\r
551 MOVE B,PVP ; USE CURRENT
\r
552 MOVEI A,PVLNT*2+1(B) ; POINT TO DOPE WORDS
\r
553 MOVE B,TBINIT+1(B) ; AND BASE FRAME
\r
554 FRM4: HLL B,OTBSAV(B) ;TIME
\r
558 OKFRT: AOS (P) ;ASSUME WINNAGE
\r
571 CHPROC: GETYP 0,A ; TYPE
\r
574 MOVEI A,PVLNT*2+1(B)
\r
575 CAMN B,PVP ; THIS PROCESS?
\r
580 CHPRO1: MOVE B,OTBSAV(TB)
\r
583 ; FUNCTION TO RETURN ARGS TUPLE FOR A FRAME
\r
585 MFUNCTION ARGS,SUBR
\r
587 PUSHJ P,OKFRT ; CHECK FRAME TYPE
\r
592 CARGS: PUSHJ P,CHPROC
\r
595 MOVEI B,-1(TP) ; POINT TO FRAME SLOT
\r
596 PUSHJ P,CHFRM ; AND CHECK FOR VALIDITY
\r
597 MOVE C,(TP) ; FRAME BACK
\r
599 CARGS1: GETYP 0,FSAV(C) ; IS THIS A FUNNY ONE
\r
600 CAIE 0,TCBLK ; SKIP IF FUNNY
\r
601 JRST .+3 ; NO NORMAL
\r
602 MOVE C,OTBSAV(C) ; ASSOCIATE WITH PREVIOUS FRAME
\r
604 HLR A,OTBSAV(C) ; TIME IT AND
\r
605 MOVE B,ABSAV(C) ; GET POINTER
\r
606 SUB TP,[2,,2] ; FLUSH CRAP
\r
609 ; FUNCTION TO RETURN FUNCTION ASSOCIATED WITH A FRAME
\r
611 MFUNCTION FUNCT,SUBR ;RETURNS FUNCTION NAME OF
\r
612 ENTRY 1 ; FRAME ARGUMENT
\r
613 PUSHJ P,OKFRT ; CHECK TYPE
\r
618 CFUNCT: PUSHJ P,CHPROC
\r
622 PUSHJ P,CHFRM ; CHECK IT
\r
623 MOVE C,(TP) ; RESTORE FRAME
\r
624 HRRZ A,FSAV(C) ;FUNCTION POINTER
\r
625 CAMG A,VECTOP ;IS THIS AN RSUBR ?
\r
627 SKIPA B,@-1(A) ;NO, GET SUBR'S NAME POINTER
\r
628 MOVE B,(A)+3 ;YES, GET RSUBR'S NAME ENTRY
\r
635 PUSH TP,EQUOTE FRAME-NO-LONGER-EXISTS
\r
641 PUSH TP,EQUOTE TOP-LEVEL-FRAME
\r
647 ; ROUTINE TO HANG INDEFINITELY WITH INTERRUPTS ENABLED
\r
649 MFUNCTION HANG,SUBR
\r
653 JUMPGE AB,HANG1 ; NO PREDICATE
\r
656 REHANG: MOVE A,[PUSHJ P,CHKPRH]
\r
657 MOVEM A,ONINT ; CHECK PREDICATE AFTER ANY INTERRUPT
\r
660 HANG1: ENABLE ;LET OURSELVES BE INTERRUPTED OUT
\r
662 DISABLE ;PREVENT INTERRUPTS AT RANDOM TIMES
\r
669 ; ROUTINE TO SLEEP FOR POSITIVE NUMBER OF SECONDS WITH INTERRUPTS ENABLED
\r
670 ; ARGUMENT SHOULD BE OF TYPE FIX OR FLOAT AND NON-NEGATIVE
\r
672 MFUNCTION SLEEP,SUBR
\r
683 SLEEP1: GETYP 0,(AB)
\r
687 JUMPL B,OUTRNG ;ARG SHOULDNT BE NEGATIVE
\r
688 IMULI B,30. ;CONVERT TO # OF THIRTIETHS OF A SECOND
\r
689 JRST SLEEPR ;GO SLEEP
\r
690 CAIE 0,TFLOAT ;IF IT WASNT FIX MAKE SURE IT IS FLOAT
\r
691 JRST WTYP1 ;WRONG TYPE ARG
\r
693 FMPR B,[30.0] ;CONVERT TO FLOATING # OF THIRTIETHS OF A SECOND
\r
694 MULI B,400 ;KLUDGE TO FIX IT
\r
697 MOVE B,C ;MOVE THE FIXED NUMBER INTO B
\r
698 JUMPL B,OUTRNG ;CHECK TO SEE THAT WE HAVE POSITIVE NUMBER
\r
700 RESLEE: MOVE B,[PUSHJ P,CHKPRS]
\r
718 SETZM ONINT ; TURN OFF FEATURE FOR NOW
\r
722 HANGP: SKIPA B,[REHANG]
\r
723 SLEEPP: MOVEI B,RESLEE
\r
736 MFUNCTION VALRET,SUBR
\r
737 ; SUBR TO VALRET A STRING TO SUPERIOR ITS PROCESS
\r
740 GETYP A,(AB) ; GET TYPE OF ARGUMENT
\r
741 CAIE A,TCHSTR ; IS IT A CHR STRING?
\r
742 JRST WTYP1 ; NO...ERROR WRONG TYPE
\r
743 PUSHJ P,CSTACK ; COPY THE CHR STRING TO THE STACK
\r
744 ; CSTACK IS IN ATOMHK
\r
745 MOVEI B,0 ; ASCIZ TERMINATOR
\r
746 EXCH B,(P) ; STORE AND RETRIEVE COUNT
\r
748 ; CALCULATE THE BEGINNING ADDR OF THE STRING
\r
749 MOVEI A,-1(P) ; GET ADDR OF TOP OF STACK
\r
750 SUBI A,-1(B) ; GET STARTING ADDR
\r
751 PUSHJ P,%VALRE ; PASS UP TO MONITOR
\r
752 JRST IFALSE ; IF HE RETURNS, RETURN FALSE
\r
755 MFUNCTION LOGOUT,SUBR
\r
757 ; SUBR TO DO A .LOGOUT (VALID ONLY AT TOP LEVEL)
\r
759 PUSHJ P,%TOPLQ ; SKIP IF AT TOP LEVEL
\r
762 PUSHJ P,%LOGOUT ; TRY TO FLUSH
\r
763 JRST IFALSE ; COULDN'T DO IT...RETURN FALSE
\r
765 ; FUNCTS TO GET UNAME AND JNAME
\r
767 MFUNCTION UNAME,SUBR
\r
774 MFUNCTION JNAME,SUBR
\r
781 ; FUNCTION TO SET AND READ GLOBAL SNAME
\r
783 MFUNCTION SNAME,SUBR
\r
790 GETYP A,(AB) ; ARG MUST BE STRING
\r
794 PUSH TP,IMQUOTE SNM
\r
800 SNAME1: MOVE B,IMQUOTE SNM
\r
809 RSUJNM: PUSHJ P,6TOCHS ; CONVERT IT
\r
813 SGSNAM: MOVE B,IMQUOTE SNM
\r
827 PUSHJ P,%SSNAM ; SET SNAME IN SYSTEM
\r
832 ;THIS SUBROUTINE ALLOCATES A NEW PROCESS TAKES NO ARGS AND
\r
833 ;IS CALLED BY PUSHJ P,. RETURNS IN A AND B A NEW PROCESS.
\r
835 ICR: MOVEI A,PVLNT ;SETUP CALL TO VECTOR FOR PVP
\r
836 PUSHJ P,IVECT ;GOBBLE A VECTOR
\r
837 HRLI C,PVBASE ;SETUP A BLT POINTER
\r
838 HRRI C,(B) ;GET INTO ADDRESS
\r
839 BLT C,PVLNT*2-1(B) ;COPY A PROTOTYPE INTO NEW PVP
\r
840 MOVSI C,400000+SPVP+.VECT. ;SET SPECIAL TYPE
\r
841 MOVEM C,PVLNT*2(B) ;CLOBBER IT IN
\r
842 PUSH TP,A ;SAVE THE RESULTS OF VECTOR
\r
845 PUSH TP,$TFIX ;GET A UNIFORM VECTOR
\r
848 ADD B,[PDLBUF-2,,-1] ;FUDGE WITH BUFFER
\r
849 MOVE C,(TP) ;REGOBBLE PROCESS POINTER
\r
850 MOVEM B,PSTO+1(C) ;STORE IN ALL HOMES
\r
854 MOVEI A,TPLNT ;PREPARE TO CREATE A TEMPORARY PDL
\r
855 PUSHJ P,IVECT ;GET THE TEMP PDL
\r
856 ADD B,[PDLBUF,,0] ;PDL GROWTH HACK
\r
857 MOVE C,(TP) ;RE-GOBBLE NEW PVP
\r
858 SUB B,[1,,1] ;FIX FOR STACK
\r
859 MOVEM B,TPBASE+1(C)
\r
861 ;SETUP INITIAL BINDING
\r
864 MOVEM B,SPBASE+1(C) ;SAVE AS BASE OF SP
\r
865 MOVEM B,SPSTO+1(C) ;AND CURRENT THEREOF
\r
866 MOVEM B,CURFCN+1(C) ; AND AS CURRENT FCN FOR SPEC/UNSPEC LOGIC
\r
867 PUSH B,IMQUOTE THIS-PROCESS
\r
868 PUSH B,$TPVP ;GIVE IT PROCESS AS VALUE
\r
870 ADD B,[2,,2] ;FINISH FRAME
\r
871 MOVEM B,TPSTO+1(C) ;MAKE THIS THE CURRENT STACK POINTER
\r
872 MOVEM C,PVPSTO+1(C) ;SAVE THE NEW PVP ITSELF
\r
873 MOVEM TVP,TVPSTO+1(C) ;AND THE GOOD OLD TRANSFER VECTOR
\r
874 AOS A,IDPROC ;GOBBLE A UNIQUE PROCESS I.D.
\r
875 MOVEM A,PROCID+1(C) ;SAVE THAT ALSO
\r
876 AOS A,PTIME ; GET A UNIQUE BINDING ID
\r
877 MOVEM A,BINDID+1(C)
\r
879 MOVSI A,TPVP ;CLOBBER THE TYPE
\r
880 MOVE B,(TP) ;AND POINTER TO PROCESS
\r
884 ;MINI ROUTINE TO CALL VECTOR WITH COUNT IN A
\r
886 IVECT: PUSH TP,$TFIX
\r
888 MCALL 1,VECTOR ;GOBBLE THE VECTOR
\r
892 ;SUBROUTINE TO SWAP A PROCESS IN
\r
893 ;CALLED WITH JSP A,SWAP AND NEW PVP IN B
\r
895 SWAP: ;FIRST STORE ALL THE ACS
\r
897 IRP A,,[PVP,TVP,AB,TB,TP,SP,P,M,R]
\r
898 MOVEM A,A!STO+1(PVP)
\r
901 SETOM 1(TP) ; FENCE POST MAIN STACK
\r
902 MOVEM TP,TPSAV(TB) ; CORRECT FRAME
\r
903 SETZM PSAV(TB) ; CLEAN UP CURRENT FRAME
\r
907 MOVE E,PVP ;RETURN OLD PROCESS IN E
\r
908 MOVE PVP,D ;AND MAKE NEW ONE BE D
\r
911 ;NOW RESTORE NEW PROCESSES AC'S
\r
913 IRP A,,[PVP,TVP,AB,TB,TP,SP,P,M,R]
\r
914 MOVE A,A!STO+1(PVP)
\r
917 JRST (C) ;AND RETURN
\r
922 ;SUBRS ASSOCIATED WITH TYPES
\r
924 ;INTERNAL FUNCTION TO GET STRAGE ALLOCATION TYPE
\r
925 ;GETS THE TYPE CODE IN A AND RETURNS SAT IN A.
\r
927 SAT: LSH A,1 ;TIMES 2 TO REF VECTOR
\r
928 HRLS A ;TO BOTH HALVES TO HACK AOBJN POINTER
\r
929 ADD A,TYPVEC+1(TVP) ;ACCESS THE VECTOR
\r
930 HRR A,(A) ;GET PROBABLE SAT
\r
931 JUMPL A,.+2 ;DID WE REALLY HAVE A VALID TYPE
\r
932 MOVEI A,0 ;NO RETURN 0
\r
934 POPJ P, ;AND RETURN
\r
936 ;TYPE (ITYPE) ARE FUNCTIONS TO RETURN THE ATOMIC NAME OF THE
\r
937 ;TYPE OF A GOODIE. TYPE TAKES ITS ARGS ON AP AND RETURNS IN A AND B.
\r
938 ;ITYPE TAKES ITS ARGS IN A AND B AND RETURNS IN SAME (B=0) FOR INVALID
\r
940 MFUNCTION TYPE,SUBR
\r
943 GETYP A,(AB) ;TYPE INTO A
\r
944 TYPE1: PUSHJ P,ITYPE ;GO TO INTERNAL
\r
945 JUMPN B,FINIS ;GOOD RETURN
\r
946 TYPERR: PUSH TP,$TATOM ;SETUP ERROR CALL
\r
947 PUSH TP,EQUOTE TYPE-UNDEFINED
\r
948 JRST CALER1" ;STANDARD ERROR HACKER
\r
950 CITYPE: GETYP A,A ; GET TYPE FOR COMPILER CALL
\r
951 ITYPE: LSH A,1 ;TIMES 2
\r
952 HRLS A ;TO BOTH SIDES
\r
953 ADD A,TYPVEC+1(TVP) ;GET ACTUAL LOCATION
\r
954 JUMPGE A,TYPERR ;LOST, TYPE OUT OF BOUNDS
\r
955 MOVE B,1(A) ;PICKUP TYPE
\r
959 ; PREDICATE -- IS OBJECT OF TYPE SPECIFIED
\r
961 MFUNCTION %TYPEQ,SUBR,[TYPE?]
\r
965 MOVE D,AB ; GET ARGS
\r
972 PUSHJ P,ITYPQ ; GO INTERNAL
\r
976 ITYPQ: GETYP A,A ; OBJECT
\r
978 TYPEQ0: SOJL C,CIFALS
\r
980 CAIE 0,TATOM ; Type name must be an atom
\r
982 CAMN B,1(D) ; Same as the OBJECT?
\r
983 JRST CPOPJ1 ; Yes, return type name
\r
985 JRST TYPEQ0 ; No, continue comparing
\r
991 CTYPEQ: SOJE A,CIFALS ; TREAT NO ARGS AS FALSE
\r
992 MOVEI D,1(A) ; FIND BASE OF ARGS
\r
995 SUBM TP,D ; D POINTS TO BASE
\r
996 MOVE E,D ; SAVE FOR TP RESTORE
\r
997 ADD D,[3,,3] ; FUDGE
\r
998 MOVEI C,(A) ; NUMBER OF TYPES
\r
1001 JFCL ; IGNORE SKIP FOR NOW
\r
1002 MOVE TP,E ; SET TP BACK
\r
1003 JUMPL B,CPOPJ1 ; SKIP
\r
1006 ; Entries to get type codes for types for fixing up RSUBRs and assembling
\r
1008 MFUNCTION %TYPEC,SUBR,[TYPE-C]
\r
1017 CAMGE AB,[-3,,0] ; skip if only type name given
\r
1021 TYPEC1: PUSHJ P,CTYPEC ; go to internal
\r
1024 GTPTYP: CAMGE AB,[-5,,0]
\r
1032 CTYPEC: PUSH P,C ; save primtype checker
\r
1033 PUSHJ P,TYPLOO ; search type vector
\r
1048 CTPEC1: MOVEI B,(D)
\r
1052 MFUNCTION %TYPEW,SUBR,[TYPE-W]
\r
1066 CTYPW3: PUSHJ P,CTYPEW
\r
1069 CTYPW1: GETYP 0,2(AB)
\r
1072 CAMGE AB,[-5,,0] ; JUMP IF RH IS GIVEN
\r
1077 CTYPW2: CAMGE AB,[-7,,0]
\r
1086 PUSHJ P,CTYPEC ; GET CODE IN B
\r
1092 ;PRIMTTYPE RETURNS THE TYPE ATOM OF A PRIMITIVE TYPE IN A CLASS
\r
1094 STBL: REPEAT NUMSAT,MQUOTE INTERNAL-TYPE
\r
1098 IRP A,,[[1WORD,WORD],[2WORD,LIST],[NWORD,UVECTOR],[2NWORD,VECTOR],[STORE,STORAGE]
\r
1099 [ARGS,TUPLE],[FRAME,FRAME],[ATOM,ATOM],[LOCID,LOCD],[CHSTR,STRING]
\r
1100 [PVP,PROCESS],[ASOC,ASOC],[LOCA,LOCA],[LOCS,LOCS],[LOCU,LOCU],[LOCV,LOCV]
\r
1101 [LOCL,LOCL],[LOCN,LOCAS],[LOCT,LOCT]]
\r
1114 MFUNCTION TYPEPRIM,SUBR
\r
1124 CTYPEP: PUSHJ P,TYPLOO ; CONVERT ATOM TO CODE
\r
1125 HRRZ A,(A) ; SAT TO A
\r
1129 MFUNCTION PRIMTYPE,SUBR
\r
1133 MOVE A,(AB) ;GET TYPE
\r
1138 PUSHJ P,SAT ;GET SAT
\r
1139 PTYP1: JUMPE A,TYPERR
\r
1140 MOVE B,MQUOTE TEMPLATE
\r
1141 CAIG A,NUMSAT ; IF BIG SAT, THEN TEMPLATE
\r
1147 ; RSUBR MAKES A VECTOR INTO AN OBJECT OF TYPE RSUBR, ALSO SLIGHTLY MUNGING IT
\r
1149 MFUNCTION RSUBR,SUBR
\r
1153 CAIE A,TVEC ; MUST BE VECTOR
\r
1155 MOVE B,1(AB) ; GET IT
\r
1156 GETYP A,(B) ; CHECK 1ST ELEMENTS TYPE
\r
1157 CAIN A,TPCODE ; PURE CODE
\r
1161 HLRM B,(B) ; CLOBEER SPECIAL COUNT FIELD
\r
1165 NRSUBR: PUSH TP,$TATOM
\r
1166 PUSH TP,EQUOTE FIRST-ELEMENT-OF-VECTOR-NOT-CODE
\r
1169 ; ROUTINE TO GENERATE ENTRYY OTHER THAN FIRST TO RSUBRR
\r
1171 MFUNCTION MENTRY,SUBR,[RSUBR-ENTRY]
\r
1175 GETYP 0,(AB) ; TYPE OF ARG
\r
1176 CAIE 0,TVEC ; BETTER BE VECTOR
\r
1181 MOVE B,1(AB) ; GET VECTOR
\r
1184 GETYP 0,(B) ; FIRST ELEMENT
\r
1187 MENTR2: GETYP 0,2(B)
\r
1191 HRRM C,2(B) ; OFFSET INTO VECTOR
\r
1196 MENTR1: CAIE 0,TATOM
\r
1198 MOVE B,1(B) ; GET ATOM
\r
1199 PUSHJ P,IGVAL ; GET VAL
\r
1203 MOVE B,1(AB) ; RESTORE B
\r
1206 BENTRY: PUSH TP,$TATOM
\r
1207 PUSH TP,EQUOTE BAD-VECTOR
\r
1210 ; SUBR TO GET ENTRIES OFFSET
\r
1212 MFUNCTION LENTRY,SUBR,[ENTRY-LOC]
\r
1226 RTFALS: MOVSI A,TFALSE
\r
1230 ;SUBROUTINE CALL FOR RSUBRs
\r
1231 RCALL: SUBM M,(P) ;CALCULATE PC's OFFSET IN THE RSUBR
\r
1232 PUSHJ P,@0 ;GO TO THE PROPER SUBROUTINE
\r
1233 SUBM M,(P) ;RECONSTITUTE THE RSUBR's PC
\r
1237 ; ERRORS IN COMPILED CODE MAY END UP HERE
\r
1241 PUSH TP,EQUOTE ERROR-IN-COMPILED-CODE
\r
1245 ;CHTYPE TAKES TWO ARGUMENTS. ANY GOODIE AND A AN ATOMIC TYPE NAME
\r
1246 ;IT CHECKS THE STORAGE ALLOCATION TYPES OF THE TWO ARE THE SAME AND
\r
1247 ;IF THEY ARE CHANGES THE TYPE OF THE FIRST TO THAT NAME D IN THE SECOND
\r
1249 MFUNCTION CHTYPE,SUBR
\r
1252 GETYP A,2(AB) ;FIRST CHECK THAT ARG 2 IS AN ATOM
\r
1255 MOVE B,3(AB) ;AND TYPE NAME
\r
1256 PUSHJ P,TYPLOO ;GO LOOKUP TYPE
\r
1257 TFOUND: HRRZ B,(A) ;GOBBLE THE SAT
\r
1258 TRNE B,CHBIT ; SKIP IF CHTYPABLE
\r
1260 TRNE B,TMPLBT ; TEMPLAT
\r
1262 AND B,[-1,,SATMSK]
\r
1263 GETYP A,(AB) ;NOW GET TYPE TO HACK
\r
1264 PUSHJ P,SAT ;FIND OUT ITS SAT
\r
1265 JUMPE A,TYPERR ;COMPLAIN
\r
1267 JRST CHTMPL ; JUMP IF TEMPLATE DATA
\r
1268 CAIE A,(B) ;DO THEY AGREE?
\r
1269 JRST TYPDIF ;NO, COMPLAIN
\r
1270 CHTMP1: MOVSI A,(D) ;GET NEW TYPE
\r
1271 HRR A,(AB) ; FOR DEFERRED GOODIES
\r
1272 JUMPL B,CHMATC ; CHECK IT
\r
1273 MOVE B,1(AB) ;AND VALUE
\r
1276 CHTMPL: MOVE E,1(AB) ; GET ARG
\r
1279 MOVE 0,3(AB) ; SEE IF TO "TEMPLATE"
\r
1280 CAME 0,MQUOTE TEMPLATE
\r
1286 PUSH TP,1(AB) ; SAVE GOODIE
\r
1290 MOVE D,MQUOTE DECL
\r
1291 PUSHJ P,IGET ; FIND THE DECL
\r
1293 MOVE D,1(AB) ; NOW GGO TO MATCH
\r
1300 TYPLOO: PUSHJ P,TYPFND
\r
1303 PUSH TP,$TATOM ;LOST, GENERATE ERROR
\r
1304 PUSH TP,EQUOTE BAD-TYPE-NAME
\r
1307 TYPFND: MOVE A,TYPVEC+1(TVP) ;GOBBLE DOWN TYPE VECTOR
\r
1308 MOVEI D,0 ;INITIALIZE TYPE COUNTER
\r
1309 TLOOK: CAMN B,1(A) ;CHECK THIS ONE
\r
1311 ADDI D,1 ;BUMP COUNTER
\r
1312 AOBJP A,.+2 ;COUTN DOWN ON VECTOR
\r
1318 TYPDIF: PUSH TP,$TATOM ;MAKE ERROR MESSAGE
\r
1319 PUSH TP,EQUOTE STORAGE-TYPES-DIFFER
\r
1323 TMPLVI: PUSH TP,$TATOM
\r
1324 PUSH TP,EQUOTE DECL-VIOLATION
\r
1328 ; FUNCTION TO ADD A NEW TYPE TO THE WORLD WITH GIVEN PRIMITIVE TYPE
\r
1330 MFUNCTION NEWTYPE,SUBR
\r
1334 HLRZ 0,AB ; CHEC # OF ARGS
\r
1335 CAILE 0,-4 ; AT LEAST 2
\r
1338 JRST TMA ; NOT MORE THAN 3
\r
1339 GETYP A,(AB) ; GET 1ST ARGS TYPE (SHOULD BE ATOM)
\r
1340 GETYP C,2(AB) ; SAME WITH SECOND
\r
1341 CAIN A,TATOM ; CHECK
\r
1345 MOVE B,3(AB) ; GET PRIM TYPE NAME
\r
1346 PUSHJ P,TYPLOO ; LOOK IT UP
\r
1347 HRRZ A,(A) ; GOBBLE SAT
\r
1348 HRLI A,TATOM ; MAKE NEW TYPE
\r
1349 PUSH P,A ; AND SAVE
\r
1350 MOVE B,1(AB) ; SEE IF PREV EXISTED
\r
1352 JRST NEWTOK ; DID NOT EXIST BEFORE
\r
1353 MOVEI B,2(A) ; FOR POSSIBLE TMPLAT BIT
\r
1354 HRRZ A,(A) ; GET SAT
\r
1355 HRRZ 0,(P) ; AND PROPOSED
\r
1358 CAIN 0,(A) ; SKIP IF LOSER
\r
1359 JRST NEWTFN ; O.K.
\r
1362 PUSH TP,EQUOTE TYPE-ALREADY-EXISTS
\r
1366 MOVE B,1(AB) ; NEWTYPE NAME
\r
1367 PUSHJ P,INSNT ; MUNG IN NEW TYPE
\r
1369 NEWTFN: CAML AB,[-5,,] ; SKIP IF TEMPLAT SUPPLIED
\r
1371 MOVEI 0,TMPLBT ; GET THE BIT
\r
1372 IORM 0,-2(B) ; INTO WORD
\r
1373 MOVE A,(AB) ; GET TYPE NAME
\r
1376 MOVE D,MQUOTE DECL
\r
1377 PUSH TP,4(AB) ; GET TEMLAT
\r
1380 NEWTF1: MOVE A,(AB)
\r
1381 MOVE B,1(AB) ; RETURN NAME
\r
1384 ; SET UP GROWTH FIELDS
\r
1386 IGROWT: SKIPA A,[111100,,(C)]
\r
1387 IGROWB: MOVE A,[001100,,(C)]
\r
1389 SUB C,B ; POINT TO DOPE WORD
\r
1390 MOVE B,TYPIC ; INDICATED GROW BLOCK
\r
1395 PUSH TP,B ; SAVE NAME OF NEWTYPE
\r
1396 MOVE C,TYPBOT+1(TVP) ; CHECK GROWTH NEED
\r
1397 CAMGE C,TYPVEC+1(TVP)
\r
1398 JRST ADDIT ; STILL ROOM
\r
1399 GAGN: PUSHJ P,IGROWB ; SETUP BOTTOM GROWTH
\r
1400 SKIPE C,EVATYP+1(TVP)
\r
1401 PUSHJ P,IGROWT ; SET UP TOP GROWTH
\r
1402 SKIPE C,APLTYP+1(TVP)
\r
1404 MOVE C,[11.,,5] ; SET UP INDICATOR FOR AGC
\r
1405 PUSHJ P,AGC ; GROW THE WORLD
\r
1406 AOJL A,GAGN ; BAD AGC LOSSAGE
\r
1407 MOVE 0,[-101,,-100]
\r
1408 ADDM 0,TYPBOT+1(TVP) ; FIX UP POINTER
\r
1410 ADDIT: MOVE C,TYPVEC+1(TVP)
\r
1411 SUB C,[2,,2] ; ALLOCATE ROOM
\r
1412 MOVEM C,TYPVEC+1(TVP)
\r
1413 HLRE B,C ; PREPARE TO BLT
\r
1414 SUBM C,B ; C POINTS DOPE WORD END
\r
1415 HRLI C,2(C) ; GET BLT AC READY
\r
1417 POP TP,-1(B) ; CLOBBER IT IN
\r
1422 ; Interface to interpreter for setting up tables associated with
\r
1423 ; template data structures.
\r
1424 ; A/ <
\b-name of type>
\b-
\r
1425 ; B/ <
\b-length ins>
\b-
\r
1426 ; C/ <
\b-uvector of length code or 0>
\r
1427 ; D/ <
\b-uvector of GETTERs>
\b-
\r
1428 ; E/ <
\b-uvector of PUTTERs>
\b-
\r
1430 CTMPLT: SUBM M,(P) ; could possibly gc during this stuff
\r
1431 SKIPE C ; for now dont handle vector of length ins
\r
1432 FATAL TEMPLATE DATA WITH COMPUTED LENGTH
\r
1433 PUSH TP,$TATOM ; save name of type
\r
1435 PUSH P,B ; save length instr
\r
1436 HLRE A,TD.LNT+1(TVP) ; check for template slots left?
\r
1437 HRRZ B,TD.LNT+1(TVP)
\r
1438 SUB B,A ; point to dope words
\r
1439 HLRZ B,1(B) ; get real length
\r
1440 ADDM B,A ; any room?
\r
1441 JUMPG A,GOODRM ; jump if ok
\r
1443 PUSH TP,$TUVEC ; save getters and putters
\r
1447 MOVEI A,6(B) ; grow it 10 by copying
\r
1448 PUSH P,A ; save new length
\r
1449 PUSHJ P,CAFRE1 ; get frozen uvector
\r
1450 ADD B,[10,,10] ; rest it down some
\r
1451 HRL C,TD.LNT+1(TVP) ; prepare to BLT in
\r
1452 MOVEM B,TD.LNT+1(TVP) ; and save as new length vector
\r
1453 HRRI C,(B) ; destination
\r
1454 ADD B,(P) ; final destination address
\r
1456 MOVE A,(P) ; length for new getters
\r
1458 MOVE C,TD.GET+1(TVP) ; get old for copy
\r
1459 MOVEM B,TD.GET+1(TVP)
\r
1462 BLT C,-13(B) ; zap those guys in
\r
1463 MOVE A,(P) ; finally putters
\r
1465 MOVE C,TD.PUT+1(TVP)
\r
1466 MOVEM B,TD.PUT+1(TVP)
\r
1467 HRRI C,(B) ; BLT pointer
\r
1470 SUB P,[1,,1] ; flush stack craft
\r
1475 GOODRM: MOVE B,TD.LNT+1(TVP) ; move down to fit new guy
\r
1476 SUB B,[1,,1] ; will always win due to prev checks
\r
1477 MOVEM B,TD.LNT+1(TVP)
\r
1479 HLRE A,TD.LNT+1(TVP)
\r
1481 ADDI A,-1(B) ; A/ final destination
\r
1483 POP P,(A) ; new length ins munged in
\r
1484 HLRE A,TD.LNT+1(TVP)
\r
1485 MOVNS A ; A/ offset for other guys
\r
1486 PUSH P,A ; save it
\r
1487 ADD A,TD.GET+1(TVP) ; point for storing uvs of ins
\r
1490 ADD A,TD.PUT+1(TVP)
\r
1491 MOVEM E,-1(A) ; store putter also
\r
1492 POP P,A ; compute primtype
\r
1495 MOVE B,(TP) ; ready to mung type vector
\r
1497 PUSHJ P,INSNT ; insert into vector
\r
1501 ; FUNCTIONS TO SET UP EVALUATION AND APPLICATION RULES FOR DATA TYPES
\r
1503 MFUNCTION EVALTYPE,SUBR
\r
1507 PUSHJ P,CHKARG ; VERIFY WINNAGE IN ARGS
\r
1508 MOVEI A,EVATYP ; POINT TO TABLE
\r
1509 MOVEI E,EVTYPE ; POINT TO PURE VERSION
\r
1510 TBLCAL: PUSHJ P,TBLSET ; SETUP TABLE ENTRY
\r
1513 MFUNCTION APPLYTYPE,SUBR
\r
1518 MOVEI A,APLTYP ; POINT TO APPLY TABLE
\r
1519 MOVEI E,APTYPE ; PURE TABLE
\r
1523 MFUNCTION PRINTTYPE,SUBR
\r
1528 MOVEI A,PRNTYP ; POINT TO APPLY TABLE
\r
1529 MOVEI E,PRTYPE ; PURE TABLE
\r
1532 ; CHECK ARGS AND SETUP FOR TABLE HACKER
\r
1534 CHKARG: GETYP A,(AB) ; 1ST MUST BE TYPE NAME
\r
1537 MOVE B,1(AB) ; GET ATOM
\r
1538 PUSHJ P,TYPLOO ; VERIFY THAT IT IS A TYPE
\r
1539 PUSH P,D ; SAVE TYPE NO.
\r
1540 HRRZ A,(A) ; GET SAT
\r
1543 GETYP A,2(AB) ; GET 2D TYPE
\r
1544 CAIE A,TATOM ; EITHER TYPE OR APPLICABLE
\r
1545 JRST TRYAPL ; TRY APPLICABLE
\r
1546 MOVE B,3(AB) ; VERIFY IT IS A TYPE
\r
1548 HRRZ A,(A) ; GET SAT
\r
1550 POP P,C ; RESTORE SAVED SAT
\r
1551 CAIE A,(C) ; SKIP IF A WINNER
\r
1552 JRST TYPDIF ; REPORT ERROR
\r
1553 POP P,C ; GET SAVED TYPE
\r
1554 MOVEI B,0 ; TELL THAT WE ARE A TYPE
\r
1557 TRYAPL: PUSHJ P,APLQ ; IS THIS APPLICABLE
\r
1560 MOVE B,2(AB) ; RETURN SAME
\r
1566 ; HERE TO PUT ENTRY IN APPROPRIATE TABLE
\r
1568 TBLSET: HRLI A,(A) ; FOR TVP HACKING
\r
1569 ADD A,TVP ; POINT TO TVP SLOT
\r
1571 PUSH TP,D ; SAVE VALUE
\r
1574 PUSH P,C ; SAVE TYPE BEING HACKED
\r
1576 SKIPE B,1(A) ; SKIP IF VECTOR DOESN'T EXIST YET
\r
1578 HLRE A,TYPBOT+1(TVP) ; GET CURRENT TABLE LNTH
\r
1581 PUSHJ P,IVECT ; GET VECTOR
\r
1582 MOVE C,(TP) ; POINT TO RETURN POINT
\r
1583 MOVEM B,1(C) ; SAVE VECTOR
\r
1586 POP P,C ; RESTORE TYPE
\r
1590 JUMPN A,TBLOK1 ; JUMP IF FUNCTION ETC. SUPPLIED
\r
1591 CAILE D,NUMPRI ; SKIP IF ORIGINAL TYPE
\r
1592 MOVNI E,(D) ; CAUSE E TO ENDUP 0
\r
1593 ADDI E,(D) ; POINT TO PURE SLOT
\r
1594 TBLOK1: ADDI C,(C) ; POINT TO VECTOR SLOT
\r
1596 JUMPN A,OK.SET ; OK TO CLOBBER
\r
1597 ADDI B,(D) ; POINT TO TARGET TYPE'S SLOT
\r
1598 ADDI B,(D) ; POINT TO TARGET TYPE'S SLOT
\r
1599 SKIPN A,(B) ; SKIP IF WINNER
\r
1600 SKIPE 1(B) ; SKIP IF LOSER
\r
1601 SKIPA D,1(B) ; SETUP D
\r
1602 JRST CH.PTB ; CHECK PURE TABLE
\r
1604 OK.SET: MOVEM A,(C) ; STORE
\r
1606 MOVE A,(AB) ; RET TYPE
\r
1611 MOVE D,[SETZ NAPT]
\r
1616 CALLTY: MOVE A,TYPVEC(TVP)
\r
1617 MOVE B,TYPVEC+1(TVP)
\r
1620 MFUNCTION ALLTYPES,SUBR
\r
1624 MOVE A,TYPVEC(TVP)
\r
1625 MOVE B,TYPVEC+1(TVP)
\r
1630 ;FUNCTION TO RETURN TYPE OF ELEMENTS IN A UVECTOR
\r
1632 MFUNCTION UTYPE,SUBR
\r
1636 GETYP A,(AB) ;GET U VECTOR
\r
1640 MOVE B,1(AB) ; GET UVECTOR
\r
1644 CUTYPE: HLRE A,B ;GET -LENGTH
\r
1646 SUB B,A ;POINT TO TYPE WORD
\r
1648 JRST ITYPE ; GET NAME OF TYPE
\r
1650 ; FUNCTION TO CHANGE UNIFORM TYPE OF A VECTOR
\r
1652 MFUNCTION CHUTYPE,SUBR
\r
1656 GETYP A,2(AB) ;GET 2D TYPE
\r
1659 GETYP A,(AB) ; CALL WITH UVECTOR?
\r
1663 MOVE A,1(AB) ; GET UV POINTER
\r
1664 MOVE B,3(AB) ;GET ATOM
\r
1666 MOVE A,(AB) ; RETURN UVECTOR
\r
1670 CCHUTY: PUSH TP,$TUVEC
\r
1672 PUSHJ P,TYPLOO ;LOOK IT UP
\r
1673 HRRZ B,(A) ;GET SAT
\r
1677 HLRE C,(TP) ;-LENGTH
\r
1679 SUB E,C ;POINT TO TYPE
\r
1680 GETYP A,(E) ;GET TYPE
\r
1681 JUMPE A,WIN0 ;ALLOW TYPE "LOSE" TO CHANGE TO ANYTHING
\r
1682 PUSHJ P,SAT ;GET SAT
\r
1684 CAIE A,(B) ;COMPARE
\r
1686 WIN0: HRLM D,(E) ;CLOBBER NEW ONE
\r
1691 CANTCH: PUSH TP,$TATOM
\r
1692 PUSH TP,EQUOTE CANT-CHTYPE-INTO
\r
1700 PUSH TP,EQUOTE NON-ATOMIC-ARGUMENT
\r
1708 ; SUBROUTINE TO LEAVE MUDDLE CLOSING ALL CHANNELS ON THE WAY
\r
1710 MFUNCTION QUIT,SUBR
\r
1715 PUSHJ P,CLOSAL ; DO THE CLOSES
\r
1717 JRST IFALSE ; JUST IN CASE
\r
1719 CLOSAL: MOVE B,TVP ; POINT TO XFER VECCTOR
\r
1720 ADD B,[CHNL0+2,,CHNL0+2] ; POINT TO 1ST (NOT INCLUDING TTY I/O)
\r
1723 PUSH P,[N.CHNS-1] ; MAX NO. OF CHANS
\r
1725 CLOSA1: MOVE B,(TP)
\r
1728 SKIPN C,-1(B) ; THIS ONE OPEN?
\r
1730 CAME C,TTICHN+1(TVP)
\r
1731 CAMN C,TTOCHN+1(TVP)
\r
1733 PUSH TP,-2(B) ; PUSH IT
\r
1735 MCALL 1,FCLOSE ; CLOSE IT
\r
1736 CLOSA4: SOSLE (P) ; COUNT DOWN
\r
1743 CLOSA3: SKIPN B,CHNL0+1(TVP)
\r
1749 MOVEM B,CHNL0+1(TVP)
\r
1753 ; LITTLE ROUTINES USED ALL OVER THE PLACE
\r
1759 MSGTYP: HRLI B,440700 ;MAKE BYTE POINTER
\r
1760 MSGTY1: ILDB A,B ;GET NEXT CHARACTER
\r
1761 JUMPE A,CPOPJ ;NULL ENDS STRING
\r
1762 CAIE A,177 ; DONT PRINT RUBOUTS
\r
1764 JRST MSGTY1 ;AND GET NEXT CHARACTER
\r
1769 WHOAMI: 0 ; SYAYS WHETHER I AM REALLY A MUDDLE OR SOME HACK
\r
1772 ;GARBAGE COLLECTORS PDLS
\r
1775 GCPDL: -GCPLNT,,GCPDL
\r
1782 MUDSTR: ASCII /MUDDLE
\7f\7f\7f/
\r
1786 ASCIZ / IN OPERATION./
\r
1788 ;MARKED PDLS FOR GC PROCESS
\r
1791 ; DUMMY FRAME FOR INITIALIZER CALLS
\r
1801 TPBAS: BLOCK ITPLNT+PDLBUF
\r
1803 ITPLNT+2+PDLBUF+7,,0
\r