1 TITLE AGC MUDDLE GARBAGE COLLECTOR
\r
3 ;SYSTEM WIDE DEFINITIONS GO HERE
\r
5 .GLOBAL RCL,VECTOP,VECBOT,PARTOP,PARBOT,HITOP,HIBOT,GETPAG
\r
6 .GLOBAL PDLBUF,PDLEX,PDLEXP,GCFLG,GCPDL,GETNUM,PARNEW,MOVPUR
\r
7 .GLOBAL PGROW,TPGROW,TIMOUT,MAINPR,%SLEEP,MSGTYP,PURTOP,PURBOT,STOSTR
\r
8 .GLOBAL MTYI,UPLO,FRMUNG,BYTDOP,GLOBSP,SYSMAX,FREDIF,FREMIN,GCHAPN,INTFLG
\r
9 .GLOBAL SAT,TTOCHN,TYPVEC,ICONS,INCONS,IBLOCK,IEUVEC,IEVECTI,CELL2
\r
10 .GLOBAL GIBLOK,REHASH,IBLOK1,IILIST,IIFORM,CIVEC,CIUVEC,CICONS
\r
11 .GLOBAL SPBASE,OUTRNG,CISTNG,%RUNAM,PURVEC,GCDOWN,N.CHNS,CHNL1
\r
12 .GLOBAL CAFRE,CAFRET,STOGC,GCHN,WNDP,FRNP,%GCJOB,%SHWND,%SHFNT,%INFMP,%GETIP
\r
13 .GLOBAL TD.PUT,TD.GET,TD.LNT
\r
14 .GLOBAL CTIME,MTYO,ILOC,GCRSET
\r
15 .GLOBAL GCTIM,GCCAUS,GCCALL,AAGC,LVLINC,STORIC,GVLINC,TYPIC
\r
16 ; GLOBALS ASSOCIATE WITH THE ASSOCIATION VECTOR
\r
18 .GLOBAL ASOVEC,ASOLNT,ITEM,INDIC,VAL,NWORDT,NODPNT,PNTRS
\r
19 .GLOBAL CELL,BINDID,GCFLCH,TYPBOT,GLOBAS,TPBASE
\r
21 .GLOBAL P.TOP,P.CORE,PMAP
\r
23 NGCS==8 ; AFTER NGCS, DO HAIRY VAL/ASSOC FLUSH
\r
25 TPMAX==20000 ;PDLS LARGER THAN THIS WILL BE SHRUNK
\r
26 PMAX==4000 ;MAXIMUM PSTACK SIZE
\r
27 TPMIN==1000 ;MINIMUM PDL SIZES
\r
29 TPGOOD==10000 ; A GOOD STACK SIZE
\r
31 .ATOM.==200000 ; FLAG SAYING ATOMS MARKED (FOR VAL FLUSH LOGIC)
\r
33 GCHN==0 ; CHANNEL FOR FUNNNY INFERIOR
\r
34 STATNO==19. ; # OF STATISTICS FOR BLOAT-STAT
\r
35 STATGC==8. ; # OF GC-STATISTICS FOR BLOAT-STAT
\r
41 TYPNT=AB ;SPECIAL AC USAGE DURING GC
\r
42 F=TP ;ALSO SPECIAL DURING GC
\r
43 LPVP=SP ;SPECIAL FOR GC, HOLDS POINTER TO PROCESS CHAIN
\r
44 FPTR=TB ; POINT TO CURRENT FRONTIER OF INFERIOR
\r
47 ; WINDOW AND FRONTIER PAGES
\r
49 FRONT==776000 ; PAGE 255. IS FRONTIER
\r
50 WIND==774000 ; PAGE 254. IS WINDOW
\r
61 MFUNCTION BLOATSTAT,SUBR,[BLOAT-STAT]
\r
65 JUMPGE AB,GETUVC ; SEE IF THERE IS AN ARGUMENT
\r
67 CAIE A,TUVEC ; SEE IF THE ARGUMENT IS A UVECTOR
\r
68 JRST WTYP1 ; IF NOT COMPLAIN
\r
71 CAIGE 0,STATNO+STATGC ; SEE IF UVECTOR IS RIGHT LENGTH
\r
73 CAMGE AB,[-2,,0] ; SEE IF THERE ARE TOO MANY ARGUMENTS
\r
75 MOVE A,(AB) ; GET THE UVECTOR
\r
77 JRST SETUV ; CONTINUE
\r
78 GETUVC: MOVEI A,STATNO+STATGC ; CREATE A UVECTOR
\r
80 SETUV: PUSH P,A ; SAVE UVECTOR
\r
82 MOVE 0,NOWFRE ; COMPUTE FREE STORAGE USED SINCE LAST GC
\r
86 HLRE 0,TP ; COMPUTE STACK SPACE USED UP
\r
90 MOVE B,IMQUOTE THIS-PROCESS
\r
93 HRRZ C,TPBASE+1(PVP) ; CALCULATE # OF ATOM SLOTS
\r
95 HRRZ D,SPBASE+1(PVP) ; COMPUTE CURRENT # OF BINDINGS
\r
99 SUB B,C ; TOTAL WORDS ATOM STORAGE
\r
100 IDIVI B,6 ; COMPUTE # OF SLOTS
\r
102 HRRZ A,GLOBASE+1(TVP) ; COMPUTE TOTAL # OF GLOBAL SLOTS
\r
103 HLRE 0,GLOBASE+1(TVP)
\r
104 SUB A,0 ; POINT TO DOPE WORD
\r
106 ASH B,-2 ; # OF GVAL SLOTS
\r
108 HRRZ 0,GLOBASE+1(TVP) ; COMPUTE # OF GVAL SLOTS IN USE
\r
109 HRRZ A,GLOBSP+1(TVP)
\r
111 ASH A,-2 ; NEGATIVE # OF SLOTS USED
\r
114 HRRZ A,TYPBOT+1(TVP) ; GET LENGTH OF TYPE VECTOR
\r
115 HLRE 0,TYPBOT+1(TVP)
\r
117 HLRZ B,1(A) ; # OF WORDS IN TYPE-VECTOR
\r
118 IDIVI B,2 ; CONVERT TO # OF TYPES
\r
120 HLRE 0,TYPVEC+1(TVP) ; LENGTH OF VISABLE TYPE-VECTOR
\r
122 IDIVI 0,2 ; GET # OF TYPES
\r
124 MOVE 0,CODTOP ; GET LENGTH OF STATIONARY IMPURE STORAGE
\r
126 SETZB B,D ; ZERO OUT MAXIMUM
\r
128 LOOPC: HLRZ 0,(C) ; GET BLK LENGTH
\r
129 ADD D,0 ; ADD # OF WORDS IN BLOCK
\r
130 CAMGE B,0 ; SEE IF NEW MAXIMUM
\r
132 HRRZ C,(C) ; POINT TO NEXT BLOCK
\r
133 JUMPN C,LOOPC ; REPEAT
\r
136 HLRE 0,P ; GET AMOUNT OF ROOM LEFT ON P
\r
140 PUSHJ P,GCSET ; FIX UP BLOAT-STAT PARAMETERS
\r
141 MOVSI C,BSTGC ; SET UP BLT FOR GC FIGURES
\r
142 HRRZ B,(P) ; RESTORE B
\r
145 HRLI C,BSTAT ; MODIFY BLT FOR STATS
\r
146 ADDI C,STATGC ; B HAS ELEMENTS
\r
147 BLT C,(B)STATGC+STATNO-1
\r
149 HRLM 0,(B)STATNO+STATGC ; MOVE IN UTYPE
\r
151 POP P,A ; RESTORE TYPE-WORD
\r
155 ; THIS IS THE SCHEME USED TO UPDATE CERTAIN IMFORMATION USED BY THE
\r
156 ; BLOAT-SPEC ROUTINE TO GIVE USERS IMFORMATION ABOUT USE OF SPACE BY
\r
159 GCRSET: SETZM GCNO ; CALL FROM INIT, ZAP ALL 1ST
\r
160 MOVE 0,[GCNO,,GCNO+1]
\r
163 GCSET: MOVE A,VECBOT ; COMPUTE FREE SPACE AVAILABLE
\r
167 MOVEM A,MAXFRE ; MODIFY MAXIMUM
\r
168 HLRE A,TP ; FIND THE DOPE WORD OF THE TP STACK
\r
170 ADDI A,1(TP) ; CLOSE TO DOPE WORD
\r
172 ADDI A,PDLBUF ; NOW AT REAL DOPE WORD
\r
173 HLRZ B,(A) ; GET LENGTH OF TP-STACK
\r
175 CAMLE B,CTPMX ; SEE IF THIS IS THE BIGGEST TP
\r
177 HLRE B,P ; FIND DOPE WORD OF P-STACK
\r
179 ADDI B,1(P) ; CLOSE TO IT
\r
180 CAME B,PGROW ; SEE IF THE STACK IS BLOWN
\r
181 ADDI B,PDLBUF ; POINTING TO IT
\r
182 HLRZ A,(B) ; GET IN LENGTH
\r
184 CAMLE A,CPMX ; SEE IF WE HAVE THE BIGGEST P STACK
\r
189 .GLOBAL PGFIND,PGGIVE,PGTAKE,PGINT
\r
191 ; FIND AND ALLOCATE AS MANY CONTIGUOUS PAGES AS INDICATED BY REG A
\r
192 ; RETURN THE NUMBER (0-255.) OF THE FIRST SUCH PAGE IN REG B
\r
193 ; RETURN -1 IN REG B IF NONE FOUND
\r
197 PUSHJ P,PGFND1 ; SEE IF ALREADY ENOUGH
\r
198 SKIPL B ; SKIP IF LOST
\r
205 MOVE C,PURBOT ; CHECK IF ROOM AT ALL
\r
206 SUB C,P.TOP ; TOTAL SPACE
\r
207 MOVEI D,(C) ; COPY FOR CONVERSION TO PAGES
\r
209 CAIGE C,(A) ; SKIP IF COULD WIN
\r
212 MOVNS A ; MOVE PURE AREA DOWN "A" PAGES
\r
214 MOVE B,PURTOP ; GET FIRST PAGE ALLOCATED
\r
215 ASH B,-10. ; TO PAGE #
\r
219 PUSHJ P,RBLDM ; GET A NEW VALUE FOR M
\r
225 PUSH P,[-1] ;POSSIBLE CONTENTS FOR REG B
\r
226 PUSH P,A ;SAVE LENGTH OF BLOCK DESIRED FOR LATER USE
\r
227 SETZB B,C ;INITIAL SECTION AND PAGE NUMBERS
\r
228 MOVEI 0,0 ;COUNT OF PAGES ALREADY FOUND
\r
230 PLOOP: TDNE E,D ;FREE PAGE ?
\r
232 JUMPN 0,NFIRST ;FIRST FREE PAGE OF A BLOCK ?
\r
233 MOVEI A,(B) ;YES SAVE ADDRESS OF PAGE IN REG A
\r
237 CAML 0,(P) ;TEST IF ENOUGH PAGES HAVE BEEN FOUND
\r
238 JRST PWIN ;YES, FINISHED
\r
240 NOTFRE: MOVEI 0,0 ;RESET COUNT
\r
241 PUSHJ P,PNEXT ;NEXT PAGE
\r
242 JRST PLOSE ;NONE--LOSE RETURNING -1 IN REG B
\r
245 PWIN: MOVEI B,(A) ;GET WINNING ADDRESS
\r
246 MOVEM B,(P)-1 ;RETURN ADDRESS OF WINNING PAGE
\r
247 MOVE A,(P) ;RELOAD LENGTH OF BLOCK OF PAGES
\r
248 MOVE 0,[TDO E,D] ;INST TO SET "BUSY" BITS
\r
251 ;CLAIM OR RETURN TO FREE STORAGE AS MANY CONTIGUOUS PAGES AS INDICATED BY REG A
\r
252 ;THE NUMBER (0 - 255.) OF THE FIRST SUCH PAGE IS IN REG B
\r
253 PGGIVE: MOVE 0,[TDZ E,D] ;INST TO SET "FREE" BITS
\r
255 PGTAKE: MOVE 0,[TDO E,D] ;INST TO SET "BUSY" BITS
\r
268 RTL: XCT 0 ;SET APPROPRIATE BIT
\r
269 PUSHJ P,PNEXT ;NEXT PAGE'S BIT
\r
270 JUMPG A,FPLOSS ;TOO MANY ?
\r
272 MOVEM E,PMAP(B) ;REPLACE BIT MASK
\r
281 PINIT: MOVE E,PMAP(B) ;GET BITS FOR THIS SECTION
\r
282 HRLZI D,400000 ;BIT MASK
\r
284 LSH D,(C) ;SHIFT TO APPROPRIATE BIT POSITION
\r
288 PNEXT: AOS (P) ;FOR SKIP RETURN ON EXPECTED SUCCESS
\r
289 LSH D,-1 ;CONSIDER NEXT PAGE
\r
290 CAIGE C,31. ;FINISHED WITH THIS SECTION ?
\r
291 AOJA C,CPOPJ ;NO, INCREMENT AND CONTINUE
\r
292 MOVEM E,PMAP(B) ;REPLACE BIT MASK
\r
294 CAIGE B,7. ;LAST SECTION ?
\r
295 AOJA B,PINIT ;NO, INCREMENT AND CONTINUE
\r
296 SOS (P) ;YES, UNDO SKIP RETURN
\r
299 FPLOSS: FATAL PAGE LOSSAGE
\r
301 PGINT: MOVEI B,HIBOT ;INITIALIZE MUDDLE'S PAGE MAP TABLE
\r
302 IDIVI B,2000 ;FIRST PAGE OF PURE CODE
\r
306 SUBI A,(B) ;NUMBER OF SUCH PAGES
\r
307 PUSHJ P,PGTAKE ;MARK THESE PAGES AS TAKEN
\r
309 ; USER GARBAGE COLLECTOR INTERFACE
\r
317 PUSHJ P,GETFIX ; GET FREEE MIN IF GIVEN
\r
319 ADD AB,[2,,2] ; NEXT ARG
\r
320 JUMPGE AB,GC1 ; NOT SUPPLIED
\r
321 PUSHJ P,GETFIX ; GET FREDIF
\r
323 GC1: PUSHJ P,COMPRM ; GET CURRENT USED CORE
\r
326 MOVEM A,GCHAIR ; FORCE FLUSH OF VALS ASSOCS
\r
327 MOVE C,[11,,0] ; INDICATOR FOR AGC
\r
328 PUSHJ P,AGC ; COLLECT THAT TRASH
\r
329 SKIPGE A ; SKIP IF OK
\r
330 PUSHJ P,FULLOS ; COMPLAIN ABOUT LACK OF SPACE
\r
331 PUSHJ P,COMPRM ; HOW MUCH ROOM NOW?
\r
332 POP P,B ; RETURN AMOUNT
\r
338 COMPRM: MOVE A,PARTOP ; USED SPACE
\r
344 MFUNCTION GCDMON,SUBR,[GC-MON]
\r
348 SETZM GCMONF ; ASSUME FALSE
\r
355 .GLOBAL EVATYP,APLTYP,PRNTYP
\r
357 \fMFUNCTION BLOAT,SUBR
\r
360 MOVEI C,0 ; FLAG TO SAY WHETHER NEED A GC
\r
361 MOVSI E,-NBLO ; AOBJN TO BLOATER TABLE
\r
363 BLOAT2: JUMPGE AB,BLOAT1 ; ALL DONE?
\r
364 PUSHJ P,NXTFIX ; GET NEXT BLOAT PARAM
\r
365 PUSHJ P,@BLOATER(E) ; DISPATCH
\r
366 AOBJN E,BLOAT2 ; COUNT PARAMS SET
\r
368 JUMPL AB,TMA ; ANY LEFT...ERROR
\r
369 BLOAT1: JUMPE C,BLOATD ; DONE, NO GC NEEDED
\r
371 MOVEM 0,GCHAIR ; FORCE HAIR TO OCCUR
\r
372 MOVE C,E ; MOVE IN INDICATOR
\r
373 HRLI C,1 ; INDICATE THAT IT COMES FROM BLOAT
\r
374 PUSHJ P,AGC ; DO ONE
\r
376 PUSHJ P,FULLOS ; NO CORE LEFT
\r
377 SKIPE A,TPBINC ; SMASH POINNTERS
\r
378 ADDM A,TPBASE+1(PVP)
\r
379 SKIPE A,GLBINC ; GLOBAL SP
\r
380 ADDM A,GLOBASE+1(TVP)
\r
382 ADDM A,TYPBOT+1(TVP)
\r
383 SETZM TPBINC ; RESET PARAMS
\r
387 BLOATD: MOVE B,VECBOT
\r
389 MOVSI A,TFIX ; RETURN CORE FOUND
\r
392 ; TABLE OF BLOAT ROUTINES
\r
410 ; BLOAT MAIN STORAGE AREA
\r
412 MAINB: MOVE D,VECBOT ; COMPUTE CURRENT ROOM
\r
414 CAMGE A,D ; NEED MORE?
\r
415 POPJ P, ; NO, LEAVE
\r
416 MOVEM A,GETNUM ; SAVE
\r
417 AOJA C,CPOPJ ; LEAVE SETTING C
\r
419 ; BLOAT TP STACK (AT TOP)
\r
421 TPBLO: HLRE D,TP ; GET -SIZE
\r
423 ADDI D,1(TP) ; POINT TO DOPE (ALMOST)
\r
424 CAME D,TPGROW ; BLOWN?
\r
425 ADDI D,PDLBUF ; POINT TO REAL DOPE WORD
\r
426 CAMG A,B ; SKIP IF GROWTH NEEDED
\r
428 ASH A,-6 ; CONVERT TO 64 WD BLOCKS
\r
431 DPB A,[111100,,-1(D)] ; SMASH SPECS IN
\r
434 ; BLOAT TOP LEVEL LOCALS
\r
436 LOBLO: IMULI A,6 ; 6 WORDS PER BINDING
\r
437 HRRZ 0,TPBASE+1(PVP)
\r
438 HRRZ B,SPBASE+1(PVP) ; ROOM AVAIL TO E
\r
440 SUBI A,(B) ; HOW MUCH MORE?
\r
441 JUMPLE A,CPOPJ ; NONE NEEDED
\r
444 DPB A,[1100,,-1(D)] ; SMASH
\r
447 ; GLOBAL SLOT GROWER
\r
449 GLBLO: ASH A,2 ; 4 WORDS PER VAR
\r
450 MOVE D,GLOBASE+1(TVP) ; CURRENT LIMITS
\r
451 HRRZ B,GLOBSP+1(TVP)
\r
453 SUBI A,(B) ; NEW AMOUNT NEEDED
\r
455 MOVEI B,GLBINC ; WHERE TO KEEP UPDATE
\r
456 PUSHJ P,NUMADJ ; FIX NUMBER
\r
458 SUB D,0 ; POINT TO DOPE
\r
459 DPB A,[1100,,(D)] ; AND SMASH
\r
462 ; HERE TO GROW TYPE VECTOR (AND FRIENDS)
\r
464 TYBLO: ASH A,1 ; TWO WORD PER TYPE
\r
465 HRRZ B,TYPBOT+1(TVP) ; FIND CURRENT ROOM
\r
466 MOVE D,TYPVEC+1(TVP)
\r
468 SUBI A,(B) ; EXTRA NEEDED TO A
\r
469 JUMPLE A,CPOPJ ; NONE NEEDED, LEAVE
\r
470 MOVEI B,TYPINC ; WHERE TO STASH SPEC
\r
471 PUSHJ P,NUMADJ ; FIX NUMBER
\r
472 HLRE 0,D ; POINT TO DOPE
\r
475 SKIPE D,EVATYP+1(TVP) ; GROW AUX TYPE VECS IF NEEDED
\r
477 SKIPE D,APLTYP+1(TVP)
\r
479 SKIPE D,PRNTYP+1(TVP)
\r
483 ; HERE TO CREATE STORAGE SPACE
\r
485 STBLO: MOVE D,PARBOT ; HOW MUCH NOW HERE
\r
487 SUBI A,(D) ; MORE NEEDED?
\r
489 MOVEM A,PARNEW ; FORCE PAIR SPACE TO MOVE ON OUT
\r
496 SUBI D,5 ; FUDGE FOR THIS CALL
\r
499 ADDI B,1(P) ; POINT TO DOPE
\r
500 CAME B,PGROW ; BLOWN?
\r
501 ADDI B,PDLBUF ; NOPE, POIN TO REAL D.W.
\r
502 ASH A,-6 ; TO 64 WRD BLOCKS
\r
503 CAILE A,377 ; IN RANGE?
\r
505 DPB A,[111100,,-1(B)]
\r
510 SFREM: MOVEM A,FREMIN
\r
515 SFRED: MOVEM A,FREDIF
\r
518 ; SET LVAL INCREMENT
\r
520 SLVL: IMULI A,6 ; CALCULATE AMOUNT TO GROW B
\r
521 IDIVI A,64. ; # OF GROW BLOCKS NEEDED
\r
522 CAIE B,0 ; DOES B HAVE A REMAINDER
\r
523 ADDI A,1 ; IF SO ADD A BLOCK
\r
527 ; SET GVAL INCREMENT
\r
529 SGVL: IDIVI A,16. ; CALCULATE NUMBER OF GROW BLOCKS NEEDED
\r
531 ADDI A,1 ; COMPENSATE FOR EXTRA
\r
535 ; SET TYPE INCREMENT
\r
537 STYP: IDIVI A,32. ; CALCULATE NUMBER OF GROW BLOCKS NEEDED
\r
539 ADDI A,1 ; COMPENSATE FOR EXTRA
\r
543 ; SET STORAGE INCREMENT
\r
545 SSTO: IDIVI A,2000 ; # OF BLOCKS
\r
546 CAIE B,0 ; REMAINDER?
\r
548 IMULI A,2000 ; CONVERT BACK TO WORDS
\r
553 ; GET NEXT (FIX) ARG
\r
555 NXTFIX: PUSHJ P,GETFIX
\r
559 ; ROUTINE TO GET POS FIXED ARG
\r
561 GETFIX: GETYP A,(AB)
\r
569 ; GET NUMBERS FIXED UP FOR GROWTH FIELDS
\r
571 NUMADJ: ADDI A,77 ; ROUND UP
\r
572 ANDCMI A,77 ; KILL CRAP
\r
574 MOVNS A ; COMPUTE ADD FACTOR FOR SPEC. POINTER UPDATE
\r
576 MOVEM A,(B) ; AND STASH IT
\r
578 ASH A,-6 ; TO 64 WD BLOCKS
\r
579 CAILE A,377 ; CHECK FIT
\r
583 ; DO SYMPATHETIC GROWTHS
\r
587 DPB A,[111100,,(D)]
\r
590 \f;FUNCTION TO CONSTRUCT A LIST
\r
592 MFUNCTION CONS,SUBR
\r
595 GETYP A,2(AB) ;GET TYPE OF 2ND ARG
\r
596 CAIE A,TLIST ;LIST?
\r
597 JRST WTYP2 ;NO , COMPLAIN
\r
598 MOVE C,(AB) ; GET THING TO CONS IN
\r
600 HRRZ E,3(AB) ; AND LIST
\r
601 PUSHJ P,ICONS ; INTERNAL CONS
\r
604 ; COMPILER CALL TO CONS
\r
611 ; INTERNAL CONS TO NIL--INCONS
\r
615 ; INTERNAL CONS--ICONS; C,D VALUE, E CDR
\r
617 ICONS: GETYP A,C ; CHECK TYPE OF VAL
\r
618 PUSHJ P,NWORDT ; # OF WORDS
\r
619 SOJN A,ICONS1 ; JUMP IF DEFERMENT NEEDED
\r
620 PUSHJ P,ICELL2 ; NO DEFER, GET 2 WORDS FROM PAIR SPACE
\r
621 JRST ICONS2 ; NO CORE, GO GC
\r
622 HRRI C,(E) ; SET UP CDR
\r
623 ICONS3: MOVEM C,(B) ; AND STORE
\r
625 TLPOPJ: MOVSI A,TLIST
\r
628 ; HERE IF CONSING DEFERRED
\r
630 ICONS1: MOVEI A,4 ; NEED 4 WORDS
\r
631 PUSHJ P,ICELL ; GO GET 'EM
\r
632 JRST ICONS2 ; NOT THERE, GC
\r
633 HRLI E,TDEFER ; CDR AND DEFER
\r
634 MOVEM E,(B) ; STORE
\r
635 MOVEI E,2(B) ; POINT E TO VAL CELL
\r
637 MOVEM C,(E) ; STORE VALUE
\r
643 ; HERE TO GC ON A CONS
\r
645 ICONS2: PUSH TP,C ; SAVE VAL
\r
648 PUSH TP,E ; SAVE VITAL STUFF
\r
649 MOVEM A,GETNUM ; AMOUNT NEEDED
\r
650 MOVE C,[3,,1] ; INDICATOR FOR AGC
\r
651 PUSHJ P,AGC ; ATTEMPT TO WIN
\r
652 SKIPGE A ; SKIP IF WON
\r
654 MOVE D,-2(TP) ; RESTORE VOLATILE STUFF
\r
658 JRST ICONS ; BACK TO DRAWING BOARD
\r
660 ; SUBROUTINE TO ALLOCATE WORDS IN PAIR SPACE. CALLS AGC IF NEEDED
\r
662 CELL2: MOVEI A,2 ; USUAL CASE
\r
663 CELL: PUSHJ P,ICELL ; INTERNAL
\r
667 MOVEM A,GETNUM ; AMOUNT REQUIRED
\r
668 PUSH P,A ; PREVENT AGC DESTRUCTION
\r
669 MOVE C,[3,,1] ; INDICATOR FOR AGC
\r
671 SKIPGE A ; SKIP IF WINNER
\r
672 PUSHJ P,FULLOS ; REPORT TROUBLE
\r
674 JRST CELL ; AND TRY AGAIN
\r
676 ; INTERNAL CELL GETTER, SKIPS IF ROO EXISTS, ELSE DOESN'T
\r
678 ICELL2: MOVEI A,2 ; MOST LIKELY CAE
\r
680 JRST ICELRC ;SEE IF WE CAN RE-USE A RECYCLE CELL
\r
681 MOVE B,PARTOP ; GET TOP OF PAIRS
\r
683 CAMLE B,VECBOT ; SKIP IF OK.
\r
685 EXCH B,PARTOP ; SETUP NEW PARTOP AND RETURN POINTER
\r
686 PUSH P,B ; MODIFY TOTAL # OF FREE WORDS
\r
691 JRST CPOPJ1 ; SKIP RETURN
\r
694 JRST ICELL+2 ;IF HE DOESNT WANT TWO, USE OLD METHOD
\r
699 SETZM (B) ;GIVE HIM A CLEAN RECYCLED CELL
\r
701 JRST CPOPJ ;THAT IT
\r
703 ;SUBROUTINES TO RETURN WORDS NEEDED BASED ON TYPE OR SAT
\r
705 NWORDT: PUSHJ P,SAT ;GET STORAGE ALLOC TYPE
\r
706 NWORDS: CAIG A,NUMSAT ; TEMPLATE?
\r
707 SKIPL MKTBS(A) ;-ENTRY IN TABLE MEANS 2 NEEDED
\r
708 SKIPA A,[1] ;NEED ONLY 1
\r
712 \f;FUNCTION TO BUILD A LIST OF MANY ELEMENTS
\r
714 MFUNCTION LIST,SUBR
\r
718 LIST12: HLRE A,AB ;GET -NUM OF ARGS
\r
719 SKIPE RCL ;SEE IF WE WANT TO DO ONE AT A TIME
\r
720 JRST LST12R ;TO GET RECYCLED CELLS
\r
722 JUMPE A,LISTN ;JUMP IF 0
\r
723 PUSHJ P,CELL ;GET NUMBER OF CELLS
\r
726 PUSH TP,(P) ;SAVE IT
\r
729 LSH A,-1 ;NUMBER OF REAL LIST ELEMENTS
\r
731 CHAINL: ADDI B,2 ;LOOP TO CHAIN ELEMENTS
\r
732 HRRZM B,-2(B) ;CHAIN LAST ONE TO NEXT ONE
\r
733 SOJG A,.-2 ;LOOP TIL ALL DONE
\r
734 CLEARM B,-2(B) ;SET THE LAST CDR TO NIL
\r
736 ; NOW LOBEER THE DATA IN TO THE LIST
\r
738 MOVE D,AB ; COPY OF ARG POINTER
\r
739 MOVE B,(TP) ;RESTORE LIS POINTER
\r
740 LISTLP: GETYP A,(D) ;GET TYPE
\r
741 PUSHJ P,NWORDT ;GET NUMBER OF WORDS
\r
742 SOJN A,LDEFER ;NEED TO DEFER POINTER
\r
743 GETYP A,(D) ;NOW CLOBBER ELEMENTS
\r
745 MOVE A,1(D) ;AND VALUE..
\r
747 LISTL2: HRRZ B,(B) ;REST B
\r
748 ADD D,[2,,2] ;STEP ARGS
\r
753 SUB TP,[2,,2] ; CLEANUP STACK
\r
757 LST12R: ASH A,-1 ;ONE AT A TIME TO GET RECYCLED CELLS
\r
759 PUSH P,A ;SAVE COUNT ON STACK
\r
763 MOVE E,B ;LOOP AND CHAIN TOGETHER
\r
766 PUSH TP,-1(P) ;PUSH ON THE TYPE WE WANT
\r
768 SUB P,[2,,2] ;CLEAN UP AFTER OURSELVES
\r
769 JRST LISTLP-2 ;AND REJOIN MAIN STREAM
\r
772 ; MAKE A DEFERRED POINTER
\r
774 LDEFER: PUSH TP,$TLIST ;SAVE CURRENT POINTER
\r
776 MOVEM D,1(TB) ; SAVE ARG HACKER
\r
779 GETYPF A,(D) ;GET FULL DATA
\r
783 MOVE C,(TP) ;RESTORE LIST POINTER
\r
784 MOVEM B,1(C) ;AND MAKE THIS BE THE VALUE
\r
786 HLLM A,(C) ;AND STORE IT
\r
797 MFUNCTION FORM,SUBR
\r
804 \f; COMPILERS CALLS TO FORM AND LIST A/ COUNT ELEMENTS ON STACK
\r
816 IILST: JUMPE A,IILST0 ; NIL WHATSIT
\r
821 PUSHJ P,ICONS ; CONS 'EM UP
\r
832 \f;FUNCTION TO BUILD AN IMPLICIT LIST
\r
834 MFUNCTION ILIST,SUBR
\r
837 ILIST2: JUMPGE AB,TFA ;NEED AT LEAST ONE ARG
\r
838 CAMGE AB,[-4,,0] ;NO MORE THAN TWO ARGS
\r
840 PUSHJ P,GETFIX ; GET POS FIX #
\r
841 JUMPE A,LISTN ;EMPTY LIST ?
\r
842 CAML AB,[-2,,0] ;ONLY ONE ARG?
\r
844 PUSH P,A ;SAVE THE CURRENT VALUE OF LENGTH FOR LOOP ITERATION
\r
845 ILIST0: PUSH TP,2(AB)
\r
853 ILIST1: MOVE C,(AB)+1 ;REGOBBLE LENGTH
\r
855 ILIST3: POP P,A ; GET FINAL TYPE
\r
859 LOSEL: PUSH P,A ; SAVE COUNT
\r
862 LOSEL1: SETZB C,D ; TLOSE,,0
\r
873 MFUNCTION IFORM,SUBR
\r
879 \f; IVECTOR AND IUVECTOR--GET VECTOR AND UVECTOR OF COMPUTED VALUES
\r
881 MFUNCTION VECTOR,SUBR,[IVECTOR]
\r
886 MFUNCTION UVECTOR,SUBR,[IUVECTOR]
\r
890 JUMPGE AB,TFA ; AT LEAST ONE ARG
\r
891 CAMGE AB,[-4,,0] ; NOT MORE THAN 2
\r
893 PUSHJ P,GETFIX ; GET A POS FIXED NUMBER
\r
894 LSH A,(C) ; A-> NUMBER OF WORDS
\r
895 PUSH P,C ; SAVE FOR LATER
\r
896 PUSHJ P,IBLOCK ; GET BLOCK (TURN ON BIT APPROPRIATELY)
\r
898 HLRE A,B ; START TO
\r
899 SUBM B,A ; FIND DOPE WORD
\r
901 MOVSI D,400000 ; GET NOT UNIFORM BIT
\r
902 MOVEM D,(A) ; INTO DOPE WORD
\r
903 SKIPA A,$TVEC ; GET TYPE
\r
904 VECTO4: MOVSI A,TUVEC
\r
905 CAML AB,[-2,,0] ; SKIP IF ARGS NEED TO BE HACKED
\r
907 JUMPGE B,FINIS ; DON'T EVAL FOR EMPTY CASE
\r
909 PUSH TP,A ; SAVE THE VECTOR
\r
915 JUMPGE B,FINIS ; EMPTY VECTOR, LEAVE
\r
916 INLP: PUSHJ P,IEVAL ; EVAL EXPR
\r
919 ADD C,[2,,2] ; BUMP VECTOR
\r
921 JUMPL C,INLP ; IF MORE DO IT
\r
923 GETVEC: MOVE A,-3(TP)
\r
928 ; HERE TO FILL UP A UVECTOR
\r
930 UINIT: PUSHJ P,IEVAL ; HACK THE 1ST VALUE
\r
931 GETYP A,A ; GET TYPE
\r
932 PUSH P,A ; SAVE TYPE
\r
933 PUSHJ P,NWORDT ; SEE IF IT CAN BE UNIFORMED
\r
934 SOJN A,CANTUN ; COMPLAIN
\r
935 STJOIN: MOVE C,(TP) ; RESTORE POINTER
\r
936 ADD C,1(AB) ; POINT TO DOPE WORD
\r
937 MOVE A,(P) ; GET TYPE
\r
938 HRLZM A,(C) ; STORE IN D.W.
\r
939 MOVE C,(TP) ; GET BACK VECTOR
\r
941 JRST UINLP1 ; START FILLING UV
\r
944 UINLP: MOVEM C,(TP) ; SAVE PNTR
\r
945 PUSHJ P,IEVAL ; EVAL THE EXPR
\r
946 GETYP A,A ; GET EVALED TYPE
\r
947 CAIE A,@(P) ; WINNER?
\r
948 JRST WRNGSU ; SERVICE ERROR FOR UVECTOR,STORAGE
\r
949 UINLP1: MOVEM B,(C) ; STORE
\r
951 GETVE1: SUB P,[1,,1]
\r
952 JRST GETVEC ; AND RETURN VECTOR
\r
954 IEVAL: PUSH TP,2(AB)
\r
960 ; ISTORAGE -- GET STORAGE OF COMPUTED VALUES
\r
962 MFUNCTION ISTORAGE,SUBR
\r
965 CAMGE AB,[-4,,0] ; AT LEAST ONE ARG
\r
967 PUSHJ P,GETFIX ; POSITIVE COUNT FIRST ARG
\r
968 PUSHJ P,CAFRE ; GET CORE
\r
969 MOVN B,1(AB) ; -COUNT
\r
970 HRL A,B ; PUT IN LHW (A)
\r
972 HRLI B,2(B) ; LENGTH + 2
\r
973 ADDI B,(A) ; MAKE POINTER TO DOPE WORDS
\r
974 HLLZM B,1(B) ; PUT TOTAL LENGTH IN 2ND DOPE
\r
975 HRRM A,1(B) ; PUT ADDRESS IN RHW (STORE DOES THIS TOO).
\r
978 CAML AB,[-2,,0] ; SECOND ARG TO EVAL?
\r
979 JRST FINIS ; IF NOT, RETURN EMPTY
\r
984 PUSHJ P,IEVAL ; EVALUATE FOR FIRST VALUE
\r
986 PUSH P,A ; FOR COMPARISON LATER
\r
989 JRST STJOIN ;TREAT LIKE A UVECTOR
\r
990 ; IF NOT 1-WORD TYPES, CANNOT STORE, SO COMPLAIN
\r
991 PUSHJ P,FREESV ; FREE STORAGE VECTOR
\r
993 PUSH TP,EQUOTE DATA-CAN'T-GO-IN-STORAGE
\r
996 ; FOR STORAGE, MUST FREE THE CORE ELSE IT IS LOST (NO GC)
\r
997 FREESV: MOVE A,1(AB) ; GET COUNT
\r
998 ADDI A,2 ; FOR DOPE
\r
999 HRRZ B,(TP) ; GET ADDRESS
\r
1000 PUSHJ P,CAFRET ; FREE THE CORE
\r
1003 \f; INTERNAL VECTOR ALLOCATOR. A/SIZE OF VECTOR (NOT INCLUDING DOPE WORDS)
\r
1005 IBLOK1: ASH A,1 ; TIMES 2
\r
1006 GIBLOK: TLOA A,400000 ; FUNNY BIT
\r
1007 IBLOCK: TLZ A,400000 ; NO BIT ON
\r
1008 ADDI A,2 ; COMPENSATE FOR DOPE WORDS
\r
1009 IBLOK2: MOVE B,VECBOT ; POINT TO BOTTOM OF SPACE
\r
1010 SUBI B,(A) ; SUBTRACT NEEDED AMOUNT
\r
1011 CAMGE B,PARTOP ; SKIP IF NO GC NEEDED
\r
1013 EXCH B,VECBOT ; WIN, GET POINTER TO BLOCK AND UPDATE VECBOT
\r
1019 HRLZM A,-1(B) ; STORE LENGTH IN DOPE WORD
\r
1020 HLLZM A,-2(B) ; AND BIT
\r
1021 HRRO B,VECBOT ; POINT TO START OF VECTOR
\r
1022 TLC B,-3(A) ; SETUP COUNT
\r
1029 ; HERE TO DO A GC ON A VECTOR ALLOCATION
\r
1031 IVECT1: PUSH P,A ; SAVE DESIRED LENGTH
\r
1032 HRRZM A,GETNUM ; AND STORE AS DESIRED AMOUNT
\r
1033 MOVE C,[4,,1] ; GET INDICATOR FOR AGC
\r
1036 PUSHJ P,FULLOS ; LOST, COMPLAIN
\r
1041 ; INTERNAL EVECTOR (CALLED FROM READ) A/ #OF THINGS
\r
1042 ; ITEMS ON TOP OF STACK
\r
1044 IEVECT: ASH A,1 ; TO NUMBER OF WORDS
\r
1046 PUSHJ P,IBLOCK ; GET VECTOR
\r
1047 HLRE D,B ; FIND DW
\r
1048 SUBM B,D ; A POINTS TO DW
\r
1050 MOVEM 0,(D) ; CLOBBER NON UNIF BIT
\r
1051 POP P,A ; RESTORE COUNT
\r
1052 JUMPE A,IVEC1 ; 0 LNTH, DONE
\r
1053 MOVEI C,(TP) ; BUILD BLT
\r
1054 SUBI C,(A)-1 ; C POINTS TO 1ST ITEM ON STACK
\r
1056 HRRI C,(B) ; B/ SOURCE,,DEST
\r
1057 BLT C,-1(D) ; XFER THE DATA
\r
1059 SUB TP,A ; FLUSH STACKAGE
\r
1060 IVEC1: MOVSI A,TVEC
\r
1071 \f; INTERNAL CALL TO EUVECTOR
\r
1073 IEUVEC: PUSH P,A ; SAVE LENGTH
\r
1076 JUMPE A,IEUVE1 ; EMPTY, LEAVE
\r
1077 ASH A,1 ; NOW FIND STACK POSITION
\r
1078 MOVEI C,(TP) ; POINT TO TOP
\r
1079 MOVE D,B ; COPY VEC POINTER
\r
1080 SUBI C,-1(A) ; POINT TO 1ST DATUM
\r
1081 GETYP A,(C) ; CHECK IT
\r
1083 SOJN A,CANTUN ; WONT FIT
\r
1086 IEUVE2: GETYP 0,(C) ; TYPE OF EL
\r
1087 CAIE 0,(E) ; MATCH?
\r
1090 MOVEM 0,(D) ; CLOBBER
\r
1092 AOBJN D,IEUVE2 ; LOOP
\r
1093 HRLZM E,(D) ; STORE UTYPE
\r
1094 IEUVE1: POP P,A ; GET COUNY
\r
1095 ASH A,1 ; MUST FLUSH 2 TIMES # OF ELEMENTS
\r
1097 SUB TP,A ; CLEAN UP STACK
\r
1103 CIUVEC: SUBM M,(P)
\r
1107 MFUNCTION EVECTOR,SUBR,[VECTOR]
\r
1111 PUSH P,A ;SAVE NUMBER OF WORDS
\r
1112 PUSHJ P,IBLOCK ; GET WORDS
\r
1113 MOVEI D,-1(B) ; SETUP FOR BLT AND DOPE CLOBBER
\r
1114 JUMPGE B,FINISV ;DONT COPY A ZERO LENGTH VECTOR
\r
1116 HRLI C,(AB) ;START BUILDING BLT POINTER
\r
1117 HRRI C,(B) ;TO ADDRESS
\r
1118 ADDI D,@(P) ;SET D TO FINAL ADDRESS
\r
1120 FINISV: MOVSI 0,400000
\r
1121 MOVEM 0,1(D) ; MARK AS GENERAL
\r
1128 \f;EXPLICIT VECTORS FOR THE UNIFORM CSE
\r
1130 MFUNCTION EUVECTOR,SUBR,[UVECTOR]
\r
1133 HLRE A,AB ;-NUM OF ARGS
\r
1135 ASH A,-1 ;NEED HALF AS MANY WORDS
\r
1137 JUMPGE AB,EUV1 ; DONT CHECK FOR EMPTY
\r
1138 GETYP A,(AB) ;GET FIRST ARG
\r
1139 PUSHJ P,NWORDT ;SEE IF NEEDS EXTRA WORDS
\r
1142 PUSHJ P,IBLOCK ; GET VECT
\r
1145 GETYP C,(AB) ;GET THE FIRST TYPE
\r
1146 MOVE D,AB ;COPY THE ARG POINTER
\r
1147 MOVE E,B ;COPY OF RESULT
\r
1149 EUVLP: GETYP 0,(D) ;GET A TYPE
\r
1151 JRST WRNGUT ;NO , LOSE
\r
1152 MOVE 0,1(D) ;GET GOODIE
\r
1153 MOVEM 0,(E) ;CLOBBER
\r
1154 ADD D,[2,,2] ;BUMP ARGS POINTER
\r
1157 HRLM C,(E) ;CLOBBER UNIFORM TYPE IN
\r
1158 FINISU: MOVSI A,TUVEC
\r
1161 WRNGSU: GETYP A,-1(TP)
\r
1163 JRST WRNGUT ;IF UVECTOR
\r
1164 PUSHJ P,FREESV ;FREE STORAGE VECTOR
\r
1166 PUSH TP,EQUOTE TYPES-DIFFER-IN-STORAGE-OBJECT
\r
1170 WRNGUT: PUSH TP,$TATOM
\r
1171 PUSH TP,EQUOTE TYPES-DIFFER-IN-UNIFORM-VECTOR
\r
1174 CANTUN: PUSH TP,$TATOM
\r
1175 PUSH TP,EQUOTE DATA-CANT-GO-IN-UNIFORM-VECTOR
\r
1178 BADNUM: PUSH TP,$TATOM
\r
1179 PUSH TP,EQUOTE NEGATIVE-ARGUMENT
\r
1181 \f; FUNCTION TO GROW A VECTOR
\r
1183 MFUNCTION GROW,SUBR
\r
1187 MOVEI D,0 ;STACK HACKING FLAG
\r
1188 GETYP A,(AB) ;FIRST TYPE
\r
1189 PUSHJ P,SAT ;GET STORAGE TYPE
\r
1190 GETYP B,2(AB) ;2ND ARG
\r
1191 CAIE A,STPSTK ;IS IT ASTACK
\r
1193 AOJA D,GRSTCK ;YES, WIN
\r
1194 CAIE A,SNWORD ;UNIFORM VECTOR
\r
1195 CAIN A,S2NWORD ;OR GENERAL
\r
1196 GRSTCK: CAIE B,TFIX ;IS 2ND FIXED
\r
1197 JRST WTYP2 ;COMPLAIN
\r
1199 CAIE B,TFIX ;3RD ARG
\r
1202 MOVEI E,1 ;UNIFORM/GENERAL FLAG
\r
1203 CAIE A,SNWORD ;SKIP IF UNIFORM
\r
1204 CAIN A,SPSTK ;DONT SKIP IF UNIFORM PDL
\r
1207 HRRZ B,1(AB) ;POINT TO START
\r
1208 HLRE A,1(AB) ;GET -LENGTH
\r
1209 SUB B,A ;POINT TO DOPE WORD
\r
1210 SKIPE D ;SKIP IF NOT STACK
\r
1211 ADDI B,PDLBUF ;FUDGE FOR PDL
\r
1212 HLLZS (B) ;ZERO OUT GROWTH SPECS
\r
1213 SKIPN A,3(AB) ;ANY TOP GROWTH?
\r
1214 JRST GROW1 ;NO, LOOK FOR BOTTOM GROWTH
\r
1215 ASH A,(E) ;MULT BY 2 IF GENERAL
\r
1216 ADDI A,77 ;ROUND TO NEAREST BLOCK
\r
1217 ANDCMI A,77 ;CLEAR LOW ORDER BITS
\r
1218 ASH A,9-6 ;DIVIDE BY 100 AND SHIFT TO POSTION
\r
1219 TRZE A,400000 ;CONVERT TO SIGN MAGNITUDE
\r
1221 TLNE A,-1 ;SKIP IF NOT TOO BIG
\r
1222 JRST GTOBIG ;ERROR
\r
1223 GROW1: SKIPN C,5(AB) ;CHECK LOW GROWTH
\r
1224 JRST GROW4 ;NONE, SKIP
\r
1225 ASH C,(E) ;GENRAL FUDGE
\r
1227 ANDCMI C,77 ;FUDGE FOR VALUE RETURN
\r
1228 PUSH P,C ;AND SAVE
\r
1229 ASH C,-6 ;DIVIDE BY 100
\r
1230 TRZE C,400 ;CONVERT TO SIGN MAGNITUDE
\r
1232 TDNE C,[-1,,777000] ;CHECK FOR OVERFLOW
\r
1234 GROW2: HLRZ E,1(B) ;GET TOTAL LENGTH OF VECTOR
\r
1236 HRLI E,(E) ;TO BOTH HALVES
\r
1237 ADDI E,1(B) ;POINTS TO TOP
\r
1239 ADD E,[PDLBUF,,0] ;YES, FUDGE LENGTH
\r
1240 SKIPL D,(P) ;SHRINKAGE?
\r
1241 JRST GROW3 ;NO, CONTINUE
\r
1243 HRLI D,(D) ;TO BOTH HALVES
\r
1244 ADD E,D ;POINT TO NEW LOW ADDR
\r
1245 GROW3: IORI A,(C) ;OR TOGETHER
\r
1246 HRRM A,(B) ;DEPOSIT INTO DOPEWORD
\r
1247 PUSH TP,(AB) ;PUSH TYPE
\r
1248 PUSH TP,E ;AND VALUE
\r
1249 JUMPE A,.+3 ;DON'T GC FOR NOTHING
\r
1250 MOVE C,[2,,0] ; GET INDICATOR FOR AGC
\r
1253 POP P,C ;RESTORE GROWTH
\r
1255 POP TP,B ;GET VECTOR POINTER
\r
1256 SUB B,C ;POINT TO NEW TOP
\r
1260 GROFUL: SUB P,[1,,1] ; CLEAN UP STACK
\r
1265 GTOBIG: PUSH TP,$TATOM
\r
1266 PUSH TP,EQUOTE ATTEMPT-TO-GROW-VECTOR-TOO-MUCH
\r
1268 GROW4: PUSH P,[0] ;0 BOTTOM GROWTH
\r
1271 FULLOS: PUSH TP,$TATOM ; GENERATE ERROR
\r
1273 AOJL A,CALER1 ; IF BAD, CALL ERROR
\r
1276 PUSH TP,TTOCHN(TVP) ; FORCE MESSAGES TO TTY
\r
1277 PUSH TP,TTOCHN+1(TVP)
\r
1278 PUSH TP,TTOCHN(TVP) ; FORCE MESSAGES TO TTY
\r
1279 PUSH TP,TTOCHN+1(TVP)
\r
1280 MCALL 1,TERPRI ; JUST PRINT MESSAGE
\r
1285 EQUOTE STILL-NO-STORAGE
\r
1287 EQUOTE STORAGE-LOW
\r
1289 \f; SUBROUTINE TO BUILD CHARACTER STRING GOODIES
\r
1291 MFUNCTION STRING,SUBR
\r
1295 MOVE B,AB ;COPY ARG POINTER
\r
1296 MOVEI C,0 ;INITIALIZE COUNTER
\r
1297 PUSH TP,$TAB ;SAVE A COPY
\r
1299 HLRE A,B ; GET # OF ARGS
\r
1301 ASH A,-1 ; 1/2 FOR # OF ARGS
\r
1305 IISTRN: SKIPN E,A ; SKIP IF ARGS EXIST
\r
1306 JRST MAKSTR ; ALL DONE
\r
1308 STRIN2: GETYP D,(B) ;GET TYPE CODE
\r
1309 CAIN D,TCHRS ;SINGLE CHARACTER?
\r
1311 CAIE D,TCHSTR ;OR STRING
\r
1312 JRST WRONGT ;NEITHER
\r
1313 HRRZ D,(B) ; GET CHAR COUNT
\r
1314 ADDI C,(D) ; AND BUMP
\r
1316 STRIN1: ADD B,[2,,2]
\r
1319 ; NOW GET THE NECESSARY VECTOR
\r
1321 MAKSTR: PUSH P,C ; SAVE CHAR COUNT
\r
1322 PUSH P,E ; SAVE ARG COUNT
\r
1323 MOVEI A,4(C) ; LNTH+4 TO A
\r
1328 JUMPGE B,DONEC ; 0 LENGTH, NO STRING
\r
1329 HRLI B,440700 ;CONVERT B TO A BYTE POINTER
\r
1330 MOVE C,(TP) ; POINT TO ARGS AGAIN
\r
1332 NXTRG1: GETYP D,(C) ;GET AN ARG
\r
1335 MOVE D,1(C) ; GET IT
\r
1336 IDPB D,B ;AND DEPOSIT IT
\r
1339 TRYSTR: MOVE E,1(C) ;GET BYTER
\r
1340 HRRZ 0,(C) ;AND COUNT
\r
1341 NXTCHR: SOJL 0,NXTARG ; IF RUNOUT, GET NEXT ARG
\r
1342 ILDB D,E ;AND GET NEXT
\r
1343 IDPB D,B ; AND DEPOSIT SAME
\r
1346 NXTARG: ADD C,[2,,2] ;BUMP ARG POINTER
\r
1350 DONEC: MOVSI C,TCHRS
\r
1351 HLLM C,(B) ;AND CLOBBER AWAY
\r
1352 HLRZ C,1(B) ;GET LENGTH BACK
\r
1356 HRLI B,440700 ;MAKE A BYTE POINTER
\r
1359 ; COMPILER'S CALL TO MAKE A STRING
\r
1361 CISTNG: SUBM M,(P)
\r
1362 MOVEI C,0 ; INIT CHAR COUNTER
\r
1363 MOVEI B,(A) ; SET UP STACK POINTER
\r
1364 ASH B,1 ; * 2 FOR NO. OF SLOTS
\r
1366 SUBM TP,B ; B POINTS TO ARGS
\r
1370 PUSHJ P,IISTRN ; MAKE IT HAPPEN
\r
1371 POP TP,TP ; FLUSH ARGS
\r
1374 \f;BUILD IMPLICT STRING
\r
1376 MFUNCTION ISTRING,SUBR
\r
1379 JUMPGE AB,TFA ; TOO FEW ARGS
\r
1380 CAMGE AB,[-4,,0] ; VERIFY NOT TOO MANY ARGS
\r
1384 IDIVI A,5 ; # OF WORDS NEEDED TO A
\r
1387 MCALL 1,UVECTOR ; GET SAME
\r
1388 HLRE C,B ; -LENGTH TO C
\r
1389 SUBM B,C ; LOCN OF DOPE WORD TO C
\r
1390 HRLI D,TCHRS ; CLOBBER ITS TYPE
\r
1393 HRR A,1(AB) ; SETUP TYPE'S RH
\r
1394 HRLI B,440700 ; AND BYTE POINTER
\r
1395 SKIPE (AB)+1 ; SKIP IF NO CHARACTERS TO DEPOSIT
\r
1396 CAML AB,[-2,,0] ; SKIP IF 2 ARGS GIVEN
\r
1398 PUSH TP,A ;SAVE OUR STRING
\r
1400 PUSH TP,A ;SAVE A TEMPORARY CLOBBER POINTER
\r
1402 PUSH P,(AB)1 ;SAVE COUNT
\r
1403 CLOBST: PUSH TP,(AB)+2
\r
1406 GETYP C,A ; CHECK IT
\r
1407 CAIE C,TCHRS ; MUST BE A CHARACTER
\r
1409 IDPB B,(TP) ;CLOBBER
\r
1410 SOSLE (P) ;FINISHED?
\r
1420 ;SET FLAG FOR INTERRUPT HANDLER
\r
1422 SETZB M,RCL ; CLEAR OUT RECYCLE LIST CELLS, AND RSUBR BASE PNTR
\r
1426 PUSHJ P,CTIME ; GET TIME FOR GIN-GOUT
\r
1427 MOVEM B,GCTIM ; SAVE FOR LATER
\r
1428 MOVEI B,[ASCIZ /GIN /]
\r
1431 NOMON1: HRRZ C,(P) ; GET CAUSE OF GC INDICATOR
\r
1432 MOVE B,GCNO(C) ; ADD 1 TO COUNT OF GC'S CAUSED BY GIVEN REASON
\r
1435 MOVEM C,GCCAUS ; SAVE CAUSE OF GC
\r
1436 SKIPN GCMONF ; MONITORING
\r
1438 MOVE B,MSGGCT(C) ; GET CAUSE MESSAGE
\r
1440 NOMON2: HLRZ C,(P) ; FIND OUT WHO CAUSED THE GC
\r
1441 MOVEM C,GCCALL ; SAVE CALLER OF GC
\r
1442 SKIPN GCMONF ; MONITORING
\r
1446 NOMON3: SUB P,[1,,1] ; POP OFF C
\r
1450 AAGC: SETZB M,RCL ; ALTERNATE GC-ENTRY POINT FOR INITIALIZATION
\r
1451 INITGC: SETOM GCFLG
\r
1454 IRP AC,,[0,A,B,C,D,E,P,R,M,SP,TP,TB,AB,TVP,PVP]
\r
1455 MOVEM AC,AC!STO"+1(PVP)
\r
1458 ; FUDGE NOWFRE FOR LATER WINNING
\r
1465 ; IF IN A PURE RSUBR, FIND ITS LENGTH AND FUDGE ITS LRU
\r
1467 HRRZ A,FSAV(TB) ; GET NAME OF CURRENT GOODIE
\r
1468 SETZM CURPLN ; CLEAR FOR NONE
\r
1469 CAML A,PURTOP ; IF LESS THAN TOP OF PURE ASSUME RSUBR
\r
1471 GETYP 0,(A) ; SEE IF PURE
\r
1472 CAIE 0,TPCODE ; SKIP IF IT IS
\r
1474 HLRZ B,1(A) ; GET SLOT INDICATION
\r
1475 ADD B,PURVEC+1(TVP) ; POINT TO SLOT
\r
1476 HRROS 2(B) ; MUNG AGE
\r
1477 HLRE A,1(B) ; - LENGTH TO A
\r
1478 MOVNM A,CURPLN ; AND STORE
\r
1481 ;SET UP E TO POINT TO TYPE VECTOR
\r
1482 GETYP E,TYPVEC(TVP)
\r
1485 HRRZ TYPNT,TYPVEC+1(TVP)
\r
1488 CHPDL: MOVE D,P ; SAVE FOR LATER
\r
1489 MOVE P,GCPDL ;GET GC'S PDL
\r
1490 CORGET: MOVE A,P.TOP ; UPDATE CORTOP
\r
1492 MOVE A,VECTOP ; ROOM BETWEEN CORTOP AND VECTOP IS GC MARK PDL
\r
1494 MOVSS A ; BUILD A PDL POINTER
\r
1496 JUMPGE A,TRYCOR ; NO ROOM, GO GET SOME
\r
1497 MOVE P,A ; SET UP PDL POINTER
\r
1499 ;FENCE POST PDLS AND CHECK IF ANY SHOULD BE SHRUNK
\r
1501 MOVEI A,(TB) ;POINT TO CURRENT FRAME IN PROCESS
\r
1502 PUSHJ P,FRMUNG ;AND MUNG IT
\r
1503 MOVE A,TP ;THEN TEMPORARY PDL
\r
1505 MOVE A,PSTO+1(PVP) ;AND UNMARKED P STACK
\r
1508 \f; FIRST CREATE INFERIOR TO HOLD NEW PAGES
\r
1510 INFCRT: MOVE A,PARBOT ; GENERATE NEW PARBOT AND PARNEW
\r
1513 ANDCMI A,1777 ; EVEN PAGE BOUNDARY
\r
1514 HRRM A,BOTNEW ; INTO POINTER WORD
\r
1516 MOVEI 0,2000(A) ; BOUNDS OF WINDOW
\r
1519 MOVEM A,PARNEW ; FIXED UP PARNEW
\r
1520 HRRZ A,BOTNEW ; GET PAGE TO START INF AT
\r
1521 ASH A,-10. ; TO PAGES
\r
1522 PUSHJ P,%GCJOB ; GET PAGE HOLDER
\r
1523 MOVSI FPTR,-2000 ; FIX UP FRONTIER POINTER
\r
1525 ;MARK PHASE: MARK ALL LISTS AND VECTORS
\r
1526 ;POINTED TO WITH ONE BIT IN SIGN BIT
\r
1527 ;START AT TRANSFER VECTOR
\r
1529 SETZB LPVP,VECNUM ;CLEAR NUMBER OF VECTOR WORDS
\r
1530 SETZB PARNUM ;CLEAR NUMBER OF PAIRS
\r
1531 MOVEI 0,NGCS ; SEE IF NEED HAIR
\r
1533 MOVEM 0,GCHAIR ; RESUME COUNTING
\r
1534 SETZM GREW ; ASSUME NO GROW/SHRINK
\r
1536 MOVSI D,400000 ;SIGN BIT FOR MARKING
\r
1537 MOVE A,ASOVEC+1(TVP) ;MARK ASSOC. VECTOR NOW
\r
1538 PUSHJ P,PRMRK ; PRE-MARK
\r
1539 MOVE A,GLOBSP+1(TVP)
\r
1542 ; HAIR TO DO AUTO CHANNEL CLOSE
\r
1544 MOVEI 0,N.CHNS-1 ; NUMBER OF CHANNELS
\r
1545 MOVEI A,CHNL1(TVP) ; 1ST SLOT
\r
1547 SKIPE 1(A) ; NOW A CHANNEL?
\r
1548 SETZM (A) ; DON'T MARK AS CHANNELS
\r
1552 MOVE A,PVP ;START AT PROCESS VECTOR
\r
1553 MOVEI B,TPVP ;IT IS A PROCESS VECTOR
\r
1554 PUSHJ P,MARK ;AND MARK THIS VECTOR
\r
1556 MOVE A,MAINPR ; MARK MAIN PROCES EVEN IF SWAPPED OUT
\r
1559 ; ASSOCIATION AND VALUE FLUSHING PHASE
\r
1561 SKIPN GCHAIR ; ONLY IF HAIR
\r
1564 SKIPE GCHAIR ; IF NOT HAIR, DO CHANNELS NOW
\r
1567 ;OPTIONAL RETIMING PHASE
\r
1568 ;THIS HAS BEEN FLUSHED BECAUSE OF PLANNER
\r
1570 SKIPE A,TIMOUT ;ANY TIME OVERFLOWS
\r
1571 PUSHJ P,RETIME ;YES, RE-CALIBRATE THEM
\r
1579 ;CORE ADJUSTMENT PHASE
\r
1580 MOVE P,GCPDL ; GET A PDL
\r
1581 SETZM CORSET ;CLEAR LATER CORE SETTING
\r
1582 PUSHJ P,CORADJ ;AND MAKE CORE ADJUSTMENTS
\r
1584 ;RELOCATION ESTABLISHMENT PHASE
\r
1585 ;1 -- IN VECTOR SPACE, ESTABLISH POINTERS TO TOP OF CORE
\r
1586 MOVE A,VECTOP" ;START AT TOP OF VECTOR SPACE
\r
1587 MOVE B,VECNEW" ;AND SET TO INITIAL OFFSET
\r
1588 SUBI A,1 ;POINT TO DOPE WORDS
\r
1589 ADDI B,(A) ; WHERE TOP VECTOR WILL GO
\r
1590 PUSHJ P,VECREL ;AND ESTABLISH RELOCATION FOR VECTORS
\r
1591 SUBI B,(A) ; RE-RELATIVIZE VECNEW
\r
1592 MOVEM B,VECNEW ;SAVE FINAL OFFSET
\r
1595 \f; MAP NEW PAIR SPACE IN FOR PAIR SPACE UPDATE
\r
1597 MOVE B,PARTOP ; POINT TO TOP OF PAIRS
\r
1600 CAMGE B,VECBOT ; OVERLAP VECTORS
\r
1603 ANDI C,1777 ; REL TO PAGE
\r
1604 ADDI C,FRONT ; 1ST DEST WORD
\r
1606 BLT C,FRONT+1777 ; MUNG IT
\r
1608 DOMAP: ASH B,-10. ; TO PAGES
\r
1610 MOVEI C,(A) ; COMPUTE HIS TOP
\r
1614 SUBM A,B ; B==> - # OF PAGES
\r
1615 HRLI A,(B) ; AOBJN TO SOURCE AND DEST
\r
1616 MOVE B,A ; IN CASE OF FUNNY
\r
1617 HRRI B,(C) ; MAP HIS POSSIBLE HIGHER OR LOWER PAGES
\r
1618 PUSHJ P,%INFMP ; NOW FLUSH INF AND MAKE HIS CORE MINE
\r
1620 \f;POINTER UPDATE PHASE
\r
1621 ;1 -- UPDATE ALL PAIR POINTERS
\r
1622 MOVE A,PARBOT ;START AT BOTTOM OF PAIR SPACE
\r
1623 PUSHJ P,PARUPD ;AND UPDATE ALL PAIR POINTERS
\r
1625 ;2 -- UPDATE ALL VECTORS
\r
1626 MOVE A,VECTOP ;START AT TOP OF VECTOR SPACE
\r
1627 PUSHJ P,VECUPD ;AND UPDATE THE POINTERS
\r
1628 MOVE A,CODTOP ; NOW UPDATE STORAGE STUFF
\r
1629 MOVEI D,0 ; FAKE OUT TO NOT UNMARK
\r
1633 ;3 -- UPDATE THE PVP AC
\r
1634 MOVEI A,PVP-1 ;SET LOC TO POINT TO PVP
\r
1635 MOVE C,PVP ;GET THE DATUM
\r
1636 PUSHJ P,NWRDUP ;AND UPDATE THIS VALUE
\r
1637 ;4 -- UPDATE THE MAIN PROCESS POINTER
\r
1638 MOVEI A,MAINPR-1 ;POINT TO MAIN PROCESS POINTER
\r
1639 MOVE C,MAINPR ;GET CONTENTS IN C
\r
1640 PUSHJ P,NWRDUP ;AND UPDATE IT
\r
1641 ;DATA MOVEMMENT ANDCLEANUP PHASE
\r
1643 ;1 -- ADJUST FOR SHRINKING VECTORS
\r
1644 MOVE A,VECTOP ;VECTOR SHRINKING PHASE
\r
1645 SKIPE SHRUNK ; SKIP IF NO SHRINKERS
\r
1646 PUSHJ P,VECSH ;GO SHRINK ANY SHRINKERS
\r
1648 ;2 -- MOVE VECTORS (AND LIST ELEMENTS)
\r
1649 MOVE A,VECTOP ;START AT TOP OF VECTOR SPACE
\r
1650 PUSHJ P,VECMOVE ;AND MOVE THE VECTORS
\r
1651 MOVE A,VECNEW ;GET FINAL CHANGE TO VECBOT
\r
1652 ADDM A,VECBOT ;OFFSET VECBOT TO ITS NEW PLACE
\r
1653 MOVE A,CORTOP ;GET NEW VALUE FOR TOP OF VECTOR SPACE
\r
1654 SUBI A,2000 ; FUDGE FOR MARK PDL
\r
1655 MOVEM A,VECTOP ;AND UPDATE VECTOP
\r
1657 ;3 -- CLEANUP VECTORS (NOTE A CONTAINS NEW VECTOP)
\r
1659 SKIPE GREW ; SKIP IF NO GROWERS
\r
1663 ;GARBAGE ZEROING PHASE
\r
1664 GARZER: MOVE A,PARTOP ;FIRST WORD OF GARBAGE IS AFTER PAIR SPACE
\r
1665 HRLS A ;GET FIRST ADDRESS IN LEFT HALF
\r
1666 MOVE B,VECBOT ;LAST ADDRESS OF GARBAGE + 1
\r
1667 CLEARM (A) ;ZERO THE FIRST WORD
\r
1668 ADDI A,1 ;MAKE A A BLT POINTER
\r
1669 BLT A,-1(B) ;AND COPY ZEROES INTO REST OF AREA
\r
1671 ;FINAL CORE ADJUSTMENT
\r
1672 SKIPE A,CORSET ;IFLESS CORE NEEDED
\r
1673 PUSHJ P,CORADL ;GIVE SOME AWAY.
\r
1675 ;NOW REHASH THE ASSOCIATIONS BASED ON NEW VALUES
\r
1680 TRYCOX: MOVE 0,VECBOT
\r
1685 MOVEI B,[ASCIZ /GOUT /]
\r
1687 NOMONO: IRP AC,,[0,A,B,C,D,E,P,R,M,SP,TP,TB,AB,PVP,TVP]
\r
1688 MOVE AC,AC!STO+1(PVP)
\r
1690 ; CLOSING ROUTINE FOR G-C
\r
1691 PUSH P,A ; SAVE AC'C
\r
1696 PUSHJ P,FIXSEN ; OUTPUT TIME
\r
1699 MOVEI A,15 ; OUTPUT C/R LINE-FEED
\r
1703 GCCONT: POP P,D ; RESTORE AC'C
\r
1707 MOVE A,GCDANG ; ERROR LEVELS TO ACS
\r
1709 SETZM GCDANG ; NOW CLEAR SAME
\r
1712 SKIPN GCHAIR ; WAS IT A FLUSHER?
\r
1713 JRST AGCWIN ; YES, NO MORE AVAILABLE
\r
1715 MOVEM A,GCHAIR ; RE-DO WITH HAIR
\r
1716 MOVE A,SPARNW ; RESET PARNEW
\r
1719 MOVE C,[11,10.] ; INDICATOR FOR AGC
\r
1720 JRST AGC ; TRY ONCE MORE
\r
1722 AGCWIN: SETZM PARNEW ;CLEAR FOR NEXT AGC CALL
\r
1723 SETZM GETNUM ;ALSO CLEAR THIS
\r
1726 JUMPGE P,RBLDM ; DONT LOSE ON BLOWN PDLS
\r
1728 CAMGE A,[-1] ; SKIP IF GOOD NEWS
\r
1730 SETZM PGROW ; CLEAR GROWTH
\r
1732 SETOM GCHAPN ; INDICATE A GC HAS HAPPENED
\r
1733 SETOM INTFLG ; AND REQUEST AN INTERRUPT
\r
1736 RBLDM: JUMPGE R,CPOPJ
\r
1737 SKIPGE M,1(R) ; SKIP IF FUNNY
\r
1741 ADD M,PURVEC+1(TVP)
\r
1751 AGCE1: FATAL AGC--TYPE VECTOR NOT OF TYPE VECTOR
\r
1753 \f; CONVERSION FROM FLOAT TO DECIMAL. X 100 AND SEND OUT WITH APPROPRIATELY PLACED DECIMAL
\r
1756 FIXSEN: PUSH P,B ; SAVE TIME
\r
1757 MOVEI B,[ASCIZ /TIME= /]
\r
1759 PUSHJ P,MSGTYP ; PRINT OUT MESSAGE
\r
1760 POP P,B ; RESTORE B
\r
1761 FSBR B,GCTIM ; GET TIME ELAPSED
\r
1762 MOVEM B,GCTIM ; SAVE ELAPSED TIME FOR INT-HANDLER
\r
1765 FMPRI B,(100.0) ; CONVERT TO FIX
\r
1769 MOVEI A,1 ; INITIALIZE COUNT OF CHARACTERS FOR PUTTING OUT TIME
\r
1771 IDIVI C,10. ; START COUNTING
\r
1775 CAIN A,1 ; SEE IF THERE IS ONLY ONE CHARACTER
\r
1777 FIXOUT: IDIVI C,10. ; RECOVER NUMBER
\r
1782 CAIN A,2 ; DECIMAL POINT HERE?
\r
1784 FIX1: HLRZ A,(P)-1 ; GET NUMBER
\r
1785 ADDI A,60 ; MAKE IT A CHARACTER
\r
1786 PUSHJ P,MTYO ; OUT IT GOES
\r
1790 DOT1: MOVEI A,". ; OUTPUT DECIMAL POINT AND PADDING 0
\r
1794 JRST FIXOUT ; CONTINUE
\r
1795 DOT2: MOVEI A,". ; OUTPUT DECIMAL POINT
\r
1799 \f; INITIAL CORE ADJUSTMENT TO OBTAIN SPACE
\r
1800 ; FOR MARK PHASE PDL
\r
1802 TRYCOR: MOVEI A,2000
\r
1803 ADDB A,CORTOP ; TRY AND GET 1 BLOCK
\r
1805 MOVEI E,(A) ; SAVE FOR LOOPER
\r
1806 PUSHJ P,P.CORE ; GET CORE
\r
1807 JRST TRYCO2 ; FAILED, TAKE MORE ACTION
\r
1810 TRYCO2: MOVNI A,2000 ; FIXUP CORTOP
\r
1812 TRYCO3: MOVE 0,TPGROW
\r
1813 ADD 0,PGROW ; 0/ NEQ 0 IF STACK BLEW
\r
1814 SKIPGE TP ; SKIP IF TP BLOWN
\r
1815 SKIPL PSTO+1(PVP) ; SKIP IF P WINS
\r
1820 TYPE C TO KEEP TRYING
\r
1821 TYPE N TO GET MUDDLE ERROR
\r
1822 TYPE V TO RETURN TO MONITOR
\r
1827 TYPE C TO KEEP TRYING
\r
1828 TYPE V TO RETURN TO MONITOR
\r
1832 SETOM GCFLCH ; TELL INTERRUPT HANDLER TO .ITYIC
\r
1834 PUSHJ P,UPLO ; IN CASE LOWER CASE TYPED
\r
1842 FATAL CORE LOSSAGE
\r
1851 TRYCO4: MOVEI A,(E)
\r
1852 TRYCO9: MOVEI B,1 ; SLEEP AND CORE UNTIL WINNAGE
\r
1854 PUSHJ P,%SLEEP ; SLEEP A WHILE
\r
1865 TRYCO5: MOVNI A,3 ; GIVE WORST ERROR RETURN
\r
1870 \f; SUBROUTINE TO CHECK SIZE OF PDLS AND DO FENCEPOSTING
\r
1872 PDLCHK: JUMPGE A,CPOPJ
\r
1873 HLRE B,A ;GET NEGATIVE COUNT
\r
1874 MOVE C,A ;SAVE A COPY OF PDL POINTER
\r
1875 SUBI A,-1(B) ;LOCATE DOPE WORD PAIR
\r
1876 HRRZS A ; ISOLATE POINTER
\r
1877 CAME A,TPGROW ;GROWING?
\r
1878 ADDI A,PDLBUF ;NO, POINT TO REAL DOPE WORD
\r
1879 HLRZ D,(A) ;GET COUNT FROM DOPE WORD
\r
1880 MOVNS B ;GET POSITIVE AMOUNT LEFT
\r
1881 SUBI D,2(B) ; PDL FULL?
\r
1882 JUMPE D,NOFENC ;YES NO FENCE POSTING
\r
1883 SETOM 1(C) ;CLOBBER TOP WORD
\r
1884 SOJE D,NOFENC ;STILL MORE?
\r
1885 MOVSI D,1(C) ;YES, SET UP TO BLT FENCE POSTS
\r
1887 BLT D,-2(A) ;FENCE POST ALL EXCEPT DOPE WORDS
\r
1890 NOFENC: CAIG B,TPMAX ;NOW CHECK SIZE
\r
1892 JRST MUNGTP ;TOO BIG OR TOO SMALL
\r
1895 MUNGTP: SUBI B,TPGOOD ;FIND DELTA TP
\r
1896 MUNG3: MOVE C,-1(A) ;IS GROWTH ALREADY SPECIFIED
\r
1897 TRNE C,777000 ;SKIP IF NOT
\r
1898 POPJ P, ;ASSUME GROWTH GIVEN WILL WIN
\r
1900 ASH B,-6 ;CONVERT TO NUMBER OF BLOCKS
\r
1902 CAILE B,377 ; SKIP IF BELOW MAX
\r
1903 MOVEI B,377 ; ELSE USE MAX
\r
1904 TRO B,400 ;TURN ON SHRINK BIT
\r
1908 MUNGT2: DPB B,[111100,,-1(A)] ;STORE IN DOPE WORD
\r
1911 ; CHECK UNMARKED STACK (NO NEED TO FENCE POST)
\r
1913 PDLCHP: HLRE B,A ;-LENGTH TO B
\r
1915 SUBI A,-1(B) ;POINT TO DOPE WORD
\r
1916 HRRZS A ;ISOLATE POINTER
\r
1917 CAME A,PGROW ;GROWING?
\r
1918 ADDI A,PDLBUF ;NO, POINT TO REAL DOPE WORD
\r
1919 MOVMS B ;PLUS LENGTH
\r
1920 HLRZ D,(A) ; D.W. LENGTH
\r
1921 SUBI D,2(B) ; PDL FULL
\r
1923 SETOM 1(C) ; START FENECE POST
\r
1924 SOJE D,NOPF ; 1 WORD?
\r
1929 NOPF: CAIG B,PMAX ;TOO BIG?
\r
1930 CAIG B,PMIN ;OR TOO LITTLE
\r
1931 JRST .+2 ;YES, MUNG IT
\r
1936 ;THIS ROUTINE MAKES SURE CURRENT FRAME MAKES SENSE
\r
1937 FRMUNG: MOVEM D,PSAV(A)
\r
1939 MOVEM TP,TPSAV(A) ;SAVE FOR MARKING
\r
1942 ; ROUTINE TO PRE MARK SPECIAL HACKS
\r
1944 PRMRK: SKIPE GCHAIR ; FLUSH IF NO HAIR
\r
1947 SUBI A,(B) ;POINT TO DOPE WORD
\r
1948 HLRZ B,1(A) ; GET LNTH
\r
1949 ADDM B,VECNUM ; AND UPDATE VECNUM
\r
1950 LDB B,[111100,,(A)] ; GET GROWTHS
\r
1951 TRZE B,400 ; SIGN HACK
\r
1953 ASH B,6 ; TO WORDS
\r
1955 LDB 0,[001100,,(A)]
\r
1960 PUSHJ P,GSHFLG ; SET GROW FLAGS
\r
1961 IORM D,1(A) ;AND MARK
\r
1964 ; SET UP FLAGS FOR OPTIOANAL GROW/SHRINK PHASES
\r
1974 \f;GENERAL MARK SUBROUTINE. CALLED TO MARK ALL THINGS
\r
1975 ; A/ GOODIE TO MARK FROM
\r
1976 ; B/ TYPE OF A (IN RH)
\r
1977 ; C/ TYPE,DATUM PAIR POINTER
\r
1979 MARK2: HLRZ B,(C) ;GET TYPE
\r
1980 MARK1: MOVE A,1(C) ;GET GOODIE
\r
1981 MARK: JUMPE A,CPOPJ ; NEVER MARK 0
\r
1983 CAIL 0,@PURBOT ; DONT MARK PURE STUFF
\r
1985 PUSH P,A ;SAVE GOODIE
\r
1986 HRLM C,-1(P) ;AND POINTER TO IT
\r
1987 ANDI B,TYPMSK ; FLUSH MONITORS
\r
1988 LSH B,1 ;TIMES 2 TO GET SAT
\r
1989 HRRZ B,@TYPNT ;GET SAT
\r
1991 CAIG B,NUMSAT ; SKIP IF TEMPLATE DATA
\r
1992 JRST @MKTBS(B) ;AND GO MARK
\r
1995 ; DISPATCH TABLE FOR MARK PHASE ("SETZ'D" ENTRIES MUST BE DEFERRED)
\r
1997 DISTBS MKTBS,GCRET,[[S2WORD,PAIRMK],[S2DEFR,DEFMK],[SNWORD,VECTMK]
\r
1998 [STPSTK,TPMK],[SARGS,<SETZ ARGMK>],[S2NWORD,VECTMK],[SPSTK,TPMK],[SSTORE,VECTMK]
\r
1999 [SFRAME,<SETZ FRMK>],[SBYTE,<SETZ BYTMK>],[SATOM,ATOMK],[SPVP,VECTMK],[SGATOM,GATOMK]
\r
2000 [SLOCID,<SETZ LOCMK>],[SCHSTR,<SETZ BYTMK>],[SASOC,ASMRK],[SLOCL,PAIRMK]
\r
2001 [SLOCA,<SETZ ARGMK>],[SLOCV,VECTMK],[SLOCU,VECTMK],[SLOCS,<SETZ BYTMK>],[SLOCN,ASMRK]]
\r
2004 ;HERE TO MARK THAT WHICH IS POINTED TO BY A DEFERRED POINTER
\r
2006 DEFMK: TLOA TYPNT,400000 ;USE SIGN BIT AS FLAG
\r
2008 ;HERE TO MARK LIST ELEMENTS
\r
2010 PAIRMK: TLZ TYPNT,400000 ;TURN OF DEFER BIT
\r
2011 PUSH P,[0] ; WILL HOLD BACK PNTR
\r
2012 MOVEI C,(A) ;POINT TO LIST
\r
2013 PAIRM1: CAMGE C,PARTOP ;CHECK FOR BEING IN BOUNDS
\r
2015 FATAL AGC--MARKED PAIR OUTSIDE PAIR SPACE
\r
2016 SKIPGE B,(C) ;SKIP IF NOT MARKED
\r
2017 JRST RETNEW ;ALREADY MARKED, RETURN
\r
2018 IORM D,(C) ;MARK IT
\r
2020 MOVEM B,FRONT(FPTR) ; STORE 1ST WORD
\r
2021 MOVE 0,1(C) ; AND 2D
\r
2022 MOVEM 0,FRONT+1(FPTR)
\r
2023 ADD FPTR,[2,,2] ; MOVE ALONG IN FRONTIER
\r
2024 JUMPL FPTR,PAIRM2 ; NOD NEED FOR NEW CORE
\r
2026 ; HERE TO EXTEND THE FRONTIER
\r
2028 HRRZ A,BOTNEW ; CURRENT BOTTOM OF WINDOW IN INF
\r
2029 ADDI A,2000 ; MOVE IT UP
\r
2031 ASH A,-10. ; TO PAGES
\r
2032 SYSLO1: PUSHJ P,%GETIP ; GET PAGE
\r
2033 PUSHJ P,%SHFNT ; AND SHARE IT
\r
2036 PAIRM2: MOVEI A,@BOTNEW ; GET INF ADDR
\r
2038 HRRM A,(C) ; LEAVE A POINTER TO NEW HOME
\r
2039 HRRZ E,(P) ; GET BACK POINTER
\r
2040 JUMPE E,PAIRM7 ; 1ST ONE, NEW FIXUP
\r
2041 MOVSI 0,(HRRM) ; INS FOR CLOBBER
\r
2042 PUSHJ P,SMINF ; SMASH INF'S CORE IMAGE
\r
2043 PAIRM4: MOVEM A,(P) ; NEW BACK POINTER
\r
2044 JUMPL TYPNT,DEFDO ;GO HANDLE DEFERRED POINTER
\r
2045 HRLM B,(P) ; SAVE OLD CDR
\r
2046 PUSHJ P,MARK2 ;MARK THIS DATUM
\r
2047 HRRZ E,(P) ; SMASH CAR IN CASE CHANGED
\r
2051 HLRZ C,(P) ;GET CDR OF LIST
\r
2052 CAIGE C,@PURBOT ; SKIP IF PURE (I.E. DONT MARK)
\r
2053 JUMPN C,PAIRM1 ;IF NOT NIL, MARK IT
\r
2054 GCRETP: SUB P,[1,,1]
\r
2056 GCRET: TLZ TYPNT,400000 ;FOR PAIRMKS BENEFIT
\r
2057 HLRZ C,-1(P) ;RESTORE C
\r
2059 POPJ P, ;AND RETURN TO CALLER
\r
2061 ;HERE TO MARK DEFERRED POINTER
\r
2063 DEFDO: PUSH P,B ; PUSH OLD PAIR ON STACK
\r
2065 MOVEI C,-1(P) ; USE AS NEW DATUM
\r
2066 PUSHJ P,MARK2 ;MARK THE DATUM
\r
2067 HRRZ E,-2(P) ; GET POINTER IN INF CORE
\r
2070 PUSHJ P,SMINF ; AND CLOBBER
\r
2072 JRST GCRET ;AND RETURN
\r
2075 PAIRM7: MOVEM A,-1(P) ; SAVE NEW VAL FOR RETURN
\r
2078 RETNEW: HRRZ A,(C) ; POINT TO NEW WORLD LOCN
\r
2079 HRRZ E,(P) ; BACK POINTER
\r
2080 JUMPE E,RETNW1 ; NONE
\r
2085 RETNW1: MOVEM A,-1(P)
\r
2088 ; ROUTINE TO SMASH INFERIORS PPAGES
\r
2089 ; E/ ADDR IN INF, A/ THING TO SMASH ,0/ INS TO USE
\r
2091 SMINF: CAML E,WNDBOT ; SEE IF IN WINDOW
\r
2093 JRST SMINF1 ; NO TRY FRONTIER
\r
2094 SMINF3: SUB E,WNDBOT ; FIX UP
\r
2095 IOR 0,[0 A,WIND(E)] ; FIX INS
\r
2100 HRRZ 0,BOTNEW ; GET FRONTIER RANGE
\r
2101 CAML E,0 ; SKIP IF BELOW
\r
2106 IOR 0,[0 A,FRONT(E)]
\r
2112 ASH A,-10. ; TO PAGES
\r
2114 ASH A,10. ; BACK TO WORDS
\r
2119 POP P,0 ; RESTORE INS OF INTEREST
\r
2123 \f; VECTOR AND TP MARKER, SIGN OF TYPNT IS SET BASED ON WHICH ONE
\r
2125 TPMK: TLOA TYPNT,400000 ;SET TP MARK FLAG
\r
2126 VECTMK: TLZ TYPNT,400000
\r
2127 MOVEI E,(A) ;SAVE A POINTER TO THE VECTOR
\r
2128 HLRE B,A ;GET -LNTH
\r
2129 SUB A,B ;LOCATE DOPE WORD
\r
2130 MOVEI A,1(A) ;ZERO LH AND POINT TO 2ND DOPE WORD
\r
2131 PUSHJ P,VECBND ; CHECK IN VECTOR SPACE
\r
2132 JRST VECTB1 ;LOSE, COMPLAIN
\r
2134 JUMPGE TYPNT,NOBUFR ;IF A VECTOR, NO BUFFER CHECK
\r
2135 CAME A,PGROW ;IS THIS THE BLOWN P
\r
2136 CAMN A,TPGROW ;IS THIS THE GROWING PDL
\r
2137 JRST NOBUFR ;YES, DONT ADD BUFFER
\r
2138 ADDI A,PDLBUF ;POINT TO REAL DOPE WORD
\r
2139 MOVSI 0,-PDLBUF ;ALSO FIX UP POINTER
\r
2141 MOVEM 0,(P) ; FIXUP RET'D PNTR
\r
2143 NOBUFR: HLRE B,(A) ;GET LENGTH FROM DOPE WORD
\r
2144 JUMPL B,GCRET ; MARKED, LEAVE
\r
2145 ANDI B,377777 ;CLOBBER POSSIBLE MARK BIT
\r
2146 MOVEI F,(A) ;SAVE A POINTER TO DOPE WORD
\r
2147 SUBI F,1(B) ;F POINTS TO START OF VECTOR
\r
2148 HRRZ 0,-1(A) ;SEE IF GROWTH SPECIFIED
\r
2149 MOVEI B,0 ; SET GROWTH 0
\r
2150 JUMPE 0,NOCHNG ;NONE, JUST CHECK CURRENT SIZES
\r
2152 LDB B,[001100,,0] ;GET GROWTH FACTOR
\r
2153 TRZE B,400 ;KILL SIGN BIT AND SKIP IF +
\r
2155 ASH B,6 ;CONVERT TO NUMBER OF WORDS
\r
2156 SUB F,B ;BOTTOM IS LOWER IN CORE
\r
2157 LDB 0,[111100,,0] ;GET TOP GROWTH
\r
2158 TRZE 0,400 ;HACK SIGN BIT
\r
2160 ASH 0,6 ;CONVERT TO WORDS
\r
2161 PUSHJ P,GSHFLG ; HACK FLAGS FOR GROW/SHRINK
\r
2162 ADD B,0 ;TOTAL GROWTH TO B
\r
2164 VECOK: HLRE E,(A) ;GET LENGTH AND MARKING
\r
2165 MOVEI F,(E) ;SAVE A COPY
\r
2166 ADD F,B ;ADD GROWTH
\r
2167 SUBI E,2 ;- DOPE WORD LENGTH
\r
2168 IORM D,(A) ;MAKE SURE NOW MARKED
\r
2169 CAML A,VECBOT ; ONLY IF REALLY IN VEC SPACE
\r
2170 ADDM F,VECNUM ; ADD LENGTH OF VECTOR
\r
2171 JUMPLE E,GCRET ;ALREADY MARKED OR ZERO LENGTH, LEAVE
\r
2173 SKIPGE B,-1(A) ;SKIP IF UNIFORM
\r
2174 TLNE B,377777 ;SKIP IF NOT SPECIAL
\r
2175 JUMPGE TYPNT,NOTGEN ;JUMP IF NOT A GENERAL VECTOR
\r
2177 GENRAL: HLRZ 0,B ;CHECK FOR PSTACK
\r
2178 JUMPE 0,NOTGEN ;IT ISN'T GENERAL
\r
2179 SUBI A,1(E) ;POINT TO FIRST ELEMENT
\r
2180 MOVEI C,(A) ;POINT TO FIRST ELEMENT WITH C
\r
2182 \f; LOOP TO MARK ELEMENTS IN A GENERAL VECTOR
\r
2184 VECTM2: HLRE B,(C) ;GET TYPE AND MARKING
\r
2185 JUMPL B,GCRET1 ;RETURN, (EITHER DOPE WORD OR FENCE POST)
\r
2186 MOVE A,1(C) ;DATUM TO A
\r
2187 ANDI B,TYPMSK ; FLUSH MONITORS
\r
2188 CAIE B,TCBLK ;IS THIS A SAVED FRAME?
\r
2189 CAIN B,TENTRY ;IS THIS A STACK FRAME
\r
2190 JRST MFRAME ;YES, MARK IT
\r
2191 CAIE B,TUBIND ; BIND
\r
2192 CAIN B,TBIND ;OR A BINDING BLOCK
\r
2195 VECTM3: PUSHJ P,MARK ;MARK DATUM
\r
2196 MOVEM A,1(C) ; IN CASE WAS FIXED
\r
2200 MFRAME: HRROI C,FRAMLN+FSAV-1(C) ;POINT TO FUNCTION
\r
2201 HRRZ A,1(C) ; GET IT
\r
2202 PUSHJ P,VECBND ; CHECK IN VECTOR SPACE
\r
2203 JRST MFRAM1 ; IGNORE, NOT IN VECTOR SPACE
\r
2204 HRL A,(A) ; GET LENGTH
\r
2206 PUSHJ P,MARK ; AND MARK IT
\r
2207 MFRAM1: HRROI C,SPSAV-FSAV(C) ;POINT TO SAVED SP
\r
2209 PUSHJ P,MARK1 ;MARK THE GOODIE
\r
2210 HRROI C,PSAV-SPSAV(C) ;POINT TO SAVED P
\r
2212 PUSHJ P,MARK1 ;AND MARK IT
\r
2213 HRROI C,TPSAV-PSAV(C) ;POINT TO SAVED TP
\r
2215 PUSHJ P,MARK1 ;MARK IT ALS
\r
2216 MOVEI C,-TPSAV+1(C) ;POINT PAST THE FRAME
\r
2217 JRST VECTM2 ;AND DO MORE MARKING
\r
2220 MBIND: MOVEI B,TATOM ;FIRST MARK ATOM
\r
2221 SKIPN GCHAIR ; IF NO HAIR, MARK ALL NOW
\r
2222 SKIPE (P) ; PASSED MARKER, IF SO DONT SKIP
\r
2223 JRST MBIND2 ; GO MARK
\r
2224 CAME A,IMQUOTE THIS-PROCESS
\r
2225 JRST MBIND1 ; NOT IT, CONTINUE SKIPPING
\r
2226 HRRM LPVP,2(C) ; SAVE IN RH OF TPVP,,0
\r
2227 MOVEI LPVP,(C) ; POINT
\r
2228 SETOM (P) ; INDICATE PASSAGE
\r
2229 MBIND1: ADDI C,6 ; SKIP BINDING
\r
2232 MBIND2: PUSHJ P,MARK1 ; MARK ATOM
\r
2233 ADDI C,2 ; POINT TO VAL
\r
2234 PUSHJ P,MARK2 ; AND MARK IT
\r
2237 MOVEI B,TLIST ; POINT TO DECL SPECS
\r
2239 PUSHJ P,MARK ; AND MARK IT
\r
2240 HRLM A,(C) ; LIST FIX UP
\r
2241 MOVEI B,TLOCI ; NOW MARK LOCATIVE
\r
2245 VECLOS: JUMPL C,CCRET ;JUMP IF CAN'T MUNG TYPE
\r
2246 HLLZ 0,(C) ;GET TYPE
\r
2247 MOVEI B,TILLEG ;GET ILLEGAL TYPE
\r
2249 MOVEM 0,1(C) ;AND STORE OLD TYPE AS VALUE
\r
2250 JRST GCRET ;RETURN WITHOUT MARKING VECTOR
\r
2252 CCRET: CLEARM 1(C) ;CLOBBER THE DATUM
\r
2256 IGBLK: HRRZ B,(C) ;SKIP TO END OF PP BLOCK
\r
2259 \f; MARK ARG POINTERS
\r
2261 ARGMK: HRRZ A,1(C) ; GET POINTER
\r
2262 HLRE B,1(C) ; AND LNTH
\r
2263 SUB A,B ; POINT TO BASE
\r
2266 HLRZ 0,(A) ; GET TYPE
\r
2270 CAIE 0,TENTRY ; IS NEXT A WINNER?
\r
2272 JRST ARGMK1 ; YES, GO ON TO WIN CODE
\r
2274 ARGMK0: SETZB A,1(C) ; CLOBBER THE CELL
\r
2275 SETZM (P) ; AND SAVED COPY
\r
2278 ARGMK1: MOVE B,1(A) ; ASSUME TTB
\r
2279 ADDI B,(A) ; POINT TO FRAME
\r
2280 CAIE 0,TINFO ; IS IT?
\r
2281 MOVEI B,FRAMLN(A) ; NO, USE OTHER GOODIE
\r
2282 HLRZ 0,OTBSAV(B) ; GET TIME
\r
2283 HRRZ A,(C) ; AND FROM POINTER
\r
2284 CAIE 0,(A) ; SKIP IF WINNER
\r
2286 HRROI C,TPSAV-1(B) ; MARK FROM TP SLOT
\r
2289 ; PUSHJ P,MARK ; WILL PUT BACK WHEN KNOWN HOW!
\r
2292 ; MARK FRAME POINTERS
\r
2294 FRMK: SUBI C,1 ;PREPARE TO MARK PROCESS VECTOR
\r
2295 HRRZ A,1(C) ;USE AS DATUM
\r
2296 SUBI A,1 ;FUDGE FOR VECTMK
\r
2297 MOVEI B,TPVP ;IT IS A VECTRO
\r
2298 PUSHJ P,MARK ;MARK IT
\r
2301 ; MARK BYTE POINTER
\r
2303 BYTMK: PUSHJ P,BYTDOP ; GET DOPE WORD IN A
\r
2304 SOJG A,VECTMK ;FUDGE DOPE WORD POINTER FOR VECTMK
\r
2306 FATAL AGC--BYTE POINTER WITH ZERO DOPE WORD POINTER
\r
2308 \f; MARK ATOMS IN GVAL STACK
\r
2310 GATOMK: HRRZ B,(C) ; POINT TO POSSIBLE GDECL
\r
2314 MOVEI A,(B) ; POINT TO DECL FOR MARK
\r
2318 HLRZ C,-1(P) ; RESTORE HOME POINTER
\r
2319 HRRM A,(C) ; CLOBBER UPDATED LIST IN
\r
2320 MOVE A,1(C) ; RESTORE ATOM POINTER
\r
2326 TLO TYPNT,.ATOM. ; SAY ATOM WAS MARKED
\r
2327 PUSHJ P,GETLNT ;GET LENGTH AND CHECK BOUNDS
\r
2328 HRRZ C,(A) ; IF UNBOUND OR GLOBAL
\r
2329 JUMPE C,MRKOBL ; SKIP
\r
2330 HRRZ C,1(A) ; DONT MARK BUT UPDATE BASED ON TPGROW
\r
2332 SUB C,B ; POINT TO DOPE WORD
\r
2333 MOVEI C,1(C) ; POINT TO 2D DOPE WORD
\r
2334 MOVSI B,-PDLBUF ; IN CASE UPDATE
\r
2335 CAME C,TPGROW ; SKIP IF GROWER
\r
2336 ADDM B,1(A) ; OTHERWISE UPDATE
\r
2337 MRKOBL: MOVEI C,1(A) ; POINT TO OBLIST SLOT
\r
2339 TLO TYPNT,.ATOM. ; SAY ATOM WAS MARKED
\r
2342 PUSHJ P,GETLNT ;GET LENGTH AND CHECK BOUNDS
\r
2351 MRKOBL: MOVEI B,TOBLS
\r
2352 SKIPGE 1(C) ; IF > 0, NOT OBL
\r
2353 PUSHJ P,MARK1 ; AND MARK IT
\r
2354 JRST GCRET ;AND LEAVE
\r
2356 GETLNT: HLRE B,A ;GET -LNTH
\r
2357 SUB A,B ;POINT TO 1ST DOPE WORD
\r
2358 MOVEI A,1(A) ;POINT TO 2ND DOPE WORD
\r
2360 JRST VECTB1 ;BAD VECTOR, COMPLAIN
\r
2362 HLRE B,(A) ;GET LENGTH AND MARKING
\r
2363 IORM D,(A) ;MAKE SURE MARKED
\r
2364 JUMPL B,GCRET1 ;MARKED ALREADY, QUIT
\r
2365 SUBI A,-1(B) ;POINT TO TOP OF ATOM
\r
2366 CAML A,VECBOT ; DONT COUNT STORAGE
\r
2367 ADDM B,VECNUM ;UPDATE VECNUM
\r
2368 POPJ P, ;AND RETURN
\r
2370 GCRET1: SUB P,[1,,1] ;FLUSH RETURN ADDRESS
\r
2373 VECBND: CAMGE A,VECTOP
\r
2383 ; MARK NON-GENERAL VECTORS
\r
2385 NOTGEN: CAMN B,[GENERAL+<SPVP,,0>] ;PROCESS VECTOR?
\r
2386 JRST GENRAL ;YES, MARK AS A VECTOR
\r
2387 JUMPL B,SPECLS ; COMPLAIN IF A SPECIAL HACK
\r
2388 SUBI A,1(E) ;POINT TO TOP OF A UNIFORM VECTOR
\r
2389 HLRZS B ;ISOLATE TYPE
\r
2391 MOVE F,B ; AND COPY IT
\r
2392 LSH B,1 ;FIND OUT WHERE IT WILL GO
\r
2393 HRRZ B,@TYPNT ;GET SAT IN B
\r
2395 MOVEI C,@MKTBS(B) ;POINT TO MARK SR
\r
2396 CAIN C,GCRET ;IF NOT A MARKED FROM GOODIE, IGNORE
\r
2398 MOVEI C,-1(A) ;POINT 1 PRIOR TO VECTOR START
\r
2399 PUSH P,E ;SAVE NUMBER OF ELEMENTS
\r
2400 PUSH P,F ;AND UNIFORM TYPE
\r
2402 UNLOOP: MOVE B,(P) ;GET TYPE
\r
2403 MOVE A,1(C) ;AND GOODIE
\r
2404 TLO C,400000 ;CAN'T MUNG TYPE
\r
2405 PUSHJ P,MARK ;MARK THIS ONE
\r
2406 MOVEM A,1(C) ; LIST FIXUP
\r
2408 AOJA C,UNLOOP ;IF MORE, DO NEXT
\r
2410 SUB P,[2,,2] ;REMOVE STACK CRAP
\r
2414 SPECLS: FATAL AGC--UNRECOGNIZED SPECIAL VECTOR
\r
2416 \f;MARK LOCID TYPE GOODIES
\r
2418 LOCMK: HRRZ B,(C) ;GET TIME
\r
2419 JUMPE B,LOCMK1 ; SKIP LEGAL CHECK FOR GLOBAL
\r
2420 HRRZ 0,2(A) ; GET OTHER TIME
\r
2421 CAIE 0,(B) ; SAME?
\r
2422 SETZB A,1(C) ; NO, SMASH LOCATIVE
\r
2423 JUMPE A,GCRET ; LEAVE IF DONE
\r
2425 MOVEI B,TATOM ; MARK ATOM
\r
2426 MOVEI C,-2(A) ; POINT TO ATOM
\r
2427 PUSHJ P,MARK1 ; LET LOCATIVE SAVE THE ATOM
\r
2429 HRRZ B,(C) ; TIME BACK
\r
2430 MOVE A,1(C) ; RESTORE POINTER TO STACK
\r
2431 JUMPE B,VECTMK ;IF ZERO, GLOBAL
\r
2432 JRST TPMK ;ELSE, ON TP
\r
2434 ; MARK ASSOCIATION BLOCKS
\r
2436 ASMRK: HRLI A,-ASOLNT ;LOOK LIKE A VECTOR POINTER
\r
2437 PUSHJ P,GETLNT ;GET LENGTH AND CHECK BOUNDS
\r
2438 MOVEI C,(A) ;COPY POINTER
\r
2439 PUSHJ P,MARK2 ;MARK ITEM CELL
\r
2441 ADDI C,INDIC-ITEM ;POINT TO INDICATOR
\r
2447 SKIPN GCHAIR ; IF NO HAIR, MARK ALL FRIENDS
\r
2449 HRRZ A,NODPNT-VAL(C) ; NEXT
\r
2450 JUMPN A,ASMRK ; IF EXISTS, GO
\r
2455 ;HERE WHEN A VECTOR POINTER IS BAD
\r
2457 VECTB1:FATAL AGC--VECTOR POINTS OUTSIDE OF VECTOR SPACE
\r
2459 \f; HERE TO MARK TEMPLATE DATA STRUCTURES
\r
2461 TD.MRK: HLRZ B,(A) ; GET REAL SPEC TYPE
\r
2462 ANDI B,377777 ; KILL SIGN BIT
\r
2463 MOVEI E,-NUMSAT-1(B) ; GET REL POINTER TO TABLE
\r
2465 ADD E,TD.LNT+1(TVP)
\r
2466 HRRZS C,A ; FLUSH COUNT AND SAVE
\r
2467 SKIPL E ; WITHIN BOUNDS
\r
2468 FATAL BAD SAT IN AGC
\r
2469 PUSHJ P,GETLNT ; GOODIE IS NOW MARKED
\r
2471 XCT (E) ; RET # OF ELEMENTS IN B
\r
2473 HLRZ D,B ; GET POSSIBLE "BASIC LENGTH" FOR RESTS
\r
2474 PUSH P,[0] ; TEMP USED IF RESTS EXIST
\r
2476 MOVEI B,(B) ; ZAP TO ONLY LENGTH
\r
2477 PUSH P,C ; SAVE POINTER TO TEMPLATE STRUCTURE
\r
2478 PUSH P,[0] ; HOME FOR VALUES
\r
2479 PUSH P,[0] ; SLOT FOR TEMP
\r
2481 SUB E,TD.LNT+1(TVP)
\r
2482 PUSH P,E ; SAVE FOR FINDING OTHER TABLES
\r
2483 JUMPE D,TD.MR2 ; NO REPEATING SEQ
\r
2484 ADD E,TD.GET+1(TVP) ; COMP LNTH OF REPEATING SEQ
\r
2485 HLRE E,(E) ; E ==> - LNTH OF TEMPLATE
\r
2486 ADDI E,(D) ; E ==> -LENGTH OF REP SEQ
\r
2488 HRLM E,-5(P) ; SAVE IT AND BASIC
\r
2490 TD.MR2: SKIPG D,-1(P) ; ANY LEFT?
\r
2493 MOVE E,TD.GET+1(TVP)
\r
2495 MOVE E,(E) ; POINTER TO VECTOR IN E
\r
2496 MOVEM D,-6(P) ; SAVE ELMENT #
\r
2497 SKIPN B,-5(P) ; SKIP IF "RESTS" EXIST
\r
2500 MOVEI 0,(B) ; BASIC LNT TO 0
\r
2501 SUBI 0,(D) ; SEE IF PAST BASIC
\r
2502 JUMPGE 0,.-3 ; JUMP IF O.K.
\r
2503 MOVSS B ; REP LNT TO RH, BASIC TO LH
\r
2504 IDIVI 0,(B) ; A==> -WHICH REPEATER
\r
2506 ADD A,-5(P) ; PLUS BASIC
\r
2507 ADDI A,1 ; AND FUDGE
\r
2508 MOVEM A,-6(P) ; SAVE FOR PUTTER
\r
2509 ADDI E,-1(A) ; POINT
\r
2512 TD.MR3: ADDI E,(D) ; POINT TO SLOT
\r
2513 XCT (E) ; GET THIS ELEMENT INTO A AND B
\r
2514 MOVEM A,-3(P) ; SAVE TYPE FOR LATER PUT
\r
2516 EXCH A,B ; REARRANGE
\r
2518 MOVEI C,-3(P) ; TELL OTHER GUYS THEY CANT DIRECTLY MUNG
\r
2519 MOVSI D,400000 ; RESET FOR MARK
\r
2520 PUSHJ P,MARK ; AND MARK THIS GUY (RET FIXED POINTER IN A)
\r
2521 MOVE C,-4(P) ; REGOBBLE POINTER TO TEMPLATE
\r
2522 MOVE E,TD.PUT+1(TVP)
\r
2523 MOVE B,-6(P) ; RESTORE COUNT
\r
2525 MOVE E,(E) ; POINTER TO VECTOR IN E
\r
2526 ADDI E,(B)-1 ; POINT TO SLOT
\r
2527 MOVE B,-3(P) ; RESTORE TYPE WORD
\r
2529 SOS D,-1(P) ; GET ELEMENT #
\r
2530 XCT (E) ; SMASH IT BACK
\r
2531 FATAL TEMPLATE LOSSAGE
\r
2532 MOVE C,-4(P) ; RESTORE POINTER IN CASE MUNGED
\r
2535 TD.MR1: SUB P,[7,,7]
\r
2536 MOVSI D,400000 ; RESTORE MARK/UNMARK BIT
\r
2539 ; This phase attempts to remove any unwanted associations. The program
\r
2540 ; loops through the structure marking values of associations. It can only
\r
2541 ; stop when no new values (potential items and/or indicators) are marked.
\r
2543 VALFLS: PUSH P,[0] ; INDICATE WHETHER ANY ON THIS PASS
\r
2544 PUSH P,[0] ; OR THIS BUCKET
\r
2545 ASOMK1: MOVE A,ASOVEC+1(TVP) ; GET VECTOR POINTER
\r
2546 SETOM -1(P) ; INITIALIZE FLAG
\r
2548 ASOM6: SKIPG C,(A) ; SKIP IF BUCKET TO BE SCANNED
\r
2550 SETOM (P) ; SAY BUCKET NOT CHANGED
\r
2552 ASOM2: MOVEI F,(C) ; COPY POINTER
\r
2553 SKIPG ASOLNT+1(C) ; SKIP IF NOT ALREADY MARKED
\r
2554 JRST ASOM4 ; MARKED, GO ON
\r
2555 PUSHJ P,MARKQ ; SEE IF ITEM IS MARKED
\r
2556 JRST ASOM3 ; IT IS NOT, IGNORE IT
\r
2557 MOVEI F,(C) ; IN CASE CLOBBERED BY MARK2
\r
2558 MOVEI C,INDIC(C) ; POINT TO INDICATOR SLOT
\r
2560 JRST ASOM3 ; NOT MARKED
\r
2562 PUSH P,A ; HERE TO MARK VALUE
\r
2564 HLRE F,ASOLNT-INDIC+1(C) ; GET LENGTH
\r
2565 JUMPL F,.+3 ; SKIP IF MARKED
\r
2566 CAML C,VECBOT ; SKIP IF IN NOT VECT SPACE
\r
2568 PUSHJ P,MARK2 ; AND MARK
\r
2569 MOVEM A,1(C) ; LIST FIX UP
\r
2570 ADDI C,ITEM-INDIC ; POINT TO ITEM
\r
2573 ADDI C,VAL-ITEM ; POINT TO VALUE
\r
2576 IORM D,ASOLNT-VAL+1(C) ; MARK ASOC BLOCK
\r
2579 AOSA -1(P) ; INDICATE A MARK TOOK PLACE
\r
2581 ASOM3: AOS (P) ; INDICATE AN UNMARKED IN THIS BUCKET
\r
2582 ASOM4: HRRZ C,ASOLNT-1(F) ; POINT TO NEXT IN BUCKET
\r
2583 JUMPN C,ASOM2 ; IF NOT EMPTY, CONTINUE
\r
2584 SKIPGE (P) ; SKIP IF ANY NOT MARKED
\r
2585 HRROS (A) ; MARK BUCKET AS NOT INTERESTING
\r
2586 ASOM1: AOBJN A,ASOM6 ; GO TO NEXT BUCKET
\r
2587 TLZE TYPNT,.ATOM. ; ANY ATOMS MARKED?
\r
2588 JRST VALFLA ; YES, CHECK VALUES
\r
2591 ; NOW SEE WHICH CHANNELS STILL POINTED TO
\r
2593 CHNFL3: MOVEI 0,N.CHNS-1
\r
2594 MOVEI A,CHNL1(TVP) ; SLOTS
\r
2595 HRLI A,TCHAN ; TYPE HERE TOO
\r
2597 CHNFL2: SKIPN B,1(A)
\r
2600 SUBI B,(C) ; POINT TO DOPE
\r
2601 HLLM A,(A) ; PUT TYPE BACK
\r
2604 HLLOS (A) ; MARK AS A LOSER
\r
2611 SETZM -1(P) ; SAY MARKED
\r
2615 SKIPE GCHAIR ; IF NOT HAIRY CASE
\r
2618 SKIPL -1(P) ; SKIP IF NOTHING NEW MARKED
\r
2621 SUB P,[2,,2] ; REMOVE FLAGS
\r
2625 \f; HERE TO REEMOVE UNUSED ASSOCIATIONS
\r
2627 MOVE A,ASOVEC+1(TVP) ; GET ASOVEC BACK FOR FLUSHES
\r
2629 ASOFL1: SKIPN C,(A) ; SKIP IF BUCKET NOT EMPTY
\r
2630 JRST ASOFL2 ; EMPTY BUCKET, IGNORE
\r
2631 HRRZS (A) ; UNDO DAMAGE OF BEFORE
\r
2633 ASOFL5: SKIPGE ASOLNT+1(C) ; SKIP IF UNMARKED
\r
2634 JRST ASOFL3 ; MARKED, DONT FLUSH
\r
2636 HRRZ B,ASOLNT-1(C) ; GET FORWARD POINTER
\r
2637 HLRZ E,ASOLNT-1(C) ; AND BACK POINTER
\r
2638 JUMPN E,ASOFL4 ; JUMP IF NO BACK POINTER (FIRST IN BUCKET)
\r
2639 HRRZM B,(A) ; FIX BUCKET
\r
2642 ASOFL4: HRRM B,ASOLNT-1(E) ; FIX UP PREVIOUS
\r
2643 JUMPE B,.+2 ; JUMP IF NO NEXT POINTER
\r
2644 HRLM E,ASOLNT-1(B) ; FIX NEXT'S BACK POINTER
\r
2645 HRRZ B,NODPNT(C) ; SPLICE OUT THRAD
\r
2652 ASOFL3: HRRZ C,ASOLNT-1(C) ; GO TO NEXT
\r
2654 ASOFL2: AOBJN A,ASOFL1
\r
2656 ; NOW CLOBBER UNMARKED LOCAL NAD GLOBAL VALUES
\r
2658 MOVE A,GLOBSP+1(TVP) ; GET GLOBAL PDL
\r
2660 GLOFLS: SKIPGE (A) ; SKIP IF NOT ALREADY MARKED
\r
2661 JRST .+3 ; VIOLATE CARDINAL RULE #69
\r
2663 PUSHJ P,ZERSLT ; CLOBBER THE SLOT
\r
2664 ANDCAM D,(A) ; UNMARK
\r
2666 JUMPL A,GLOFLS ; MORE?, KEEP LOOPING
\r
2668 LOCFL1: HRRZ A,(LPVP) ; NOW CLOBBER LOCAL SLOTS
\r
2670 HLLZS 2(LPVP) ; NOW CLEAR
\r
2672 JUMPE A,LOCFL2 ; NONE TO FLUSH
\r
2674 LOCFLS: SKIPGE (A) ; MARKDE?
\r
2678 ANDCAM D,(A) ;UNMARK
\r
2679 HRRZ A,(A) ; GO ON
\r
2681 LOCFL2: JUMPN LPVP,LOCFL1 ; JUMP IF MORE PROCESS
\r
2686 MARK23: PUSH P,A ; SAVE BUCKET POINTER
\r
2692 AOS -2(P) ; MARKING HAS OCCURRED
\r
2693 IORM D,ASOLNT+1(C) ; MARK IT
\r
2696 \f; CHANNEL FLUSHER FOR NON HAIRY GC
\r
2698 CHNFLS: PUSH P,[-1]
\r
2699 SETOM (P) ; RESET FOR RETRY
\r
2706 ; VALUE FLUSHING PHASE, HACKS BOTTOM OF TP AND GLOBAL SP
\r
2708 VALFLA: MOVE C,GLOBSP+1(TVP)
\r
2710 VALFL1: SKIPL (C) ; SKIP IF NOT MARKED
\r
2711 PUSHJ P,MARKQ ; SEE IF ATOM IS MARKED
\r
2714 AOS -1(P) ; INDICATE MARK OCCURRED
\r
2716 HRRZ B,(C) ; GET POSSIBLE GDECL
\r
2717 JUMPE B,VLFL10 ; NONE
\r
2718 CAIN B,-1 ; MAINFIFEST
\r
2723 PUSHJ P,MARK ; MARK IT
\r
2724 MOVE C,(P) ; POINT
\r
2725 HRRM A,(C) ; CLOBBER UPDATE IN
\r
2726 VLFL10: ADD C,[2,,2] ; BUMP TO VALUE
\r
2727 PUSHJ P,MARK2 ; MARK VALUE
\r
2730 VALFL2: ADD C,[4,,4]
\r
2731 JUMPL C,VALFL1 ; JUMP IF MORE
\r
2733 HRLM LPVP,(P) ; SAVE POINTER
\r
2734 VALFL7: MOVEI C,(LPVP)
\r
2736 VALFL6: HRRM C,(P)
\r
2738 VALFL5: HRRZ C,(C) ; CHAIN
\r
2740 MOVEI B,TATOM ; TREAT LIKE AN ATOM
\r
2741 SKIPL (C) ; MARKED?
\r
2742 PUSHJ P,MARKQ1 ; NO, SEE
\r
2743 JRST VALFL5 ; LOOP
\r
2744 AOS -1(P) ; MARK WILL OCCUR
\r
2746 ADD C,[2,,2] ; POINT TO VALUE
\r
2747 PUSHJ P,MARK2 ; MARK VALUE
\r
2752 VALFL4: HRRZ C,(P) ; GET SAVED LPVP
\r
2754 HRRZ C,2(C) ; POINT TO NEXT
\r
2758 HRRM LPVP,2(A) ; NEW PROCESS WAS MARKED
\r
2761 ZERSLT: HRRI B,(A) ; COPY POINTER
\r
2766 VALFL9: HLRZ LPVP,(P) ; RESTORE CHAIN
\r
2770 \f;SUBROUTINE TO SEE IF A GOODIE IS MARKED
\r
2771 ;RECEIVES POINTER IN C
\r
2772 ;SKIPS IF MARKED NOT OTHERWISE
\r
2774 MARKQ: HLRZ B,(C) ;TYPE TO B
\r
2775 MARKQ1: MOVE E,1(C) ;DATUM TO C
\r
2777 CAIL 0,@PURBOT ; DONT CHACK PURE
\r
2778 JRST MKD ; ALWAYS MARKED
\r
2779 ANDI B,TYPMSK ; FLUSH MONITORS
\r
2781 HRRZ B,@TYPNT ;GOBBLE SAT
\r
2783 CAIG B,NUMSAT ; SKIP FOR TEMPLATE
\r
2784 JRST @MQTBS(B) ;DISPATCH
\r
2785 ANDI E,-1 ; FLUSH REST HACKS
\r
2789 DISTBS MQTBS,MKD,[[S2WORD,PAIRMQ],[S2DEFR,PAIRMQ],[SNWORD,VECMQ],[S2NWORD,VECMQ]
\r
2790 [STPSTK,VECMQ],[SARGS,ARGMQ],[SPSTK,VECMQ],[SFRAME,FRMQ],[SBYTE,BYTMQ],[SLOCID,LOCMQ]
\r
2791 [SATOM,VECMQ],[SPVP,VECMQ],[SLOCID,VECMQ],[SCHSTR,BYTMQ],[SLOCA,ARGMQ],[SLOCU,VECMQ]
\r
2792 [SLOCV,VECMQ],[SLOCS,BYTMQ],[SLOCN,ASMQ],[SASOC,ASMQ],[SLOCL,PAIRMQ],[SGATOM,VECMQ]]
\r
2794 PAIRMQ: JUMPE E,MKD ; NIL ALWAYS MARKED
\r
2795 SKIPL (E) ; SKIP IF MARKED
\r
2802 BYTMQ: HRRZ E,(C) ;GET DOPE WORD POINTER
\r
2803 SOJA E,VECMQ1 ;TREAT LIKE VECTOR
\r
2805 FRMQ: HRRZ E,(C) ; POINT TO PV DOPE WORD
\r
2809 VECMQ: HLRE 0,E ;GET LENGTH
\r
2810 SUB E,0 ;POINT TO DOPE WORDS
\r
2812 VECMQ1: SKIPGE 1(E) ;SKIP IF NOT MARKED
\r
2813 AOS (P) ;MARKED, CAUSE SKIP RETURN
\r
2816 ASMQ: SUBI E,ASOLNT
\r
2819 LOCMQ: HRRZ 0,(C) ; GET TIME
\r
2820 JUMPE 0,VECMQ ; GLOBAL, LIKE VECTOR
\r
2821 HLRE 0,E ; FIND DOPE
\r
2823 MOVEI E,1(E) ; POINT TO LAST DOPE
\r
2824 CAMN E,TPGROW ; GROWING?
\r
2825 SOJA E,VECMQ1 ; YES, CHECK
\r
2826 ADDI E,PDLBUF ; FUDGE
\r
2834 ;RETIME PHASE -- CALLED IFF A FRAME TIME HAS OVERFLOWED
\r
2835 ;RECEIVES POINTER TO STACK TO BE RECALIBRATED IN A
\r
2836 ;LEAVES HIGHEST TIME IN TIMOUT
\r
2838 RETIME: HLRE B,A ;GET LENGTH IN B
\r
2839 SUB A,B ;COMPUTE DOPE WORD LOCATION
\r
2840 MOVEI A,1(A) ;POINT TO 2D DOPE WORD AND CLEAR LH
\r
2841 CAME A,TPGROW ;IS THIS ONE BLOWN?
\r
2842 ADDI A,PDLBUF ;NO, POINT TO DOPE WORD
\r
2843 LDB B,[222100,,(A)] ;GET LENGTH FIELD (IGNOREING MARK BIT
\r
2844 SUBI A,-1(B) ;POINT TO PDLS BASE
\r
2845 MOVEI C,1 ;INITIALIZE NEW TIMES
\r
2847 RETIM1: SKIPGE B,(A) ;IF <0, HIT DOPE WORD OR FENCE POST
\r
2849 HLRZS B ;ISOLATE TYPE
\r
2850 CAIE B,TENTRY ;FRAME START?
\r
2851 AOJA A,RETIM2 ;NO, TRY BINDING
\r
2852 HRLM C,FRAMLN+OTBSAV(A) ;STORE NEW TIME
\r
2853 ADDI A,FRAMLN ;POINT TO NEXT ELEMENT
\r
2854 AOJA C,RETIM1 ;BUMP TIME AND MOVE ON
\r
2856 RETIM2: CAIE B,TUBIND
\r
2857 CAIN B,TBIND ;BINDING?
\r
2858 HRRM C,3(A) ;YES, STORE CURRENT TIME
\r
2859 AOJA A,RETIM1 ;AND GO ON
\r
2861 RETIM3: MOVEM C,TIMOUT ;SAVE TIME
\r
2867 \f; Core adjustment phase, try to win in all obscure cases!
\r
2869 CORADJ: MOVE A,P.TOP ; update AGCs core top
\r
2871 MOVE A,PARBOT ; figure out all the core needed
\r
2876 ADDI A,3777 ; account for gc pdl and round to block
\r
2879 CORAD3: CAMG A,PURTOP ; any way of winning at all?
\r
2880 JRST CORAD1 ; yes, go try
\r
2881 CORA33: SETOM GCDNTG ; no, can't even grow something
\r
2882 SETOM GCDANG ; or get current request
\r
2883 SKIPL C,PARNEW ; or move pairs up
\r
2885 MOVEM C,SPARNW ; save attempt in case of retry
\r
2887 CORAD6: MOVE A,CORTOP ; update core gotton with needed
\r
2888 ASH A,-10. ; to blocks
\r
2889 PUSHJ P,P.CORE ; try to get it (any lossage will retry)
\r
2891 CORA11: MOVE A,CORTOP ; compute new home for vectors
\r
2893 SUBI A,2000 ; remember gc pdl
\r
2895 POPJ P, ; return to main GC loop
\r
2897 ; Here if at least enough for growers
\r
2899 CORAD1: SKIPN B,GCDOWN ; skip if were called to get pure space
\r
2901 ADDI A,2000(B) ; A/ enough for move down and minimum free
\r
2902 CAMG A,PURTOP ; any chance of winning?
\r
2903 JRST CORAD4 ; yes, go win some
\r
2905 ; Here if cant move down
\r
2907 SETOM GCDANG ; complain upon return
\r
2908 SUBI A,2000(B) ; reset for re-entry into loop
\r
2909 CAMLE A,PURTOP ; win?
\r
2912 ; Here if may be able to grant current request
\r
2914 CORAD2: ADD A,GETNUM ; A/ total neede including request
\r
2915 ADD A,CURPLN ; dont give self away or something
\r
2916 ADDI A,3777 ; at least one free block and round
\r
2917 ANDCMI A,1777 ; to block boundary
\r
2918 CAMG A,PURTOP ; any hope of this?
\r
2919 JRST CORAD5 ; yes, now see if some slop space can appear
\r
2921 SETOM GCDANG ; tell caller we lost
\r
2922 MOVE A,PURTOP ; try to get as much as possible anyway
\r
2925 CORAD8: ASH A,-10. ; to pages
\r
2927 FATAL PAGES NOT AVAILABLE
\r
2928 MOVSI D,400000 ; wipes out D
\r
2929 MOVE A,PURBOT ; and use current PURBOT as new core top
\r
2930 SUBI A,2000 ; for gc pdl
\r
2932 JRST CORAD6 ; and allocate necessary pages
\r
2934 ; Here if real necessities taken care of, try for slop space
\r
2936 CORAD5: ADD A,FREMIN ; try for minimum
\r
2937 SUBI A,2000-1777 ; round and flush min 2000 of before
\r
2938 ANDCMI A,1777 ; round to block boundary
\r
2939 CAMG A,PURTOP ; again, do we win?
\r
2940 JRST CORAD7 ; yes, we win totally
\r
2942 ; Here if cant get desired free but get some
\r
2944 MOVE A,PURTOP ; compute pages to flush
\r
2945 SUB A,CURPLN ; again dont flush current prog
\r
2946 SUB A,PURBOT ; A/ words to get
\r
2947 JRST CORAD8 ; go do it
\r
2949 ; Here if can get all the free we want
\r
2951 CORAD7: SUB A,CURPLN
\r
2952 CAMG A,PURBOT ; do any pages get the ax?
\r
2953 JRST CORAD9 ; no, see if can give core back!
\r
2954 SUB A,PURBOT ; words to get purely
\r
2957 CORAD9: CAMG A,CORTOP ; skip if must get core
\r
2960 JRST CORAD6 ; and go get it
\r
2962 ; Here if still may have to give it back
\r
2964 CORA10: MOVE B,CORTOP
\r
2966 CAMG B,FREDIF ; skip if giving awy
\r
2969 CORA12: MOVEM A,CORTOP
\r
2971 MOVEM A,CORSET ; leave to shrink later
\r
2974 ; Here if going down to also get free space
\r
2976 CORAD4: SUBI A,2000 ; uncompensate for min
\r
2978 CAML A,CORTOP ; skip if ok for max
\r
2979 MOVE A,CORTOP ; else use up to pure
\r
2980 SUB A,GCDOWN ; new CORTOP to A
\r
2981 JRST CORA12 ; go set up final shrink
\r
2983 ; routine to wait for core
\r
2988 SOS (P) ; ret to prev ins
\r
2991 CORADL: PUSHJ P,P.CORE ;SET TO NEW CORE VALUE
\r
2992 FATAL AGC--CANT CORE DOWN
\r
2994 \f;VECTOR RELOCATE --GETS VECTOP IN A
\r
2996 ;FILLS IN RELOCATION FIELDS OF MARKED VECTORS
\r
2997 ;AND REUTRNS FINAL VECNEW IN B
\r
2999 VECREL: CAMG A,VECBOT ;PROCESSED TO BOTTOM OF VECTOR SPACE?
\r
3000 POPJ P, ;YES, RETURN
\r
3001 HLRE C,(A) ;GET COUNT FROM DOPE WD, EXTEND MARK BIT
\r
3002 JUMPL C,VECRE1 ;IF MARKED GO PROCESS
\r
3003 HRRM A,(A) ; INDICATE NON-MOVE BY LEAVING SAME
\r
3004 SUBI A,(C) ;MOVE ON TO NEXT VECTOR
\r
3005 SOJG C,VECREL ;AND KEEP SCANNING
\r
3006 JSP D,VCMLOS ;LOSER, LEAVE TRACKS AS TO WHO LOST
\r
3008 VECRE1: HRRZ E,-1(A) ;GOBBLE THE GROWTH FILEDS
\r
3009 HRRM B,(A) ;STORE RELOCATION
\r
3010 JUMPE E,VECRE2 ;NO GROWTH (OR SHRINKAGE), GO AWAY
\r
3011 LDB F,[111100,,E] ;GET TOP GROWTH IN F
\r
3012 TRZN F,400 ;CHECK AND FLUSH SIGN
\r
3013 MOVNS F ;WAS ON, NEGATE
\r
3014 SKIPE GCDNTG ; SKIP IF GROWTH OK
\r
3015 JUMPL F,VECRE3 ; DONT ALLOW POSITIVE GROWTH
\r
3016 ASH F,6 ;CONVERT TO WORDS
\r
3017 ADD B,F ;UPDATE RELOCATION
\r
3018 HRRM B,(A) ;AND STORE IT
\r
3019 VECRE3: ANDI E,777 ;ISOLATE BOTTOM GROWTH
\r
3020 TRZN E,400 ;CHECK AND CLEAR SIGN
\r
3022 SKIPE GCDNTG ; SKIP IF GROWTH OK
\r
3024 ASH E,6 ;CONVERT TO WORDS
\r
3025 ADD B,E ;UPDATE FUTURE RELOCATIONS
\r
3026 VECRE2: SUBI A,400000(C) ;AND MOVE ON TO NEXT VECTOR
\r
3027 ANDI C,377777 ;KILL MARK
\r
3028 SUBI B,(C) ; UPDATE WHERE TO GO LOCN
\r
3029 SOJG C,VECREL ;AND KEEP GOING
\r
3030 JSP D,VCMLOS ;LOSES, LEAVE TRACKS
\r
3032 ;PAIR SPACE UPDATE
\r
3034 ;GETS PARBOT IN AC A
\r
3035 ;UPDATES VALUES AND CDRS UP TO PARTOP
\r
3037 PARUPD: CAML A,PARTOP ;ARE THERE MORE PAIRS TO PROCESS
\r
3038 POPJ P, ;NO -- RETURN
\r
3040 ;UPDATE VALUE CELL
\r
3041 PARUP1: ANDCAM D,(A) ; KILL MARK BIT
\r
3042 HLRZ B,(A) ;SET RH OF B TO TYPE
\r
3043 MOVE C,1(A) ;SET C TO VALUE
\r
3044 PUSHJ P,VALUPD ;UPDATE THIS VALUE
\r
3045 ADDI A,2 ;MOVE ON TO NEXT PAIR
\r
3046 JRST PARUPD ;AND CONTINUE
\r
3049 \f;VECTOR SPACE UPDATE
\r
3051 ;UPDATES ALL VALUE CELLS IN MARKED VECTORS
\r
3052 ;ESCAPES WHEN IT GETS TO VECBOT
\r
3054 VECUPD: SUBI A,1 ;MAKE A POINT TO LAST DOPE WD
\r
3060 ; STORAGE SPACE UPDATE
\r
3062 STOUP: PUSH P,[STOSTR]
\r
3067 VECUP1: CAMG A,-1(P) ;ANY MORE VECTORS TO PROCESS?
\r
3069 SKIPGE B,(A) ;IS DOPE WORD MARKED?
\r
3070 JRST VECUP2 ;YES -- GO PROCESS VALUES IN THIS VECTOR
\r
3071 HLLZS -1(A) ;MAKE SURE NO GROWTH ATTEMPTS
\r
3072 HLRZS B ;NO -- SET RH OF B TO SIZE OF VECTOR
\r
3073 VECUP5: SUB A,B ;SET A TO POINT TO DOPE WD OF NEXT VECTOR
\r
3074 JRST VECUP1 ;AND CONTINUE
\r
3076 VECUP2: PUSH P,A ;SAVE DOPE WORD POINTER
\r
3077 HLRZ B,(A) ;GET LENGTH OF THIS VECTOR
\r
3078 VECU11: ANDI B,377777 ;TURN OFF MARK BIT
\r
3079 SKIPGE E,-1(A) ;CHECK FOR UNIFORM OR SPECIAL
\r
3080 TLNE E,377777 ;SKIP IF GENERAL
\r
3081 JRST VECUP6 ;UNIFORM OR SPECIAL, GO DO IT
\r
3082 VECU10: SUB A,B ;SET AC A TO NEXT DOPE WORD
\r
3083 ADDI A,1 ;AND ADVANCE TO FIRST ELEMENT OF THIS VECTOR
\r
3084 VECUP3: HLRZ B,(A) ;GET TYPE
\r
3085 TRNE B,400000 ;IF MARK BIT SET
\r
3086 JRST VECUP4 ;DONE WITH THIS VECTOR
\r
3089 CAIN B,TENTRY ;SPECIAL HACK FOR ENTRY
\r
3092 CAIN B,TSKIP ; SKIP POINTER
\r
3093 JRST BINDUP ; HACK APPROPRAITELY
\r
3094 CAIE B,TBVL ;VECTOR BINDING?
\r
3095 CAIN B,TBIND ;AND BINDING BLOCK
\r
3099 VECU15: MOVE C,1(A) ;GET VALUE
\r
3100 PUSHJ P,VALUPD ;UPDATE THIS VALUE
\r
3101 VECU12: ADDI A,2 ;GO ON TO NEXT VECTOR
\r
3102 JRST VECUP3 ;AND CONTINUE
\r
3104 VECUP4: POP P,A ;SET TO OLD DOPE WORD
\r
3105 ANDCAM D,(A) ;TURN OFF MARK BIT
\r
3106 HLRZ B,(A) ;GET LENGTH
\r
3107 ANDI B,377777 ; IN CASE DING STORAGE
\r
3108 JRST VECUP5 ;GO ON TO NEXT VECTOR
\r
3112 ;UPDATE A SAVED SAVE BLOCK
\r
3113 ENTSUP: MOVEI A,FRAMLN+SPSAV-1(A) ;A POINTS BEFORE SAVED SP
\r
3115 PUSHJ P,VALPD1 ;UPDATE SPSAV
\r
3116 MOVEI A,PSAV-SPSAV(A)
\r
3118 PUSHJ P,VALPD1 ;UPDATE PSAV
\r
3119 MOVEI A,TPSAV-PSAV(A)
\r
3121 PUSHJ P,VALPD1 ;UPDATE TPSAV
\r
3122 ;SKIP TO END OF BLOCK
\r
3127 IGBLK2: HRRZ B,(A) ;GET DISPLACEMENT
\r
3128 ADDI A,3(B) ;USE IT
\r
3131 \f; ENTRY PART OF THE STACK UPDATER
\r
3133 ENTRUP: ADDI A,FRAMLN-2 ;POINT PAST FRAME
\r
3134 JRST VECU12 ;NOW REJOIN VECTOR UPDATE
\r
3136 ; UPDATE A BINDING BLOCK
\r
3138 BINDUP: HRRZ C,(A) ;POINT TO CHAIN
\r
3139 JUMPE C,NONEXT ;JUMP IF NO NEXT BINDING IN CHAIN
\r
3140 HRRZ 0,@(P) ; GET OWN DESTINATION
\r
3141 SUBI 0,@(P) ; RELATIVIZE
\r
3142 ADD C,0 ; AND UPDATE
\r
3143 HRRM C,(A) ;AND STORE IT BACK
\r
3144 NONEXT: CAIN B,TUBIND
\r
3146 CAIE B,TBIND ;SKIP IF VAR BINDING
\r
3147 JRST VECU14 ;NO, MUST BE A VECTOR BIND
\r
3148 MOVEI B,TATOM ;UPDATE ATOM POINTER
\r
3151 HLRZ B,(A) ;TYPE OF VALUE
\r
3153 ADDI A,2 ; POINT TO PREV LOCATIVE
\r
3154 VECU16: MOVEI B,TLOCI
\r
3155 SKIPN 1(A) ; IF NO LOCATIVE,
\r
3156 MOVEI B,TUNBOU ; SAY UNBOUND
\r
3160 VECU14: CAIN B,TBVL ; CHANGE BVL TO VEC
\r
3161 MOVEI B,TVEC ;NOW TREAT LIKE A VECTOR
\r
3164 ; NOW SAFE TO UPDATE ALL ENTRY BLOCKS
\r
3166 ENHACK: HRRZ F,TBSTO(LPVP) ;GET POINTER TO TOP FRAME
\r
3167 HLLZS TBSTO(LPVP) ;CLEAR FIELD
\r
3169 JUMPE F,LSTFRM ;FINISHED
\r
3171 ENHCK1: MOVEI A,FSAV-1(F) ;POINT PRIOR TO SAVED FUNCTION
\r
3172 HRRZ C,1(A) ; GET POINTER TO FCN
\r
3173 CAML C,VECBOT ; SKIP IF A LOSER
\r
3174 CAMLE C,VECTOP ; SKIP IF A WINNER
\r
3176 HRL C,(C) ; MAKE INTO AOBJN
\r
3178 PUSHJ P,VALUPD ; AND UPDATE
\r
3179 ENHCK2: HRRZ F,2(A) ;POINT TO PRIOR FRAME
\r
3180 MOVEI B,TTB ;MARK SAVED TB
\r
3181 PUSHJ P,[AOJA A,VALPD1]
\r
3182 MOVEI B,TAB ;MARK ARG POINTER
\r
3183 PUSHJ P,[AOJA A,VALPD1]
\r
3184 MOVEI B,TSP ;SAVED SP
\r
3185 PUSHJ P,[AOJA A,VALPD1]
\r
3186 MOVEI B,TPDL ;SAVED P STACK
\r
3187 PUSHJ P,[AOJA A,VALPD1]
\r
3188 MOVEI B,TTP ;SAVED TP
\r
3189 PUSHJ P,[AOJA A,VALPD1]
\r
3190 JUMPN F,ENHCK1 ;MARK NEXT ONE IF IT EXISTS
\r
3192 LSTFRM: HRRZ A,BINDID(LPVP) ;NEXT PROCESS
\r
3193 HLLZS BINDID(LPVP) ;CLOBBER
\r
3195 JUMPN LPVP,ENHACK ;DO NEXT PROCESS
\r
3198 \f; UPDATE ELEMENTS IN UNIFROM AND SPECIAL VECTORS
\r
3200 VECUP6: JUMPL E,VECUP7 ;JUMP IF SPECIAL
\r
3201 CAIG B,2 ;EMPTY UVECTOR ?
\r
3202 JRST VECUP4 ;YES, NOTHING TO UPDATE
\r
3203 HLRZS E ;ISOLATE TYPE
\r
3205 EXCH E,B ;TYPE TO B AND LENGTH TO E
\r
3206 SUBI A,(E) ;POINT TO NEXT DOPE WORD
\r
3210 MOVE B,UPDTBS(B) ;FIND WHERE POINTS
\r
3211 CAIN B,CPOPJ ;UNMARKED?
\r
3212 JRST VECUP4 ;YES, GO ON TO NEXT VECTOR
\r
3213 PUSH P,B ;SAVE SR POINTER
\r
3214 SUBI E,2 ;DON'T COUNT DOPE WORDS
\r
3216 VECUP8: MOVE C,1(A) ;GET GOODIE
\r
3217 MOVEI 0,(C) ; ISOLATE ADDR
\r
3218 JUMPE 0,.+3 ; NEVER 0 PNTR
\r
3219 CAIGE 0,@PURBOT ; OR IF PURE
\r
3220 PUSHJ P,@(P) ;CALL UPDATE ROUTINE
\r
3222 SOJG E,VECUP8 ;LOOP FOR ALL ELEMNTS
\r
3224 SUB P,[1,,1] ;REMOVE RANDOMNESS
\r
3227 ; SPECIAL VECTOR UPDATE
\r
3229 VECUP7: HLRZS E ;ISOLATE SPECIAL TYPE
\r
3230 CAIN E,SATOM+400000 ;ATOM?
\r
3231 JRST ATOMUP ;YES, GO DO IT
\r
3232 CAIN E,STPSTK+400000 ;STACK
\r
3233 JRST VECU10 ;TREAT LIKE A VECTOR
\r
3234 CAIN E,SPVP+400000 ;PROCESS VECTOR
\r
3235 JRST PVPUP ;DO SPECIAL STUFF
\r
3236 CAIN E,SASOC+400000
\r
3237 JRST ASOUP ;UPDATE ASSOCIATION BLOCK
\r
3239 TRZ E,400000 ; CHECK FOR TEMPLATE VECTOR
\r
3240 CAIG E,NUMSAT ; SKIP IF POSSIBLE
\r
3241 FATAL AGC--UNRECOGNIZED SPECIAL VECTOR (UPDATE)
\r
3242 MOVEI E,-NUMSAT-1(E)
\r
3244 ADD E,TD.LNT+1(TVP)
\r
3246 FATAL AGC--BAD TEMPLATE TYPE
\r
3248 TD.UPD: MOVEI C,-1(A) ; POINTER TO OBJECT IN C
\r
3250 HLRZ D,B ; POSSIBLE BASIC LENGTH
\r
3253 MOVEI B,(B) ; ISOLATE LENGTH
\r
3254 PUSH P,C ; SAVE POINTER TO OBJECT
\r
3256 PUSH P,[0] ; HOME FOR VALUES
\r
3257 PUSH P,[0] ; SLOT FOR TEMP
\r
3259 SUB E,TD.LNT+1(TVP)
\r
3260 PUSH P,E ; SAVE FOR FINDING OTHER TABLES
\r
3261 JUMPE D,TD.UP2 ; NO REPEATING SEQ
\r
3262 ADD E,TD.GET+1(TVP) ; COMP LNTH OF REPEATING SEQ
\r
3263 HLRE E,(E) ; E ==> - LNTH OF TEMPLATE
\r
3264 ADDI E,(D) ; E ==> -LENGTH OF REP SEQ
\r
3266 HRLM E,-5(P) ; SAVE IT AND BASIC
\r
3268 TD.UP2: SKIPG D,-1(P) ; ANY LEFT?
\r
3271 MOVE E,TD.GET+1(TVP)
\r
3273 MOVE E,(E) ; POINTER TO VECTOR IN E
\r
3274 MOVEM D,-6(P) ; SAVE ELMENT #
\r
3275 SKIPN B,-5(P) ; SKIP IF "RESTS" EXIST
\r
3278 MOVEI 0,(B) ; BASIC LNT TO 0
\r
3279 SUBI 0,(D) ; SEE IF PAST BASIC
\r
3280 JUMPGE 0,.-3 ; JUMP IF O.K.
\r
3281 MOVSS B ; REP LNT TO RH, BASIC TO LH
\r
3282 IDIVI 0,(B) ; A==> -WHICH REPEATER
\r
3284 ADD A,-5(P) ; PLUS BASIC
\r
3285 ADDI A,1 ; AND FUDGE
\r
3286 MOVEM A,-6(P) ; SAVE FOR PUTTER
\r
3287 ADDI E,-1(A) ; POINT
\r
3290 TD.UP3: ADDI E,(D) ; POINT TO SLOT
\r
3291 XCT (E) ; GET THIS ELEMENT INTO A AND B
\r
3292 MOVEM A,-3(P) ; SAVE TYPE FOR LATER PUT
\r
3294 MOVE C,B ; VALUE TO C FOR VALUPD
\r
3296 MOVEI A,-3(P) ; TELL OTHER GUYS THEY CANT DIRECTLY MUNG
\r
3297 MOVSI D,400000 ; RESET FOR MARK
\r
3298 PUSHJ P,VALUPD ; AND MARK THIS GUY (RET FIXED POINTER IN A)
\r
3299 MOVE C,-4(P) ; GET POINTER FOR UPDATE OF ELEMENT
\r
3300 MOVE E,TD.PUT+1(TVP)
\r
3301 SOS D,-1(P) ; RESTORE COUNT
\r
3303 MOVE E,(E) ; POINTER TO VECTOR IN E
\r
3304 MOVE B,-6(P) ; SAVED OFFSET
\r
3305 ADDI E,(B)-1 ; POINT TO SLOT
\r
3306 MOVE A,-3(P) ; RESTORE TYPE WORD
\r
3308 XCT (E) ; SMASH IT BACK
\r
3309 FATAL TEMPLATE LOSSAGE
\r
3313 TD.UP1: SUB P,[7,,7]
\r
3314 MOVSI D,400000 ; RESTORE MARK/UNMARK BIT
\r
3317 \f; UPDATE ATOM VALUE CELLS
\r
3319 ATOMUP: SUBI A,-1(B) ; POINT TO VALUE CELL
\r
3321 HRRZ 0,(A) ;GOBBLE BINDID
\r
3322 JUMPN 0,.+3 ;NOT GLOBAL
\r
3323 CAIN B,TLOCI ;IS IT A LOCATIVE?
\r
3324 MOVEI B,TVEC ;MARK AS A VECTOR
\r
3325 HRRZ 0,1(A) ; GET POINTER
\r
3328 JRST .+2 ; OUT OF BOUNDS, DONT UPDATE
\r
3329 PUSHJ P,VALPD1 ;UPDATE IT
\r
3330 MOVEI B,TOBLS ; TYPE TO OBLIST
\r
3332 PUSHJ P,[AOJA A,VALPD1]
\r
3335 ; UPDATE PROCESS VECTOR
\r
3337 PVPUP: SUBI A,-1(B) ;POINT TO TOP
\r
3338 HRRM LPVP,BINDID(A) ;CHAIN ALL PROCESSES TOGETHER
\r
3340 HRRZ 0,TBSTO+1(A) ;POINT TO CURRENT FRAME
\r
3341 HRRM 0,TBSTO(A) ;SAVE
\r
3342 HRRZ 0,TPSTO+1(A) ;0_SAVED TP POINTER
\r
3344 SUBI 0,-1(B) ;0 _ POINTER TO OLD DOPE WORD
\r
3349 \f;THIS SUBROUTINE TAKES CARE OF UPDATING ASSOCIATION BLOCKS
\r
3351 ASOUP: SUBI A,-1(B) ;POINT TO START OF BLOCK
\r
3352 HRRZ B,ASOLNT-1(A) ;POINT TO NEXT
\r
3354 HRRZ C,ASOLNT+1(B) ;AND GET ITS RELOC IN C
\r
3355 SUBI C,ASOLNT+1(B) ; RELATIVIZE
\r
3356 ADDM C,ASOLNT-1(A) ;C NOW HAS UPDATED PONTER
\r
3357 ASOUP1: HLRZ B,ASOLNT-1(A) ;GET PREV BLOCK POINTER
\r
3359 HRRZ F,ASOLNT+1(B) ;AND ITS RELOCATION
\r
3360 SUBI F,ASOLNT+1(B) ; RELATIVIZE
\r
3362 ADDM F,ASOLNT-1(A) ;RELOCATE
\r
3363 ASOUP2: HRRZ B,NODPNT(A) ;UPDATE NODE CHAIN
\r
3365 HRRZ C,ASOLNT+1(B) ;GET RELOC
\r
3366 SUBI C,ASOLNT+1(B) ; RELATIVIZE
\r
3367 ADDM C,NODPNT(A) ;ANID UPDATE
\r
3368 ASOUP4: HLRZ B,NODPNT(A) ;GET PREV POINTER
\r
3370 HRRZ F,ASOLNT+1(B) ;RELOC
\r
3371 SUBI F,ASOLNT+1(B)
\r
3374 ASOUP5: HRLI A,-3 ;SET TO UPDATE OTHER CONTENTS
\r
3376 ASOUP3: HLRZ B,(A) ;GET TYPE
\r
3377 PUSHJ P,VALPD1 ;UPDATE
\r
3378 ADD A,[1,,2] ;MOVE POINTER
\r
3380 JRST VECUP4 ;AND QUIT
\r
3382 \f;VALUPD UPDATES A SINLE VALUE FROM EITHER PAIR SPACE OR VECTOR SPACE
\r
3383 ;GETS POINTER TO TYPE CELL IN RH OF A
\r
3384 ;TYPE IN RH OF B (LH MUST BE 0)
\r
3387 VALPD1: MOVE C,1(A) ;GET VALUE TO UPDATE
\r
3388 VALUPD: MOVEI 0,(C)
\r
3389 CAIGE 0,@PURBOT ; SKIP IF PURE, I.E. DONT HACK
\r
3390 TRNN C,-1 ;ANY POINTER PART?
\r
3391 JRST CPOPJ ;NO, LEAVE
\r
3393 LSH B,1 ;SET TYPE TIMES 2
\r
3394 HRRZ B,@TYPNT ;GET STORAGE ALLOCATION TYPE
\r
3396 CAIG B,NUMSAT ; SKIP IF TEMPLATE
\r
3397 JRST @UPDTBS(B) ;AND DISPATCH THROUGH STORAGE ALLOCATION DISPATCH TABLE
\r
3400 ;SAT DISPATCH TABLE
\r
3402 DISTBS UPDTBS,CPOPJ,[[SNWORD,NWRDUP],[STPSTK,STCKUP]
\r
3403 [SFRAME,FRAMUP],[STBASE,TBUP],[SARGS,ARGUP],[SBYTE,BYTUP],[SATOM,NWRDUP],[SPSTK,STCKUP]
\r
3404 [SLOCID,LOCUP],[SPVP,NWRDUP],[S2NWORD,NWRDUP],[SABASE,ABUP],[SCHSTR,BYTUP],[SASOC,ASUP]
\r
3405 [SLOCA,ARGUP],[SLOCU,NWRDUP],[SLOCN,ASUP],[SLOCS,BYTUP],[SGATOM,NWRDUP]]
\r
3410 ;PAIR POINTER UPDATE
\r
3411 2WDUP: MOVEI 0,(C)
\r
3412 CAIGE 0,@PURBOT ; SKIP AND IGNORE IF PURE
\r
3413 TRNN C,-1 ;POINT TO NIL?
\r
3414 POPJ P, ;YES -- NO UPDATE NEEDED
\r
3415 SKIPGE B,(C) ;NO -- IS THIS A BROKEN HEART
\r
3416 HRRM B,1(A) ;YESS -- STORE NEW VALUE
\r
3417 SKIPE B,PARNEW ;IF LIST SPACE IS MOVING
\r
3418 ADDM B,1(A) ;THEN ADD OFFSET TO VALUE
\r
3421 ; HERE TO UPDATE ASSOCIATIONS
\r
3423 ASUP: HRLI C,-ASOLNT ;MAKE INTO VECTOR POINTER
\r
3425 \f;VECTOR, ATOM, STACK, AND BASE POINTER UPDATE
\r
3427 LOCUP: HRRZ B,(A) ;CHECK IF IT IS TIMED
\r
3428 JUMPN B,LOCUP1 ;JUMP IF TIMED, OTHERWISE TREAT LIKE VECTORE
\r
3430 NWRDUP: HLRE B,C ;EXTEND COUNT IN B
\r
3431 SUBI C,-1(B) ;SET C TO POINT TO DOPE WORD
\r
3432 TMPLUP: HRRZ B,(C) ;EXTEND RELOCATION IN B
\r
3433 SUBI B,(C) ; RELATIVIZE
\r
3434 ADDM B,1(A) ;AND ADD RELOCATION TO STORED DATUM
\r
3435 HRRZ C,-1(C) ;GET GROWTH SPECS
\r
3436 JUMPE C,CPOPJ ;NO GROWTH, LEAVE
\r
3437 LDB C,[111100,,C] ;GET UPWORD GROWTH
\r
3438 TRZN C,400 ;FLUSH SIGN AN NEGATR DIRECTION
\r
3440 SKIPE GCDNTG ; SKIP IF GROWTH WINS
\r
3441 JUMPL C,CPOPJ ; POS GROWTH, LOSE
\r
3442 ASH C,6+18. ;TO LH AND TIMES 100(8)
\r
3443 ADDM C,1(A) ;UPDATE POINTER
\r
3448 STCKUP: MOVSI B,PDLBUF ;GET OFFSET FOR PDLS
\r
3449 ADDM B,1(A) ;AND ADD TO COUNT
\r
3450 JRST NWRDUP ;NOW TREAT LIKE VECTOR
\r
3452 BYTUP: MOVEI C,(A) ; SET TO GET DOPE WORD
\r
3456 HRRZ B,(A) ;SET B TO RELOCATION FOR THIS VEC
\r
3457 SUBI B,(A) ; RELATIVIZE
\r
3458 ADDM B,1(C) ;AND UPDATE VALUE
\r
3459 MOVE A,C ; FIX UP FOR SCANNER
\r
3460 POPJ P, ;DONE WITH UPDATE
\r
3463 ABUP: HLRE B,C ;GET LENGTH
\r
3464 SUB C,B ;POINT TO FRAME
\r
3465 HLRZ B,(C) ;GET TYPE OF NEXT GOODIE
\r
3467 CAIN B,TINFO ;IS IT A FRAME
\r
3468 ADD C,1(C) ;NO, POINT TO FRAME
\r
3469 CAIE B,TINFO ;IF IT IS A FRAME
\r
3470 ADDI C,FRAMLN ;POINT TO ITS BASE
\r
3471 TBUP: MOVE C,TPSAV(C) ;GET A ASTACK POINTER TO FIND DOPE WORD
\r
3472 HLRE B,C ;UPDATE BASED ON THIS POINTER
\r
3474 ABUP1: HRRZ B,1(C) ;GET RELOCATION
\r
3475 SUBI B,1(C) ; RELATIVIZE
\r
3476 ADDM B,1(A) ;AND MUNG POINTER
\r
3479 FRAMUP: HRRZ B,(A) ;UPDATE PVP
\r
3480 HRRZ C,(B) ;IN CELL
\r
3481 SUBI C,(B) ; RELATIVIZE
\r
3485 SUBI B,-1(C) ;ADDRESS OF PV
\r
3486 HRRZ C,TPSTO(B) ;IF TPSTO HAS OLD TP DOPE WORD,
\r
3487 JUMPN C,ABUP2 ;USE IT
\r
3488 HRRZ C,TPSTO+1(B) ;ELSE, GENERATE IT
\r
3491 ABUP2: SOJA C,ABUP1 ; FUDGE AND GO
\r
3493 \f;VECTOR SHRINKING PHASE
\r
3495 VECSH: SUBI A,1 ;POOINT TO 1ST DOPE WORD
\r
3496 VECSH1: CAMGE A,VECBOT ;FINISHED
\r
3497 POPJ P, ;YES, QUIT
\r
3498 HRRZ B,-1(A) ;GET A SPEC
\r
3499 JUMPE B,NXTSHN ;IGNORE IF NONE
\r
3500 PUSHJ P,GETGRO ;GET THE SPECS
\r
3501 JUMPGE C,SHRNBT ;SHRINKIGN AT BOTTOM
\r
3502 MOVEI E,(A) ;COPY POINTER
\r
3503 ADD A,C ;POINT TO NEW DOPE LOCATION WITH E
\r
3504 MOVE F,-1(E) ;GET OLD DOPE
\r
3505 ANDCMI F,777000 ;KILL THIS SPEC
\r
3506 MOVEM F,-1(A) ;STORE
\r
3507 MOVE F,(E) ;OTHER DOPE WORD
\r
3508 ADD F,C ; UPDATE DESTINATION
\r
3509 HRLZI C,(C) ;TO LH
\r
3510 ADD F,C ;CHANGE LENGTH
\r
3511 MOVEM F,(A) ;AND STORE
\r
3513 HRRI C,(E) ; MAKE NOT MOVE
\r
3514 MOVEM C,(E) ;AND STORE
\r
3516 SHRNBT: JUMPGE B,NXTSHN ;GROWTH, IGNOORE
\r
3517 MOVM E,B ;GET A POSITIVE COPY
\r
3518 HRLZI B,(B) ;TO LH
\r
3519 ADDM B,(A) ;ADD INTO DOPE WORD
\r
3520 MOVEI 0,777 ;SET TO CLOBBER GROWTH
\r
3521 ANDCAM 0,-1(A) ;CLOBBER
\r
3522 HLRZ B,(A) ;GET NEW LENGTH
\r
3523 SUBI A,(B) ;POINT TO LOW END
\r
3524 HRLI E,(A) ; MAKE NON MOVER
\r
3525 MOVSM E,(A) ;STORE
\r
3528 NXTSHN: HLRZ B,(A) ;GET LENGTH
\r
3529 JUMPE B,VCMLOS ;LOOSE
\r
3533 GETGRO: LDB C,[111100,,B] ;GET UPWARD GROWTH
\r
3534 TRZE C,400 ;CHECK AND MUNG SIGN
\r
3536 ASH C,6 ;?IMES 100
\r
3537 ANDI B,777 ;AND GET DOWN GROWTH
\r
3538 TRZE B,400 ;CHECK AND MUNG SIGN
\r
3542 \f;VECMOV -- MOVES VECTOR DATA TO WHERE RELOC FIELDS OF
\r
3543 ;VECTORS INDICATE. MOVES DOPEWDS UP FOR VECTORS GROWING AT
\r
3545 ;CALLED WITH VECTOP IN A. CALLS PARMOV TO MOVE PAIRS
\r
3547 VECMOV: SUBI A,1 ;SET A TO ADDR OF TOP DOPE WD
\r
3548 MOVSI D,400000 ;NEGATIVE D MARKS END OF BACK CHAIN
\r
3549 MOVEI TYPNT,0 ;CLEAR ON GOING ADDRESS FOR FORWARD RESUME
\r
3550 VECMO1: CAMGE A,VECBOT ;GOT TO BOTTOM OF VECTORS
\r
3551 JRST PARMOV ;YES, MOVE LIST ELEMENTS AND RETURN
\r
3552 MOVEI C,(A) ;NO, COPY ADDR OF THIS DOPEWD
\r
3553 HRRZ B,(A) ;GET RELOCATION OF THIS VECTOR
\r
3554 SUBI B,(A) ; RELATIVIZE
\r
3555 JUMPL B,VECMO5 ;IF MOVING DOWNWARD, MAKE BACK CHAIN
\r
3556 JUMPE B,VECMO4 ;IF NON MOVER, JUST ADJUST DOPW AND MOVE ON
\r
3558 ADDI C,(B) ;SET ADDR OF LAST DESTINATION WD
\r
3559 HRLI B,A ;MAKE B INDEX ON A
\r
3560 HLL A,(A) ;COUNT TO A LEFT HALF
\r
3562 POP A,@B ;MOVE A WORD
\r
3563 TLNE A,-1 ;REACHED END OF MOVING
\r
3564 JRST .-2 ;NO, REPEAT
\r
3565 ;YES, NOTE A HAS ADDR OF NEXT DOPEWD
\r
3566 \f;HERE TO ADJUST LOCATION OF DOPEWDS FOR GROWTH (FORWARDLY)
\r
3567 VECMO2: LDB B,[111000,,-1(C)] ;GET HIGH GROWTH FIELD
\r
3568 JUMPE B,VECMO3 ;IF NO GROWTH, DONT MOVE
\r
3569 SKIPE GCDNTG ; SKIP IF GROWTH PERMITTED
\r
3571 ASH B,6 ;EXPRESS GROWTH IN WORDS
\r
3572 HRLI C,2 ;SET COUNT FOR POPPING 2 DOPEWDS
\r
3573 HRLI B,C ;MAKE B INDEX ON C
\r
3574 POP C,@B ;MOVE PRIME DOPEWD
\r
3575 POP C,@B ;MOVE AUX DOPEWD
\r
3576 VECMO3: JUMPL D,VECMO1 ;IF NO BACK CHAIN THEN MOVE ON
\r
3577 JRST VECMO6 ;YES, BACKCHAINING, CONTINUE SAME
\r
3579 ;HERE TO SKIP OVER STILL VECTORS (FORWARDLY)
\r
3580 VECMO4: HLRZ B,(A) ;GET SIZE OF UNMOVER
\r
3581 SUBI A,(B) ;UPDATE A TO NEXT VECTOR
\r
3582 JRST VECMO2 ;AND GO CLEAN UP GROWTH
\r
3583 ;HERE TO ESTABLISH A BACKWARDS CHAIN
\r
3584 VECMO5: EXCH D,(A) ;CHAIN FORWARD
\r
3585 HLRZ B,D ;GET SIZE
\r
3586 SUBI A,(B) ;GO ON TO NEXT VECOTR
\r
3587 CAMGE A,VECBOT ;HAVE WE GOT TO END OF VECTORS?
\r
3588 JRST VECMO7 ;YES, GO MOVE PAIRS AND UNCHAIN
\r
3589 HRRZ B,(A) ;GET RELOCATION OF THIS VECTOR
\r
3590 SUBI B,(A) ; RELATIVIZE
\r
3591 JUMPLE B,VECMO5 ;IF NOT POSITIVE, CONTINUE CHAINING
\r
3592 MOVEM A,TYPNT ;SAVE ADDR FOR FORWARD RESUME
\r
3594 ;HERE TO UNCHAIN A VECTOR, MOVE IT, AND ADJUST DOPEWDS
\r
3595 VECMO6: HLRZ B,D ;GET SIZE
\r
3596 MOVEI F,1(A) ;GET A COPY OF BEGINNING OF VECTOR
\r
3597 ADDI A,(B) ;SET TO POINT TO ADDR OF DOPEWD CURRENTLY IN D
\r
3598 EXCH D,(A) ;AND UNCHAIN
\r
3599 HRRZ B,(A) ;GET RELOCATION FOR THIS VECTOR
\r
3600 SUBI B,(A) ; RELATIVIZE
\r
3601 MOVEI C,(A) ;COPY A POINTER TO DOPEW
\r
3602 SKIPGE D ;HAVE WE REACHED THE TOP OF THE CHAIN?
\r
3603 MOVE A,TYPNT ;YES, RESTORE FORWARD MOVE RESUME ADDR
\r
3604 JUMPE B,VECMO2 ;IF STILL VECTOR,GO ADJUST DOPEWDS
\r
3605 ADDI C,(B) ;MAKE C POINT TO NEW DOPEW ADDR
\r
3606 ADDI B,(F) ;B RH NEW 1ST WORD
\r
3607 HRLI B,(F) ;B LH OLD 1ST WD ADDR
\r
3608 BLT B,(C) ;COPY THE DATA
\r
3609 JRST VECMO2 ;AND GO ADJUST DOPEWDS
\r
3611 ;HERE TO STOP CHAINING BECAUSE OF BOTTOM OF VECTOR SPACE
\r
3612 VECMO7: MOVEM A,TYPNT
\r
3618 \f;PAIR MOVEMENT PHASE -- USES PARNEW,PARBOT, AND PARTOP TO MOVE PAIRS
\r
3621 PARMOV: SKIPN A,PARNEW ;IS THERE ANY PAIR MOVEMENT?
\r
3622 POPJ P, ;NO, RETURN
\r
3623 JUMPL A,PARMO2 ;YES -- IF MOVING DOWNWARDS, GO DO A BLT
\r
3624 HRLI A,B ;MOVING UPWARDS SETAC A TO INDEX OFF AC B
\r
3625 MOVE B,PARTOP ;GET HIGH PAIR ADDREESS
\r
3626 SUB B,PARBOT ;AND SUBTRACT BOTTOM TO GET NUMBER OF PAIRS
\r
3627 HRLZS B ;PUT COUNT IN LEFT HALF
\r
3628 HRR B,PARTOP ;GET HIGH ADDRESS PLUS ONE IN RH
\r
3629 SUBI B,1 ;AND SUBTRACT ONE TO POINT TO LAST WORD TO BE MOVED
\r
3631 PARMO1: TLNN B,-1 ;HAS COUNT REACHED ZERO?
\r
3632 JRST PARMO3 ;YES -- FINISH UP
\r
3633 POP B,@A ;NO -- TRANSFER2Y
\eU NEXT WORD
\r
3634 JRST PARMO1 ;AND REPEAT
\r
3636 PARMO2: MOVE B,PARBOT ;GET ADDRESS OF FIRST SOURCE WD
\r
3637 HRLS B ;IN BOTH HALVES OF AC B
\r
3638 ADD B,A ;MAKE RH OF B POINT TO FIRST DESTINATION WORD
\r
3639 ADD A,PARTOP ;MAKE RH OF A POINT TO LAST DESTINATION WORD PLUS ONE
\r
3640 BLT B,-1(A) ;AND TRANSFER THE BLOCK OF PAIRS
\r
3642 PARMO3: MOVE A,PARNEW ;GET OFFSET FOR PAIR SPACE
\r
3643 ADDM A,PARBOT ;AND CORRECT BOTTOM
\r
3644 ADDM A,PARTOP ;AND CORRECT TOP.
\r
3645 SETZM PARNEW ;CLEAR SO IF CALLED TWICE, NO LOSSAGE
\r
3647 \f;VECZER -- CLEARS DATA IN AREAS JUST GROWN
\r
3648 ;UPDATES SIZE OF VECTORS
\r
3649 ;CLEARS RELOCATION AND GROWTH FIELDS IN DOPEWDS
\r
3650 ;CALLED WITH NEW VECTOP IN A (VECBOT SHOULD BE NEW TOO)
\r
3652 VECZER: SUBI A,1 ;MAKE A POINT TO HIGH VECTORS
\r
3653 VECZE1: CAMGE A,VECBOT ;REACHED BOTTOM OF VECTORS?
\r
3654 POPJ P, ;YES, RETURN
\r
3655 HLLZS F,(A) ;NO, CLEAR RELOCATION GET SIZE
\r
3656 HLRZS F ;AND PUT SIZE IN RH OF F
\r
3657 HRRZ B,-1(A) ;GET GROWTH INTO B
\r
3658 JUMPN B,VECZE3 ;IF THERE IS SOME GROWTH, GO DO IT
\r
3659 VECZE2: SUBI A,(F) ;GROWTH DONE, MOVE ON TO NEXT VECTOR
\r
3660 JRST VECZE1 ;AND REPEAT
\r
3662 VECZE3: HLLZS -1(A) ;CLEAR GROWTH IN THE VECTOR
\r
3663 LDB C,[111000,,B] ;GET HIGH ORDER GROWTH IN C
\r
3666 ANDI B,377 ;AND LIMIT B TO LOW SIDE
\r
3667 ASHC B,6 ;EXPRESS GROWTH IN WORDS
\r
3668 JUMPE C,VECZE4 ;IF NO HIGH GROWTH SKIP TO LOW GROWTH
\r
3669 ADDI F,(C) ;ADD HIGH GROWTH TO SIZE
\r
3670 SUBM A,C ;GET ADDR OF 2ND WD TO BE ZEROED
\r
3671 SETZM -1(C) ;CLEAR 1ST WORD
\r
3672 HRLI C,-1(C) ;MAKE C A CLEARING BLT POINTER
\r
3673 BLT C,-2(A) ;AND CLEAR HIGH END DATA
\r
3675 VECZE4: JUMPE B,VECZE5 ;IF NO LOW GROWTH SKIP TO SIZE UPDATE
\r
3676 MOVNI C,(F) ;GET NEGATIVE SIZE SO FAR
\r
3677 ADDI C,(A) ;AND MAKE C POINT TO LAST WORD OF STUFF TO BE CLEARED
\r
3678 ADDI F,(B) ;UPDATE SIZE
\r
3679 SUBM C,B ;MAKE B POINT TO LAST WD OF NEXT VECT
\r
3680 ADDI B,2 ;AND NOW TO 2ND DATA WD TO BE CLEARED
\r
3681 SETZM -1(B) ;CLEAR 1ST DATA WD
\r
3682 HRLI B,-1(B) ;MAKE B A CLEARING BLT POINTER
\r
3683 BLT B,(C) ;AND CLEAR THE LOW DATA
\r
3685 VECZE5: HRLZM F,(A) ;STORE THE NEW SIZE IN DOPEWD
\r
3688 \f;SUBROUTINE TO REBUILD THE NOW DEFUNCT HASH TABLE
\r
3690 REHASH: MOVE TVP,TVPSTO+1(PVP) ;RESTORE TV POINTER
\r
3691 MOVE D,ASOVEC+1(TVP) ;GET POINTER TO VECTOR
\r
3693 PUSH P,E ;PUSH A POINTER
\r
3694 HLRE A,D ;GET -LENGTH
\r
3695 MOVMS A ;AND PLUSIFY
\r
3696 PUSH P,A ;PUSH IT ALSO
\r
3698 REH3: HRRZ C,(D) ;POINT TO FIRST BUCKKET
\r
3699 HLRZS (D) ;MAKE SURE NEW POINTER IS IN RH
\r
3700 JUMPE C,REH1 ;BUCKET EMPTY, QUIT
\r
3702 REH2: MOVEI E,(C) ;MAKE A COPY OF THE POINTER
\r
3703 MOVE A,ITEM(C) ;START HASHING
\r
3704 TLZ A,TYPMSK#777777 ; KILL MONITORS
\r
3707 TLZ 0,TYPMSK#777777
\r
3710 TLZ A,400000 ;MAKE SURE FINAL HASH IS +
\r
3711 IDIV A,(P) ;DIVIDE BY TOTAL LENGTH
\r
3712 ADD B,-1(P) ;POINT TO WINNING BUCKET
\r
3714 MOVE C,[002200,,(B)] ;BYTE POINTER TO RH
\r
3715 CAILE B,(D) ;IF PAST CURRENT POINT
\r
3716 MOVE C,[222200,,(B)] ;USE LH
\r
3717 LDB A,C ;GET OLD VALUE
\r
3718 DPB E,C ;STORE NEW VALUE
\r
3719 HRRZ B,ASOLNT-1(E) ;GET NEXT POINTER
\r
3720 HRRZM A,ASOLNT-1(E) ;AND CLOBBER IN NEW NEXT
\r
3721 SKIPE A ;SKKIP IF NOTHING PREVIOUSLY IN BUCKET
\r
3722 HRLM E,ASOLNT-1(A) ;OTHERWISE CLOBBER
\r
3723 SKIPE C,B ;SKIP IF END OF CHAIN
\r
3725 REH1: AOBJN D,REH3
\r
3727 SUB P,[2,,2] ;FLUSH THE JUNK
\r
3729 \fVCMLOS: FATAL AGC--VECTOR WITH ZERO IN DOPE WORD LENGTH
\r
3732 ; THESE ARE THE MESSAGES INDICATING THE CAUSE OF THE GC
\r
3734 MSGGCT: [ASCIZ /USER CALLED- /]
\r
3735 [ASCIZ /FREE STORAGE- /]
\r
3736 [ASCIZ /TP-STACK- /]
\r
3737 [ASCIZ /TOP-LEVEL LOCALS- /]
\r
3738 [ASCIZ /GLOBAL VALUES- /]
\r
3740 [ASCIZ /STATIONARY IMPURE STORAGE- /]
\r
3741 [ASCIZ /P-STACK /]
\r
3742 [ASCIZ /BOTH STACKS BLOWN- /]
\r
3743 [ASCIZ /PURE STORAGE- /]
\r
3744 [ASCIZ /GC-RCALL- /]
\r
3746 ; THESE ARE MESSAGES INDICATING WHO CAUSED THE GC
\r
3756 [ASCIZ /PURE-PAGE LOADER /]
\r
3758 [ASCIZ /INTERRUPT-HANDLER /]
\r
3759 [ASCIZ /NEWTYPE /]
\r
3767 ; LOCATIONS USED BY BLOAT-STAT TO HELP THE USER PICK BLOAT SPECIFICATIONS.
\r
3770 GCNO: 0 ; USER-CALLED GC
\r
3771 BSTGC: 0 ; FREE STORAGE
\r
3773 0 ; TOP-LEVEL LVALS
\r
3778 0 ; BOTH STATCKS BLOWN
\r
3782 NOWFRE: 0 ; FREE STORAGE FROM LAST GC
\r
3783 CURFRE: 0 ; STORAGE USED SINCE LAST GC
\r
3784 MAXFRE: 0 ; MAXIMUM FREE STORAGE ALLOCATED
\r
3785 USEFRE: 0 ; TOTAL FREE STORAGE USED
\r
3786 NOWTP: 0 ; TP LENGTH FROM LAST GC
\r
3787 CURTP: 0 ; # WORDS ON TP
\r
3788 CTPMX: 0 ; MAXIMUM SIZE OF TP SO FAR
\r
3789 NOWLVL: 0 ; # OF TOP-LEVEL LVAL-SLOTS
\r
3790 CURLVL: 0 ; # OF TOP-LEVEL LVALS
\r
3791 NOWGVL: 0 ; # OF GVAL SLOTS
\r
3792 CURGVL: 0 ; # OF GVALS
\r
3793 NOWTYP: 0 ; SIZE OF TYPE-VECTOR
\r
3794 CURTYP: 0 ; # OF TYPES
\r
3795 NOWSTO: 0 ; SIZE OF STATIONARY STORAGE
\r
3796 CURSTO: 0 ; STATIONARY STORAGE IN USE
\r
3797 CURMAX: 0 ; MAXIMUM BLOCK OF CONTIGUOUS STORAGE
\r
3798 NOWP: 0 ; SIZE OF P-STACK
\r
3799 CURP: 0 ; #WORDS ON P
\r
3800 CPMX: 0 ; MAXIMUM P-STACK LENGTH SO FAR
\r
3801 GCCAUS: 0 ; INDICATOR FOR CAUSE OF GC
\r
3802 GCCALL: 0 ; INDICATOR FOR CALLER OF GC
\r
3805 ; THIS GROUP OF VARIABLES DETERMINES HOW THINGS GROW
\r
3806 LVLINC: 6 ; LVAL INCREMENT ASSUMED TO BE 64 SLOTS
\r
3807 GVLINC: 4 ; GVAL INCREMENT ASSUMED TO BE 64 SLOTS
\r
3808 TYPIC: 1 ; TYPE INCREMENT ASSUMED TO BE 32 TYPES
\r
3809 STORIC: 2000 ; STORAGE INCREMENT USED BY NFREE (MINIMUM BLOCK-SIZE)
\r
3812 RCL: 0 ; POINTER TO LIST OF RECYCLEABLE LIST CELLS
\r
3813 GCMONF: 0 ; NON-ZERO SAY GIN/GOUT
\r
3814 GCDANG: 0 ; NON-ZERO, STORAGE IS LOW
\r
3815 GCDNTG: 0 ; NON-ZERO ABORT GROWTHS
\r
3816 GETNUM: 0 ;NO OF WORDS TO GET
\r
3817 PARNUM: 0 ;NO OF PAIRS MARKED
\r
3818 VECNUM: 0 ;NO OF WORDS IN MARKED VECTORS
\r
3819 CORSET: 0 ;NO OF BLOCKS OF CORE, IF GIVING CORE AWAY
\r
3820 CORTOP: 0 ;CURRENT TOP OF CORE, EXCLUDING ANY TO BE GIVEN AWAY
\r
3822 ;VARIABLES WHICH DETERMIN WHEN MUDDLE WILL ASK FOR MORE CORE,
\r
3823 ;AND WHEN IT WILL GET UNHAPPY
\r
3825 SYSMAX: 50. ;MAXIMUM SIZE OF MUDDLE
\r
3826 FREMIN: 20000 ;MINIMUM FREE WORDS
\r
3827 FREDIF: 10000 ;DIFFERENCE BETWEEN FREMIN AND MAXIMUM NUMBER OF FREE WORDS
\r
3828 ;POINTER TO GROWING PDL
\r
3830 TPGROW: 0 ;POINTS TO A BLOWN TP
\r
3831 PPGROW: 0 ;POINTS TO A BLOWN PP
\r
3832 TIMOUT: 0 ;POINTS TO TIMED OUT PDL
\r
3833 PGROW: 0 ;POINTS TO A BLOWN P
\r
3838 GCFLCH: 0 ; TELL INT HANDLER TO ITIC CHARS
\r
3839 GCHAIR: 1 ; COUNTS GCS AND TELLS WHEN TO HAIRIFY
\r
3840 SHRUNK: 0 ; NON-ZERO=> AVECTOR(S) SHRUNK
\r
3841 GREW: 0 ; NON-ZERO=> A VECTOR(S) GREW
\r
3842 SPARNW: 0 ; SAVED PARNEW
\r
3843 GCDOWN: 0 ; AMOUNT TO TRY AND MOVE DOWN
\r
3844 CURPLN: 0 ; LENGTH OF CURRENTLY RUNNING PURE RSUBR
\r
3846 ; VARS ASSOCIATED WITH BLOAT LOGIC
\r
3852 ; VARS FOR PAGE WINDOW HACKS
\r
3854 WNDBOT: 0 ; BOTTOM OF WINDOW
\r
3856 BOTNEW: (FPTR) ; POINTER TO FRONTIER
\r
3868 \fTITLE ARITHMETIC PRIMITIVES FOR MUDDLE
\r
3870 .GLOBAL HI,RLOW,CPLUS,CMINUS,CTIMES,CDIVID,CFIX,CFLOAT
\r
3871 .GLOBAL CLQ,CGQ,CLEQ,CGEQ,C1Q,C0Q,CMAX,CMIN,CABS,CMOD,CCOS,CSIN,CATAN,CLOG
\r
3872 .GLOBAL CEXP,CSQRT,CTIME,CORB,CXORB,CANDB,CEQVB,CRAND,SAT,BFLOAT
\r
3876 ;DEFINES MUDDLE PRIMITIVES: FIX,FLOAT,ATAN,IEXP,LOG,
\r
3877 ; G?,L?,0?,1?,+,-,*,/,MAX,MIN,ABS,SIN,COS,SQRT,RANDOM,
\r
3908 YES: MOVSI A,TATOM ;RETURN PATH FOR 'TRUE'
\r
3913 NO: MOVSI A,TFALSE ;RETURN PATH FOR 'FALSE'
\r
3917 \f;ERROR RETURNS AND OTHER UTILITY ROUTINES
\r
3920 OVRFLD: PUSH TP,$TATOM
\r
3921 PUSH TP,EQUOTE OVERFLOW
\r
3924 CARGCH: GETYP 0,A ; GET TYPE
\r
3930 ARGCHK: ;CHECK FOR SINGLE FIXED OR FLOATING
\r
3931 ;ARGUMENT IF FIXED CONVERT TO FLOATING
\r
3932 ;RETURN FLOATING ARGRUMENT IN B ALWAYS
\r
3936 CAIN C,TFLOAT ;FLOATING?
\r
3937 POPJ P, ;YES, RETURN
\r
3938 CAIE C,TFIX ;FIXED?
\r
3939 JRST WTYP1 ;NO, ERROR
\r
3940 JSP A,BFLOAT ;YES, CONVERT TO FLOATING AND RETURN
\r
3943 OUTRNG: PUSH TP,$TATOM
\r
3944 PUSH TP,EQUOTE ARGUMENT-OUT-OF-RANGE
\r
3947 NSQRT: PUSH TP,$TATOM
\r
3948 PUSH TP,EQUOTE NEGATIVE-ARGUMENT
\r
3970 \f;DISPATCH TABLES USED TO CONTROL THE FLOW OF THE VARIOUS PRIMITIVES
\r
3972 TABLE2: NO ;TABLE2 (0)
\r
3973 TABLE3: YES ;TABLE2 (1) & TABLE3 (0)
\r
4019 \f;PRIMITIVES FLOAT AND FIX
\r
4021 MFUNCTION FIX,SUBR
\r
4032 MFUNCTION FLOAT,SUBR
\r
4057 FXFL: GETYP A,(AB)
\r
4064 MFUNCTION ABS,SUBR
\r
4071 MOVIT: MOVM B,VAL1 ;GET ABSOLUTE VALUE OF ARGUMENT
\r
4072 AFINIS: HRLZS A ;MOVE TYPE CODE INTO LEFT HALF
\r
4077 MFUNCTION MOD,SUBR
\r
4080 CAIE A,TFIX ;FIRST ARG FIXED ?
\r
4083 CAIE A,TFIX ;SECOND ARG FIXED ?
\r
4086 IDIV A,VAL2 ;FORM QUOTIENT & REMAINDER
\r
4087 JUMPGE B,.+2 ;Only return positive remainders
\r
4091 \f;PRIMITIVES PLUS, DIFFERENCE, TIMES, DIVIDE, MIN, AND MAX
\r
4093 MFUNCTION MIN,SUBR
\r
4100 MFUNCTION MAX,SUBR
\r
4107 MFUNCTION DIVIDE,SUBR,[/]
\r
4114 MFUNCTION DIFFERENCE,SUBR,[-]
\r
4121 MFUNCTION TIMES,SUBR,[*]
\r
4128 MFUNCTION PLUS,SUBR,[+]
\r
4134 GOPT: MOVE D,AB ;ARGUMENT POINTER
\r
4141 ; BUILD COMPILER ENTRIES TO THESE ROUTINES
\r
4143 IRP NAME,,[CMINUS,CDIVID,CPLUS,CTIMES,CMIN,CMAX]CODE,,[2,3,4,5,6,7]
\r
4145 NAME: MOVEI E,CODE
\r
4149 CARIT1: MOVEI D,(A)
\r
4153 SUBM TP,D ; POINT TO ARGS
\r
4161 CARITH: MOVE B,DEFVAL(E) ; GET VAL
\r
4163 MOVEI 0,TFIX ; FIX UNTIL CHANGE
\r
4164 JUMPN A,ARITH0 ; AT LEAST ONE ARG
\r
4168 ARITH0: SOJE A,ARITH1 ; FALL IN WITH ONE ARG
\r
4170 GETYP C,(D) ; TYPE OF 1ST ARG
\r
4171 ADD D,[2,,2] ; GO TO NEXT
\r
4178 ARITH1: GETYP C,(D) ; GET NEXT TYPE
\r
4180 JRST ARITH2 ; TO FLOAT LOOP
\r
4181 XCT FUNC(E) ; DO IT
\r
4183 SOJG A,ARITH1 ; KEEP ADDING OR WHATEVER
\r
4184 JFCL OVRFLW,OVRFLD
\r
4188 ARITH3: GETYP C,(D)
\r
4189 MOVE 0,1(D) ; GET ARG
\r
4193 JSP C,OFLOAT ; FLOAT IT
\r
4196 ARITH4: CAIE C,TFLOAT
\r
4200 ARITH2: CAIE C,TFLOAT ; FLOATER?
\r
4207 ARITH5: XCT FLFUNC(E)
\r
4211 JFCL OVRFLW,OVRFLD
\r
4215 SWITCH: XCT COMPAR(E) ;FOR MAX & MIN TESTING
\r
4224 FLSWCH: XCT FLCMPR(E)
\r
4230 \f;PRIMITIVES ONEP AND ZEROP
\r
4232 MFUNCTION ONEP,SUBR,[1?]
\r
4236 MFUNCTION ZEROP,SUBR,[0?]
\r
4241 CAIN A,TFIX ;fixed ?
\r
4243 CAIE A,TFLOAT ;floating ?
\r
4246 CAMN B,NUMBR(E) ;equal to correct value ?
\r
4250 TESTFX: CAMN E,VAL1 ;equal to correct value ?
\r
4253 NO1: MOVSI A,TFALSE
\r
4257 YES1: MOVSI A,TATOM
\r
4261 NUMBR: 0 ;FLOATING PT ZERO
\r
4262 201400,,0 ;FLOATING PT ONE
\r
4263 \f;PRIMITIVES LESSP AND GREATERP
\r
4265 MFUNCTION LEQP,SUBR,[L=?]
\r
4269 MFUNCTION GEQP,SUBR,[G=?]
\r
4274 MFUNCTION LESSP,SUBR,[L?]
\r
4278 MFUNCTION GREATERP,SUBR,[G?]
\r
4296 ; COMPILERS ENTRIES TO THESE GUYS
\r
4298 IRP NAME,,[CGQ,CLQ,CGEQ,CLEQ]COD,,[0,1,2,3]
\r
4307 JRST COMPD ; COMPARING FIX AND FLOAT
\r
4314 CMPTYP: CAIE 0,TFIX
\r
4326 MFUNCTION RANDOM,SUBR
\r
4329 CAMGE A,[-4] ;At most two arguments to random to set seeds
\r
4332 MOVE B,VAL2 ;Set second seed
\r
4334 MOVE A,VAL1 ;Set first seed
\r
4336 RANDGO: PUSHJ P,CRAND
\r
4339 CRAND: MOVE B,RLOW ;FREDKIN'S RANDOM NUMBER GENERATOR.
\r
4347 \fMFUNCTION SQRT,SUBR
\r
4356 SQ2: MOVE C,B ;NEWTON'S METHOD, SPECINER'S HACK.
\r
4365 MFUNCTION COS,SUBR
\r
4367 FADR B,[1.570796326] ;COS(X)=SIN (X+PI/2)
\r
4372 MFUNCTION SIN,SUBR
\r
4380 POPJ P, ;GOSPER'S RECURSIVE SIN.
\r
4381 FDVR B,[-3.0] ;SIN(X)=4*SIN(X/-3)**3-3*SIN(X/-3)
\r
4389 CSQRT: PUSHJ P,CARGCH
\r
4393 CSIN: PUSHJ P,CARGCH
\r
4394 CSIN1: PUSHJ P,.SIN
\r
4398 CCOS: PUSHJ P,CARGCH
\r
4399 FADR B,[1.570796326]
\r
4401 \fMFUNCTION LOG,SUBR
\r
4402 PUSHJ P,ARGCHK ;LEAVES ARGUMENT IN B
\r
4406 CLOG: PUSHJ P,CARGCH
\r
4408 ILOG: JUMPLE B,OUTRNG
\r
4409 LDB D,[331100,,B] ;GRAB EXPONENT
\r
4410 SUBI D,201 ;REMOVE BIAS
\r
4411 TLZ B,777000 ;SET EXPONENT
\r
4412 TLO B,201000 ; TO 1
\r
4418 MOVE C,[0.434259751]
\r
4420 FADR C,[0.576584342]
\r
4422 FADR C,[0.961800762]
\r
4424 FADR C,[2.88539007]
\r
4430 FMPR B,[0.693147180] ;LOG E OF 2
\r
4435 \fMFUNCTION ATAN,SUBR
\r
4440 CATAN: PUSHJ P,CARGCH
\r
4444 CAMG D,[0.4^-8] ;SMALL ENOUGH SO ATAN(X)=X?
\r
4446 CAML D,[7.0^7] ;LARGE ENOUGH SO THAT ATAN(X)=PI/2?
\r
4449 CAMLE D,[1.0] ;IS ABS(X)<1.0?
\r
4450 FDVM C,D ;NO,SCALE IT DOWN
\r
4453 MOVE C,[1.44863154]
\r
4455 MOVE A,[-0.264768620]
\r
4458 FADR C,[3.31633543]
\r
4459 MOVE A,[-7.10676005]
\r
4462 FADR C,[6.76213924]
\r
4463 MOVE B,[3.70925626]
\r
4465 FADR B,[0.174655439]
\r
4467 JUMPG D,ATAN2 ;WAS ARG SCALED?
\r
4468 FADR B,PI2 ;YES, ATAN(X)=PI/2-ATAN(1/X)
\r
4471 ATAN2: SKIPGE (P) ;WAS INPUT NEGATIVE?
\r
4472 MOVNS B ;YES,COMPLEMENT
\r
4473 ATAN3: MOVSI A,TFLOAT
\r
4478 \fMFUNCTION IEXP,SUBR,[EXP]
\r
4479 PUSHJ P,ARGCHK ;LEAVE FLOATING POINT ARG IN B
\r
4483 CEXP: PUSHJ P,CARGCH
\r
4488 FMPR A,[0.434294481] ;LOG BASE 10 OF E
\r
4498 EXPR1: FMPR D,FLOAP1(B)
\r
4499 LDB A,[103300,,C]
\r
4505 RATEY: FADR C,COEF2-1(B)
\r
4512 SKIPL (P) ;SKIP IF INPUT NEGATIVE
\r
4519 EXPR2: LDB E,[030300,,B]
\r
4522 FMPR D,D ;TO THE 8TH POWER
\r
4543 \f;BITWISE BOOLEAN FUNCTIONS
\r
4545 MFUNCTION %ANDB,SUBR,ANDB
\r
4547 HRREI B,-1 ;START ANDING WITH ALL ONES
\r
4548 MOVE D,[AND B,A] ;LOGICAL INSTRUCTION
\r
4549 JRST LOGFUN ;DO THE OPERATION
\r
4551 MFUNCTION %ORB,SUBR,ORB
\r
4557 MFUNCTION %XORB,SUBR,XORB
\r
4563 MFUNCTION %EQVB,SUBR,EQVB
\r
4568 LOGFUN: JUMPGE AB,ZROARG
\r
4569 LOGTYP: GETYP A,(AB) ;GRAB THE TYPE
\r
4570 PUSHJ P,SAT ;STORAGE ALLOCATION TYPE
\r
4572 JRST WRONGT ;WRONG TYPE...LOSE
\r
4573 MOVE A,1(AB) ;LOAD ARG INTO A
\r
4574 XCT D ;DO THE LOGICAL OPERATION
\r
4575 AOBJP AB,.+2 ;ADD ONE TO BOTH HALVES
\r
4576 AOBJN AB,LOGTYP ;ADD AGAIN AND LOOP IF NEEDED
\r
4578 ZROARG: MOVE A,$TWORD
\r
4581 ;routine to sort lists or vectors of either fixed point or floating numbers
\r
4582 ;the components are interchanged repeatedly to acheive the sort
\r
4583 ;first arg: the structure to be sorted
\r
4584 ;if no second arg sort in descending order
\r
4585 ;second arg: if false then sort in ascending order
\r
4586 ; else sort in descending order
\r
4588 MFUNCTION SORT,SUBR
\r
4591 CAIGE A,-4 ;Only two arguments allowed
\r
4593 MOVE O,DESCEND ;Set up "O" to test for descending order as default condition
\r
4594 CAIE A,-4 ;Optional second argument?
\r
4596 GETYP B,TYP2 ;See if it is other than false
\r
4598 MOVE O,ASCEND ;Set up "O" to test for ascending order
\r
4599 GETYP A,TYP1 ;CHECK TYPE OF FIRST ARGUMENT
\r
4609 GOBACK: MOVE A,TYP1 ;RETURN THE SORTED ARGUMENT AS VALUE
\r
4613 DESCEND: CAMG C,(A)+1
\r
4614 ASCEND: CAML C,(A)+1
\r
4615 \f;ROUTINE TO SORT LISTS IN NUMERICAL ORDER
\r
4617 LSORT: MOVE A,VAL1
\r
4618 JUMPE A,GOBACK ;EMPTY LIST?
\r
4619 HLRZ B,(A) ;TYPE OF FIRST COMPONENT
\r
4624 MOVEI E,0 ;FOR COUNT OF LENGTH OF LIST
\r
4625 LCOUNT: JUMPE A,LLSORT ;REACHED END OF LIST?
\r
4626 MOVE A,(A) ;NEXT COMPONENT
\r
4627 TLZ A,(B) ;SAME TYPE AS FIRST COMPONENT?
\r
4630 AOJA E,LCOUNT ;INCREMENT COUNT AND CONTINUE
\r
4632 LLSORT: SOJE E,GOBACK ;FINISHED WITH SORTING?
\r
4633 HRRZ A,VAL1 ;START THIS LOOP OF SORTING AT THE BEGINNING
\r
4634 MOVEM E,(P)+1 ;Save the iteration depth
\r
4635 CLSORT: HRRZ B,(A) ;NEXT COMPONENT
\r
4636 MOVE C,(B)+1 ;ITS VALUE
\r
4637 XCT O ;ARE THESE TWO COMPONENTS IN ORDER?
\r
4639 MOVE D,(A)+1 ;INTERCHANGE THEM
\r
4642 MOVE A,B ;MAKE THE COMPONENT IN "B" THE CURRENT ONE
\r
4644 MOVE E,(P)+1 ;Restore the iteration depth
\r
4646 \f;ROUTINE TO SORT VECTORS IN NUMERICAL ORDER
\r
4648 VSORT: HLRE D,VAL1 ;GET COUNT FIELD OF VECTOR
\r
4649 IDIV D,[-2] ;LENGTH
\r
4650 JUMPE D,GOBACK ;EMPTY VECTOR?
\r
4651 MOVE E,D ;SAVE LENGTH IN "E"
\r
4652 HRRZ A,VAL1 ;POINTER TO VECTOR
\r
4653 MOVE B,(A) ;TYPE OF FIRST COMPONENT
\r
4658 SOJLE D,GOBACK ;IF ONLY ONE COMPONENT THEN FINISHED
\r
4659 VCOUNT: ADDI A,2 ;CHECK NEXT COMPONENT
\r
4660 CAME B,(A) ;SAME TYPE AS FIRST COMPONENT?
\r
4662 SOJG D,VCOUNT ;CONTINUE WITH NEXT COMPONENT
\r
4664 VVSORT: SOJE E,GOBACK ;FINISHED SORTING?
\r
4665 HRRZ A,VAL1 ;START THIS LOOP OF SORTING AT THE BEGINNING
\r
4666 MOVEM E,(P)+1 ;Save the iteration depth
\r
4667 CVSORT: MOVE C,(A)+3 ;VALUE OF NEXT COMPONENT
\r
4668 XCT O ;ARE THESE TWO COMPONENTS IN ORDER?
\r
4670 MOVE D,(A)+1 ;INTERCHANGE THEM
\r
4673 ADDI A,2 ;UPDATE THE CURRENT COMPONENT
\r
4675 MOVE E,(P)+1 ;Restore the iteration depth
\r
4679 MFUNCTION TIME,SUBR
\r
4687 RLOW: 155256071112
\r
4692 \f\fTITLE ATOMHACKER FOR MUDDLE
\r
4697 .GLOBAL RLOOKU,CHMAK,OBLNT,ROOT,INTOBL,ERROBL,IFALSE
\r
4698 .GLOBAL .BLOCK,IDVAL,NXTDCL,CHRWRD,CSTACK,CSTAK,ILOOKC,IGVAL,BYTDOP
\r
4699 .GLOBAL ICONS,INCONS,IBLOCK,INSRTX,GCHACK,IMPURIFY
\r
4700 .GLOBAL CINSER,CIRMV,CLOOKU,CATOM,CIPNAM,MPOPJ,CSETG
\r
4702 .VECT.==40000 ; BIT FOR GCHACK
\r
4704 ; FUNCTION TO GENERATE AN EMPTY OBLIST
\r
4706 MFUNCTION MOBLIST,SUBR
\r
4709 CAMGE AB,[-5,,0] ;CHECK NUMBER OF ARGS
\r
4711 JUMPGE AB,MOBL2 ; NO ARGS
\r
4715 PUSH TP,IMQUOTE OBLIST
\r
4716 MCALL 2,GET ; CHECK IF IT EXISTS ALREADY
\r
4719 MOBL2: MOVE A,OBLNT ;GET DEFAULT LENGTH
\r
4720 CAML AB,[-3,,0] ;IS LENGTH SUPPLIED
\r
4721 JRST MOBL1 ;NO, USE STANDARD LENGTH
\r
4722 GETYP C,2(AB) ;GET ARG TYPE
\r
4725 MOVE A,3(AB) ;GET LENGTH
\r
4726 MOBL1: PUSH TP,$TFIX
\r
4728 MCALL 1,UVECTOR ;GET A UNIFORM VECTOR
\r
4729 MOVSI C,TLIST+.VECT. ;IT IS OF TYPE LIST
\r
4730 HLRE D,B ;-LENGTH TO D
\r
4731 SUBM B,D ;D POINTS TO DOPE WORD
\r
4732 MOVEM C,(D) ;CLOBBER TYPE IN
\r
4734 JUMPGE AB,FINIS ; IF NO ARGS, DONE
\r
4743 PUSH TP,IMQUOTE OBLIST
\r
4746 MCALL 3,PUT ; PUT THE NAME ON THE OBLIST
\r
4750 PUSH TP,IMQUOTE OBLIST
\r
4753 MCALL 3,PUT ; PUT THE OBLIST ON THE NAME
\r
4759 MFUNCTION GROOT,SUBR,ROOT
\r
4762 MOVE B,ROOT+1(TVP)
\r
4765 MFUNCTION GINTS,SUBR,INTERRUPTS
\r
4767 MOVE A,INTOBL(TVP)
\r
4768 MOVE B,INTOBL+1(TVP)
\r
4771 MFUNCTION GERRS,SUBR,ERRORS
\r
4773 MOVE A,ERROBL(TVP)
\r
4774 MOVE B,ERROBL+1(TVP)
\r
4778 COBLQ: SKIPN B,2(B) ; SKIP IF EXISTS
\r
4791 MFUNCTION OBLQ,SUBR,[OBLIST?]
\r
4797 MOVE B,1(AB) ; GET ATOM
\r
4802 \f; FUNCTION TO FIND AN ATOM ON A GIVEN OBLIST WITH A GIVEN PNAME
\r
4804 MFUNCTION LOOKUP,SUBR
\r
4807 PUSHJ P,ILOOKU ;CALL INTERNAL ROUTINE
\r
4810 CLOOKU: SUBM M,(P)
\r
4828 ILOOKU: PUSHJ P,ARGCHK ;CHECK ARGS
\r
4829 PUSHJ P,CSTACK ;PUT CHARACTERS ON THE STACK
\r
4831 CALLIT: MOVE B,3(AB) ;GET OBLIST
\r
4832 ILOOKC: PUSHJ P,ILOOK ;LOOK IT UP
\r
4833 POP P,D ;RESTORE COUNT
\r
4834 HRLI D,(D) ;TO BOTH SIDES
\r
4838 ;THIS ROUTINE CHECKS ARG TYPES
\r
4840 ARGCHK: GETYP A,(AB) ;GET TYPES
\r
4842 CAIE A,TCHRS ;IS IT EITHER CHAR STRING
\r
4844 CAIE C,TOBLS ;IS 2ND AN OBLIST
\r
4845 JRST WRONGT ;TYPES ARE WRONG
\r
4848 ;THIS SUBROUTINE PUTS CHARACTERS ON THE STACK (P WILL BE CHANGED)
\r
4851 CSTACK: MOVEI B,(AB)
\r
4852 CSTAK: POP P,D ;RETURN ADDRESS TO D
\r
4853 CAIE A,TCHRS ;IMMEDIATE?
\r
4854 JRST NOTIMM ;NO, HAIR
\r
4855 MOVE A,1(B) ; GET CHAR
\r
4856 LSH A,29. ; POSITION
\r
4858 PUSH P,[1] ;WITH NUMBER
\r
4859 JRST (D) ;GO CALL SEARCHER
\r
4861 NOTIMM: MOVEI A,1 ; CLEAR CHAR COUNT
\r
4862 HRRZ C,(B) ; GET COUNT OF CHARS
\r
4863 JUMPE C,NULST ; FLUSH NULL STRING
\r
4864 MOVE B,1(B) ;GET BYTE POINTER
\r
4866 CLOOP1: PUSH P,[0] ; STORE CHARS ON STACK
\r
4867 MOVSI E,(<440700,,(P)>) ; SETUP BYTE POINTER
\r
4868 CLOOP: ILDB 0,B ;GET A CHARACTER
\r
4869 IDPB 0,E ;STORE IT
\r
4870 SOJE C,CDONE ; ANY MORE?
\r
4871 TLNE E,760000 ; WORD FULL
\r
4872 JRST CLOOP ;NO CONTINUE
\r
4873 AOJA A,CLOOP1 ;AND CONTINUE
\r
4876 CDONE1: PUSH P,A ;AND NUMBER OF WORDS
\r
4880 NULST: PUSH TP,$TATOM
\r
4881 PUSH TP,EQUOTE NULL-STRING
\r
4883 \f; THIS FUNCTION LOOKS FOR ATOMS. CALLED BY PUSHJ P,ILOOK
\r
4884 ; B/ OBLIST POINTER
\r
4885 ; -1(P)/ LENGTH IN WORDS OF CHARACTER BLOCK
\r
4886 ; CHAR STRING IS ON THE STACK
\r
4888 ILOOK: MOVN A,-1(P) ;GET -LENGTH
\r
4889 HRLI A,-1(A) ;<-LENGTH-1>,,-LENGTH
\r
4890 PUSH TP,$TFIX ;SAVE
\r
4892 ADDI A,-1(P) ;HAVE AOBJN POINTER TO CHARS
\r
4893 MOVEI D,0 ;HASH WORD
\r
4895 AOBJN A,.-1 ;XOR THEM ALL TOGETHER
\r
4896 HLRE A,B ;GET LENGTH OF OBLIST
\r
4898 TLZ D,400000 ; MAKE SURE + HASH CODE
\r
4899 IDIVI D,(A) ;DIVIDE
\r
4900 HRLI E,(E) ;TO BOTH HALVES
\r
4901 ADD B,E ;POINT TO BUCKET
\r
4903 MOVEI 0,(B) ;IN CASE REMOVING 1ST
\r
4904 SKIPN C,(B) ;BUCKET EMPTY?
\r
4905 JRST NOTFND ;YES, GIVE UP
\r
4906 LOOK2: SKIPN A,1(C) ;NIL CAR ON LIST?
\r
4907 JRST NEXT ;YES TRY NEXT
\r
4908 ADD A,[3,,3] ;POINT TO ATOMS PNAME
\r
4909 MOVE D,(TP) ;GET PSEUDO AOBJN POINTER TO CHARS
\r
4910 ADDI D,-1(P) ;NOW ITS A REAL AOBJN POINTER
\r
4911 JUMPE D,CHECK0 ;ONE IS EMPTY
\r
4912 LOOK1: MOVE E,(D) ;GET A WORD
\r
4913 CAME E,(A) ;COMPARE
\r
4914 JRST NEXT ;THIS ONE DOESN'T MATCH
\r
4915 AOBJP D,CHECK ;ONE RAN OUT
\r
4916 AOBJN A,LOOK1 ;JUMP IF STILL MIGHT WIN
\r
4918 NEXT: MOVEI 0,(C) ;POINT TO PREVIOUS ELEMENT
\r
4919 HRRZ C,(C) ;STEP THROUGH
\r
4922 NOTFND: EXCH C,B ;RETURN BUCKET IN B
\r
4924 CPOPJT: SUB TP,[2,,2] ;REMOVE RANDOM TP STUFF
\r
4927 CHECK0: JUMPN A,NEXT ;JUMP IF NOT ALSO EMPTY
\r
4929 CHECK: AOBJN A,NEXT ;JUMP IF NO MATCH
\r
4931 MOVE E,B ; RETURN BUCKET
\r
4932 MOVE B,1(C) ;GET ATOM
\r
4936 \f; FUNCTION TO INSERT AN ATOM ON AN OBLIST
\r
4938 MFUNCTION INSERT,SUBR
\r
4950 CINSER: SUBM M,(P)
\r
4962 ;INSERT WITH A GIVEN PNAME
\r
4969 PUSH TP,$TFIX ;FLAG CALL
\r
4972 PUSHJ P,CSTAK ;COPY ONTO STACK
\r
4974 PUSHJ P,ILOOK ;LOOK IT UP (BUCKET RETURNS IN C)
\r
4975 JUMPN B,ALRDY ;EXISTS, LOSE
\r
4976 MOVE D,-2(TP) ; GET OBLIST BACK
\r
4977 INSRT1: PUSH TP,$TOBLS ;SAVE BUCKET POINTER
\r
4980 PUSH TP,D ; SAVE OBLIST
\r
4981 INSRT3: PUSHJ P,IATOM ; MAKE AN ATOM
\r
4982 PUSHJ P,LINKCK ; A LINK REALLY NEEDED ?
\r
4984 HRRZ E,(E) ; GET BUCKET
\r
4986 MOVE C,-2(TP) ;BUCKET AGAIN
\r
4987 HRRM B,(C) ;INTO NEW BUCKET
\r
4989 MOVE B,1(B) ;GET ATOM BACK
\r
4990 MOVE D,(TP) ; GET OBLIST
\r
4991 MOVEM D,2(B) ; AND CLOBBER
\r
4992 MOVE C,-4(TP) ;GET FLAG
\r
4993 SUB TP,[6,,6] ;POP STACK
\r
4998 ;INSERT WITH GIVEN ATOM
\r
4999 INSRT0: MOVE A,-2(TP) ;GOBBLE PNAME
\r
5000 SKIPE 2(A) ; SKIP IF NOT ON AN OBLIST
\r
5005 PUSH P,(A) ;FLUSH PNAME ONTO P STACK
\r
5008 MOVE B,(TP) ; GET OBLIST FOR LOOKUP
\r
5009 PUSHJ P,ILOOK ;ALREADY THERE?
\r
5011 PUSH TP,$TOBLS ;SAVE NECESSARY STUFF AWAY FROM CONS
\r
5012 PUSH TP,C ;WHICH WILL MAKE A LIST FROM THE ATOM
\r
5016 MOVE C,(TP) ;RESTORE
\r
5021 MOVE B,-4(TP) ; GET BACK ATOM
\r
5022 MOVEM C,2(B) ; CLOBBER OBLIST IN
\r
5030 LINKCK: HRRZ C,FSAV(TB) ;CALLER'S NAME
\r
5032 SKIPA C,$TLINK ;LET US INSERT A LINK INSTEAD OF AN ATOM
\r
5033 MOVSI C,TATOM ;GET REAL ATOM FOR CALL TO ICONS
\r
5039 ALRDY: PUSH TP,$TATOM
\r
5040 PUSH TP,EQUOTE ATOM-ALREADY-THERE
\r
5043 ONOBL: PUSH TP,$TATOM
\r
5044 PUSH TP,EQUOTE ON-AN-OBLIST-ALREADY
\r
5047 ; INTERNAL INSERT CALL
\r
5049 INSRTX: POP P,0 ; GET RET ADDR
\r
5059 JRST INSRT3 ; INTO INSERT CODE
\r
5061 INSRXT: PUSH P,-4(TP)
\r
5066 ; FUNCTION TO REMOVE AN ATOM FROM AN OBLIST
\r
5068 MFUNCTION REMOVE,SUBR
\r
5076 CAML AB,[-3,,] ; SKIP IF OBLIST GIVEN
\r
5095 IRMV1: GETYP 0,A ; CHECK 1ST ARG
\r
5098 CAIE 0,TATOM ; ATOM, TREAT ACCORDINGLY
\r
5101 SKIPN D,2(B) ; SKIP IF ON OBLIST AND GET SAME
\r
5107 CAME C,D ; BETTER BE THE SAME
\r
5110 GOTOBL: ADD B,[3,,3] ; POINT TO PNAME
\r
5113 PUSH P,(B) ; PUSH PNAME
\r
5116 MOVEM D,(TP) ; SAVE OBLIST
\r
5132 HRRZ D,0 ;PREPARE TO SPLICE (0 POINTS PRIOR TO LOSING PAIR)
\r
5133 HRRZ C,(C) ;GET NEXT OF LOSING PAIR
\r
5135 CAIGE 0,HIBOT ; SKIP IF PURE
\r
5142 RMV2: HRRM C,(D) ;AND SPLICE
\r
5143 SETZM 2(B) ; CLOBBER OBLIST SLOT
\r
5144 RMVDON: SUB TP,[4,,4]
\r
5148 ;INTERNAL CALL FROM THE READER
\r
5150 RLOOKU: PUSH TP,$TFIX ;PUSH A FLAG
\r
5151 POP P,C ;POP OFF RET ADR
\r
5152 PUSH TP,C ;AND USE AS A FLAG FOR INTERNAL
\r
5153 MOVE C,(P) ; CHANGE CHAR COUNT TO WORD
\r
5158 CAMN A,$TOBLS ;IS IT ONE OBLIST?
\r
5160 CAME A,$TLIST ;IS IT A LIST
\r
5164 PUSH TP,$TOBLS ; SLOT FOR REMEBERIG
\r
5171 RLOOK2: GETYP A,(B) ;CHECK THIS IS AN OBLIST
\r
5172 MOVE B,1(B) ;VALUE
\r
5175 PUSHJ P,ILOOK ;LOOK IT UP
\r
5176 JUMPN B,RLOOK3 ;WIN
\r
5177 SKIPE -2(TP) ; SKIP IF DEFAULT NOT STORED
\r
5179 HRRZ D,(TP) ; GET CURRENT
\r
5180 MOVE D,1(D) ; OBLIST
\r
5182 MOVEM C,-4(TP) ; FOR INSERT IF NEEDED
\r
5184 HRRZ B,@(TP) ;CDR THE LIST
\r
5187 SKIPN D,-2(TP) ; RESTORE FOR INSERT
\r
5188 JRST BADDEF ; NO DEFAULT, USER LOST ON SPECIFICATION
\r
5190 SUB TP,[6,,6] ; FLUSH CRAP
\r
5193 DEFFLG==1 ;SPECIAL FLAG USED TO INDICATE THAT A DEFAULT HAS ALREADY BEEN SPECIFIED
\r
5194 DEFALT: CAIN A,TATOM ;SPECIAL DEFAULT INDICATING ATOM ?
\r
5195 CAME B,MQUOTE DEFAULT
\r
5196 JRST BADDEF ;NO, LOSE
\r
5198 XORB A,-6(TP) ;SET AND TEST FLAG
\r
5199 TLNN A,DEFFLG ; HAVE WE BEEN HERE BEFORE ?
\r
5200 JRST BADDEF ; YES, LOSE
\r
5201 SETZM -2(TP) ;ZERO OUT PREVIOUS DEFAULT
\r
5203 JRST RLOOK4 ;CONTINUE
\r
5205 RLOOK1: PUSH TP,$TOBLS
\r
5206 PUSH TP,B ; SAVE OBLIST
\r
5207 PUSHJ P,ILOOK ;LOOK IT UP THERE
\r
5208 MOVE D,(TP) ; GET OBLIST
\r
5210 JUMPE B,INSRT1 ;GO INSET IT
\r
5213 INSRT2: JRST .+2 ;
\r
5214 RLOOK3: SUB TP,[6,,6] ;POP OFF LOSSAGE
\r
5215 PUSHJ P,ILINK ;IF THIS IS A LINK FOLLOW IT
\r
5216 PUSH P,(TP) ;GET BACK RET ADR
\r
5217 SUB TP,[2,,2] ;POP TP
\r
5218 JRST IATM1 ;AND RETURN
\r
5221 BADOBL: PUSH TP,$TATOM
\r
5222 PUSH TP,EQUOTE BAD-OBLIST-OR-LIST-THEREOF
\r
5225 BADDEF: PUSH TP,$TATOM
\r
5226 PUSH TP,EQUOTE BAD-DEFAULT-OBLIST-SPECIFICATION
\r
5229 ONOTH: PUSH TP,$TATOM
\r
5230 PUSH TP,EQUOTE ATOM-ON-DIFFERENT-OBLIST
\r
5232 \f;SUBROUTINE TO MAKE AN ATOM
\r
5234 MFUNCTION ATOM,SUBR
\r
5247 IATOMI: GETYP 0,A ;CHECK ARG TYPE
\r
5250 JRST .+2 ;JUMP IF WINNERS
\r
5257 PUSHJ P,CSTAK ;COPY ONTO STACK
\r
5258 PUSHJ P,IATOM ;NOW MAKE THE ATOM
\r
5261 ;INTERNAL ATOM MAKER
\r
5263 IATOM: MOVE A,-1(P) ;GET WORDS IN PNAME
\r
5264 ADDI A,3 ;FOR VALUE CELL
\r
5265 PUSHJ P,IBLOCK ; GET BLOCK
\r
5266 MOVSI C,<(GENERAL)>+SATOM+.VECT. ;FOR TYPE FIELD
\r
5267 MOVE D,-1(P) ;RE-GOBBLE LENGTH
\r
5268 ADDI D,3(B) ;POINT TO DOPE WORD
\r
5270 SKIPG -1(P) ;EMPTY PNAME ?
\r
5271 JRST IATM0 ;YES, NO CHARACTERS TO MOVE
\r
5272 MOVE E,B ;COPY ATOM POINTER
\r
5273 ADD E,[3,,3] ;POINT TO PNAME AREA
\r
5275 SUB C,-1(P) ;POINT TO STRING ON STACK
\r
5276 MOVE D,(C) ;GET SOME CHARS
\r
5277 MOVEM D,(E) ;AND COPY THEM
\r
5280 IATM0: MOVSI A,TATOM ;TYPE TO ATOM
\r
5281 IATM1: POP P,D ;RETURN ADR
\r
5287 \f;SUBROUTINE TO GET AN ATOM'S PNAME
\r
5289 MFUNCTION PNAME,SUBR
\r
5294 CAIE A,TATOM ;CHECK TYPE IS ATOM
\r
5300 CIPNAM: SUBM M,(P)
\r
5304 IPNAME: ADD A,[3,,3]
\r
5307 PUSH P,(A) ;FLUSH PNAME ONTO P
\r
5309 IMULI B,5 ; CHARS TO B
\r
5310 MOVE 0,(P) ; LAST WORD
\r
5312 SUBI A,1 ; FIND LAST 1
\r
5313 ANDCM 0,A ; 0 HAS 1ST 1
\r
5315 HRREI 0,-34.(A) ; FIND HOW MUCH TO ADD
\r
5319 PUSHJ P,CHMAK ;MAKE A STRING
\r
5322 \f; BLOCK STRUCTURE SUBROUTINES FOR MUDDLE
\r
5324 MFUNCTION BLK,SUBR,BLOCK
\r
5328 GETYP A,(AB) ;CHECK TYPE OF ARG
\r
5329 CAIE A,TOBLS ;IS IT AN OBLIST
\r
5330 CAIN A,TLIST ;OR A LIAT
\r
5333 MOVSI A,TATOM ;LOOK UP OBLIST
\r
5334 MOVE B,IMQUOTE OBLIST
\r
5335 PUSHJ P,IDVAL ;GET VALUE
\r
5338 PUSH TP,.BLOCK(PVP) ;HACK THE LIST
\r
5339 PUSH TP,.BLOCK+1(PVP)
\r
5340 MCALL 2,CONS ;CONS THE LIST
\r
5341 MOVEM A,.BLOCK(PVP) ;STORE IT BACK
\r
5342 MOVEM B,.BLOCK+1(PVP)
\r
5344 PUSH TP,IMQUOTE OBLIST
\r
5347 MCALL 2,SET ;SET OBLIST TO ARG
\r
5350 MFUNCTION ENDBLOCK,SUBR
\r
5354 SKIPN B,.BLOCK+1(PVP) ;IS THE LIST NIL?
\r
5355 JRST BLKERR ;YES, LOSE
\r
5356 HRRZ C,(B) ;CDR THE LIST
\r
5357 HRRZM C,.BLOCK+1(PVP)
\r
5358 PUSH TP,$TATOM ;NOW RESET OBLIST
\r
5359 PUSH TP,IMQUOTE OBLIST
\r
5360 HLLZ A,(B) ;PUSH THE TYPE OF THE CAR
\r
5362 PUSH TP,1(B) ;AND VALUE OF CAR
\r
5366 BLKERR: PUSH TP,$TATOM
\r
5367 PUSH TP,EQUOTE UNMATCHED
\r
5370 BADLST: PUSH TP,$TATOM
\r
5371 PUSH TP,EQUOTE NIL-LIST-OF-OBLISTS
\r
5373 \f;SUBROUTINE TO CREATE CHARACTER STRING GOODIE
\r
5375 CHMAK: MOVE A,-1(P)
\r
5379 MOVEI C,-1(P) ;FIND START OF CHARS
\r
5380 HLRE E,B ; - LENGTH
\r
5381 ADD C,E ;C POINTS TO START
\r
5382 MOVE D,B ;COPY VECTOR RESULT
\r
5383 JUMPGE D,NULLST ;JUMP IF EMPTY
\r
5384 MOVE A,(C) ;GET ONE
\r
5386 ADDI C,1 ;BUMP POINTER
\r
5388 NULLST: MOVSI C,TCHRS+.VECT. ;GET TYPE
\r
5389 MOVEM C,(D) ;CLOBBER IT IN
\r
5390 MOVE A,-1(P) ; # WORDS
\r
5393 MOVMM E,-1(P) ; SO IATM1 WORKS
\r
5394 JRST IATM1 ;RETURN
\r
5396 ; SUBROUTINE TO READ FIVE CHARS FROM STRING.
\r
5397 ; TWO CALLS, ONE WITH A POINTING TO LIST ELEMENT,
\r
5398 ; THE OTHER WITH B POINTING TO PAIR. SKIPS IF WINNER, ELSE DOESNT
\r
5400 NXTDCL: GETYP B,(A) ;CHECK TYPE
\r
5401 CAIE B,TDEFER ;LOSE IF NOT DEFERRED
\r
5404 MOVE B,1(A) ;GET REAL BYTE POINTER
\r
5406 GETYP C,(B) ;CHECK IT IS CHSTR
\r
5408 JRST CPOPJC ;NO, QUIT
\r
5412 MOVEI E,0 ;INITIALIZE DESTINATION
\r
5413 HRRZ C,(B) ; GET CHAR COUNT
\r
5414 JUMPE C,GOTDCL ; NULL, FINISHED
\r
5415 MOVE B,1(B) ;GET BYTE POINTER
\r
5416 MOVE D,[440700,,E] ;BYTE POINT TO E
\r
5417 CHLOOP: ILDB 0,B ; GET A CHR
\r
5418 IDPB 0,D ;CLOBBER AWAY
\r
5419 SOJE C,GOTDCL ; JUMP IF DONE
\r
5420 TLNE D,760000 ; SKIP IF WORD FULL
\r
5421 JRST CHLOOP ; MORE THAN 5 CHARS
\r
5422 TRO E,1 ; TURN ON FLAG
\r
5424 GOTDCL: MOVE B,E ;RESULT TO B
\r
5425 AOS -4(P) ;SKIP RETURN
\r
5432 ; SUBROUTINE TO FIND A BYTE STRINGS DOPE WORD
\r
5433 ; RECEIVES POINTER TO PAIR CONNTAINIGN CHSTR IN C, RETURNS DOPE WORD IN A
\r
5435 BYTDOP: PUSH P,B ; SAVE SOME ACS
\r
5438 MOVE B,1(C) ; GET BYTE POINTER
\r
5439 LDB D,[360600,,B] ; POSITION TO D
\r
5440 LDB E,[300600,,B] ; AND BYTE SIZE
\r
5441 MOVEI A,(E) ; A COPY IN A
\r
5442 IDIVI D,(E) ; D=> # OF BYTES IN WORD 1
\r
5443 HRRZ E,(C) ; GET LENGTH
\r
5444 SUBM E,D ; # OF BYTES IN OTHER WORDS
\r
5445 JUMPL D,BYTDO1 ; NEAR DOPE WORD
\r
5446 MOVEI B,36. ; COMPUTE BYTES PER WORD
\r
5448 ADDI D,-1(A) ; NOW COMPUTE WORDS
\r
5449 IDIVI D,(A) ; D/ # NO. OF WORDS PAST 1ST
\r
5450 ADD D,1(C) ; D POINTS TO DOPE WORD
\r
5457 BYTDO1: MOVEI A,1(B)
\r
5461 \f;ROUTINES TO DEFINE AND HANDLE LINKS
\r
5463 MFUNCTION LINK,SUBR
\r
5465 CAML AB,[-6,,0] ;NO MORE THAN 3 ARGS
\r
5466 CAML AB,[-2,,0] ;NO LESS THAN 2 ARGS
\r
5468 CAML AB,[-4,,0] ;ONLY TWO ARGS SUPPLIED ?
\r
5469 JRST GETOB ;YES, GET OBLIST FROM CURRENT PATH
\r
5474 GETOB: MOVSI A,TATOM
\r
5475 MOVE B,IMQUOTE OBLIST
\r
5487 LINKIN: PUSHJ P,IINSRT
\r
5488 CAMN A,$TFALSE ;LINK NAME ALREADY USED ?
\r
5489 JRST ALRDY ;YES, LOSE
\r
5497 ILINK: CAME A,$TLINK ;FOUND A LINK ?
\r
5498 POPJ P, ;NO, FINISHED
\r
5500 PUSHJ P,IGVAL ;GET THE LINK'S DESTINATION
\r
5501 CAME A,$TUNBOUND ;WELL FORMED LINK ?
\r
5504 PUSH TP,EQUOTE BAD-LINK
\r
5508 ; THIS SUBROUTINE IMPURIFIES A PURE ATOM TO ALLOW MODIFICATION OF SYSTEM SUBRS
\r
5516 JRST RTNATM ; NOT PURE, RETURN
\r
5518 ; 1) IMPURIFY ITS OBLIST BUCKET
\r
5520 SKIPN B,2(C) ; PICKUP OBLIST IF IT EXISTS
\r
5521 JRST IMPUR1 ; NOT ON ONE, IGNORE THIS CODE
\r
5523 ADDI B,(TVP) ; POINT TO SLOT
\r
5524 MOVE B,(B) ; GET THE REAL THING
\r
5525 ADD C,[3,,3] ; POINT TO PNAME
\r
5526 HLRE A,C ; GET LNTH IN WORDS OF PNAME
\r
5528 PUSH P,[IMPUR2] ; FAKE OUT ILOOKC
\r
5529 PUSH P,(C) ; PUSH UP THE PNAME
\r
5531 PUSH P,A ; NOW THE COUNT
\r
5532 JRST ILOOKC ; GO FIND BUCKET
\r
5534 IMPUR2: JUMPE B,IMPUR1 ; NOT THERE, GO
\r
5535 PUSH TP,$TOBLS ; SAVE BUCKET
\r
5538 MOVE B,(E) ; GET NEXT ONE
\r
5539 IMPUR4: MOVEI 0,(B)
\r
5540 CAIGE 0,HIBOT ; SKIP IF PURE
\r
5541 JRST IMPUR3 ; FOUND IMPURE NESS, SKIP IT
\r
5542 HLLZ C,(B) ; SET UP ICONS CALL
\r
5545 PUSHJ P,ICONS ; CONS IT UP
\r
5546 HRRZ E,(TP) ; RETRV PREV
\r
5547 HRRM B,(E) ; AND CLOBBER
\r
5548 IMPUR3: MOVSI 0,TLIST
\r
5549 MOVEM 0,-1(TP) ; FIX TYPE
\r
5550 HRRZM B,(TP) ; STORE GOODIE
\r
5551 HRRZ B,(B) ; CDR IT
\r
5552 JUMPN B,IMPUR4 ; LOOP
\r
5553 SUB TP,[2,,2] ; FLUSH TP CRUFT
\r
5555 ; 2) GENERATE A DUPLICATE ATOM
\r
5557 IMPUR1: HLRE A,(TP) ; GET LNTH OF ATOM
\r
5560 PUSHJ P,IBLOCK ; GET NEW BLOCK FOR ATOM
\r
5563 HRL B,-2(TP) ; SETUP BLT
\r
5565 ADDI A,(B) ; END OF BLT
\r
5566 BLT B,(A) ; CLOBBER NEW ATOM
\r
5567 MOVSI B,.VECT. ; TURN ON BIT FOR GCHACK
\r
5570 ; 3) NOW COPY GLOBAL VALUE
\r
5572 MOVE B,(TP) ; ATOM BACK
\r
5574 SKIPE A,1(B) ; NON-ZER POINTER?
\r
5575 CAIN 0,TUNBOU ; BOUND?
\r
5576 JRST IMPUR5 ; NO, DONT COPY GLOB VAL
\r
5584 IMPUR5: PUSH TP,$TFIX ;SAVE OLD ATOM WITH FUNNY TYPE TO AVOID LOSSAGE
\r
5587 ; 4) UPDATE ALL POINTERS TO THIS ATOM
\r
5589 MOVE A,[PUSHJ P,ATFIX] ; INS TO PASS TO GCHACK
\r
5597 ; ROUTINE PASSED TO GCHACK
\r
5599 ATFIX: CAIE C,TGATOM ; GLOBAL TYPE ATOM
\r
5601 CAME D,(TP) ; SKIP IF WINNER
\r
5611 TITLE PROCESS-HACKER FOR MUDDLE
\r
5617 .GLOBAL ICR,NAPT,IGVAL,CHKARG,RESFUN,RETPROC,SWAP,MAINPR,PROCHK,NOTRES
\r
5618 .GLOBAL PSTAT,LSTRES,TOPLEV,MAINPR,1STEPR,INCONS
\r
5619 .GLOBAL TBINIT,APLQ
\r
5621 MFUNCTION PROCESS,SUBR
\r
5624 GETYP A,(AB) ;GET TYPE OF ARG
\r
5625 ;MUST BE SOME APPLIABLE TYPE
\r
5627 JRST NAPT ;NO, ERROR - NON-APPLIABLE TYPE
\r
5630 PUSHJ P,ICR ;CREATE A NEW PROCESS
\r
5631 MOVE C,TPSTO+1(B) ;GET ITS SRTACK
\r
5632 PUSH C,[TENTRY,,TOPLEV]
\r
5633 PUSH C,[1,,0] ;TIME
\r
5639 PUSH C,D ;SAVED STACK POINTER
\r
5641 MOVEM C,TPSTO+1(B) ;STORE NEW TP
\r
5642 HRRI D,1(C) ;MAKE A TB
\r
5643 HRLI D,2 ;WITH A TIME
\r
5644 MOVEM D,TBINIT+1(B)
\r
5645 MOVEM D,TBSTO+1(B) ;SAVE ALSO FOR SIMULATED START
\r
5646 MOVE C,(AB) ;STORE ARG
\r
5647 MOVEM C,RESFUN(B) ;INTO PV
\r
5649 MOVEM C,RESFUN+1(B)
\r
5651 MOVEM 0,PSTAT+1(B)
\r
5655 MFUNCTION RETPROC,SUBR
\r
5656 ; WHO KNOWS WHAT THIS SHOULD REALLY DO
\r
5657 ;PROBABLY, JUST AN EXIT
\r
5658 ;FOR NOW, PRINT OUT AN ERROR MESSAGE
\r
5660 PUSH TP,EQUOTE ATTEMPT-TO-RETURN-OUT-OF-PROCESS
\r
5669 MFUNCTION RESUME,FSUBR
\r
5670 ;RESUME IS CALLED WITH TWO ARGS
\r
5671 ;THE FIRST IS A PROCESS FORM OF THE PROCESS TO BE RESUMED
\r
5672 ;THE SECOND IS A FUNCTION TO BE CALLED WHEN THIS PROCESS
\r
5673 ; (THE PARENT) IS ITSELF RESUMED
\r
5674 ;IF THE FUNCTION IS NOT GIVEN SOME STANDARD FUNCTION IS
\r
5677 ; NOTE - TYPE AND NUMBER OF ARGS CHECKS MUST BE ADDED TO BOTH RESUME AND CREATE
\r
5680 HRRZ C,@1(AB) ;GET CDR ADDRESS
\r
5681 JUMPE C,NOFUN ;IF NO SECOND ARG, SUPPLY STANDARD
\r
5682 HLLZ A,(C) ;GET CDR TYPE
\r
5683 CAME A,$TATOM ;ATOMIC?
\r
5684 JRST RES2 ;NO, MUST EVAL TO GET FUNCTION
\r
5686 PUSHJ P,IGVAL ;TRY TO GET GLOBAL VALUE
\r
5687 CAMN A,$TUNBOUND ;GLOBALLY UNBOUND?
\r
5688 JRST LFUN ;YES, TRY FOR LOCAL VALUE
\r
5689 RES1: MOVEM A,RESFUN(PVP) ;STORE IN THIS PROCESS
\r
5690 MOVEM B,RESFUN+1(PVP)
\r
5692 HRRZ C,1(AB) ;GET CAR ADDRESS
\r
5693 PUSH TP,(C) ;PUSH PROCESS FORM
\r
5695 JSP E,CHKARG ;CHECK FOR DEFERED TYPE
\r
5696 ;INSERT CHECKS FOR PROCESS FORM
\r
5697 MCALL 1,EVAL ;EVAL PROCESS FORM WHICH WILL SWITCH
\r
5701 RES2: PUSH TP,(C) ;PUSH FUNCTION ARG
\r
5703 JSP E,CHKARG ;CHECK FOR DEFERED
\r
5704 MCALL 1,EVAL ;EVAL TO GET FUNCTION
\r
5707 LFUN: HRRZ C,1(AB) ;GET CDR ADDRESS
\r
5710 MCALL 1,VALUE ;GET LOCAL VALUE OF ATOM FOR FUNCTION
\r
5713 NOFUN: MOVSI A,TUNBOUND ;MAKE RESUME FUNCTION UNBOUND
\r
5717 ; PROCHK - SETUP LAST RESUMER SLOT
\r
5719 PROCHK: CAME B,MAINPR ; MAIN PROCESS?
\r
5720 MOVEM PVP,LSTRES+1(B)
\r
5723 ; THIS FUNCTION RESUMES A PROCESS, CALLED WITH ONE OR TWO ARGS
\r
5724 ; THE FIRST IS A VALUE TO RETURN TO THE OTHER PROCESS OR PASS TO ITS
\r
5726 ; THE SECOND IS THE PROCESS TO RESUME (IF NOT SUPPLIED, USE THE LSTRES)
\r
5729 MFUNCTION RESUME,SUBR
\r
5736 JRST CHPROC ; VALIDITY CHECK ON PROC
\r
5737 SKIPN B,LSTRES+1(PVP) ; ANY RESUMERS?
\r
5738 JRST NORES ; NO, COMPLAIN
\r
5740 CAMN B,PVP ; DO THEY DIFFER?
\r
5742 MOVE A,PSTAT+1(B) ; CHECK STATE
\r
5743 CAIE A,RUNABL ; MUST BE RUNABL
\r
5744 CAIN A,RESMBL ; OR RESUMABLE
\r
5747 NOTRUN: PUSH TP,$TATOM
\r
5748 PUSH TP,EQUOTE PROCESS-NOT-RUNABLE-OR-RESUMABLE
\r
5751 RESUM1: PUSHJ P,PROCHK ; FIX LISTS UP
\r
5752 MOVEI A,RESMBL ; GET NEW STATE
\r
5753 MOVE D,B ; FOR SWAP
\r
5754 STRTN: JSP C,SWAP ; SWAP THEM
\r
5755 MOVEM A,PSTAT+1(E) ; CLOBBER OTHER STATE
\r
5756 MOVE A,PSTAT+1(PVP) ; DECIDE HOW TO PROCEED
\r
5758 MOVEM 0,PSTAT+1(PVP) ; NEW STATE
\r
5759 MOVE C,ABSTO+1(E) ; OLD ARGS
\r
5761 JRST DORUN ; THEY DO RUN RUN, THEY DO RUN RUN
\r
5762 RETARG: MOVE A,(C)
\r
5763 MOVE B,1(C) ; RETURN
\r
5766 DORUN: PUSH TP,RESFUN(PVP)
\r
5767 PUSH TP,RESFUN+1(PVP)
\r
5771 PUSH TP,A ; CALL SUICIDE WITH THESE ARGS
\r
5773 MCALL 1,SUICID ; IF IT RETURNS, KILL IT
\r
5776 CHPROC: GETYP A,2(AB)
\r
5782 NORES: PUSH TP,$TATOM
\r
5783 PUSH TP,EQUOTE NO-PROCESS-TO-RESUME
\r
5786 ; FUNCTION TO CAUSE PROCESSES TO SELF DESTRUCT
\r
5788 MFUNCTION SUICIDE,SUBR
\r
5794 ASH A,-1 ; DIV BY 2
\r
5795 AOJE A,NOPROC ; NO PROCESS GIVEN
\r
5797 GETYP A,2(AB) ; MAKE SURE OF PROCESS
\r
5803 NOPROC: SKIPN C,LSTRES+1(PVP) ; MAKE SURE OF EDLIST
\r
5804 MOVE C,MAINPR ; IF NOT DEFAULT TO MAIN
\r
5805 SUIC2: CAMN C,PVP ; DONT SUICIDE TO SELF
\r
5814 MOVE D,B ; RESTORE NEWPROCESS
\r
5818 SUSELF: PUSH TP,$TATOM
\r
5819 PUSH TP,EQUOTE ATTEMPT-TO-SUICIDE-TO-SELF
\r
5823 MFUNCTION RESER,SUBR,RESUMER
\r
5831 GETYP A,(AB) ; CHECK FOR PROCESS
\r
5834 MOVE B,1(AB) ; GET PROCESS
\r
5835 GTLAST: MOVSI A,TFALSE ; ASSUME NONE
\r
5836 SKIPN B,LSTRES+1(B) ; GET IT IF IT EXISTS
\r
5838 MOVSI A,TPVP ; GET TYPE
\r
5841 ; FUNCTION TO PUT AN EVAL CALL ON ANOTHER PROCESSES STACK
\r
5843 MFUNCTION BREAKSEQ,SUBR,BREAK-SEQ
\r
5847 GETYP A,2(AB) ; 2D ARG MUST BE PROCESS
\r
5851 MOVE B,3(AB) ; GET PROCESS
\r
5852 CAMN B,PVP ; SKIP IF NOT ME
\r
5854 MOVE A,PSTAT+1(B) ; CHECK STATE
\r
5855 CAIE A,RESMBL ; BEST BE RESUMEABLE
\r
5857 MOVE C,TBSTO+1(B) ; GET SAVE ACS TO BUILD UP A DUMMY FRAME
\r
5858 MOVE D,TPSTO+1(B) ; STACK POINTER
\r
5859 MOVE E,SPSTO+1(B) ; FIX UP OLD FRAME
\r
5861 MOVEI E,CALLEV ; FUNNY PC
\r
5863 MOVE E,PSTO+1(B) ; SET UP P,PP AND TP SAVES
\r
5865 PUSH D,[0] ; ALLOCATES SOME SLOTS
\r
5867 PUSH D,(AB) ; NOW THAT WHIC IS TO BE EVALLED
\r
5870 HRRI E,-1(D) ; BUILD UP ARG POINTER
\r
5872 PUSH D,[TENTRY,,BREAKE]
\r
5874 PUSH D,E ; NEW ARG POINTER
\r
5875 REPEAT 4,PUSH D,[0] ; OTHER SLOTS
\r
5876 MOVEM D,TPSTO+1(B)
\r
5877 MOVEI C,(D) ; BUILD NEW AB
\r
5879 MOVEM C,TBSTO+1(B) ; STORE IT
\r
5880 MOVE A,2(AB) ; RETURN PROCESS
\r
5887 CALLEV: MOVEM A,-3(TP) ; HERE TO EVAL THE GOODIE (SAVE REAL RESULT)
\r
5894 BREAKM: PUSH TP,$TATOM
\r
5895 PUSH TP,EQUOTE ATTEMPT-TO-BREAK-OWN-SEQUENCE
\r
5898 ; FUNCTION TOP PUT PROCESS IN 1 STEP MODE
\r
5900 MFUNCTION 1STEP,SUBR
\r
5902 MOVEM PVP,1STEPR+1(B) ; CLOBBER TARGET PROCESS
\r
5905 ; FUNCTION TO UNDO ABOVE
\r
5907 MFUNCTION %%FREE,SUBR,FREE-RUN
\r
5909 CAME PVP,1STEPR+1(B)
\r
5914 FNDBND: SKIPE 1STEPR+1(B) ; DOES IT HAVE ANY 1STEPPER?
\r
5915 JRST NOTMIN ; YES, COMPLAIN
\r
5916 MOVE D,B ; COPY PROCESS
\r
5917 ADD D,[1STEPR,,1STEPR] ; POINTER FOR SEARCH
\r
5918 HRRZ C,SPSTO+1(B) ; GET THIS BINDING STACK
\r
5920 FNDLP: GETYP 0,(C) ; IS THIS A TBVL?
\r
5922 CAME D,1(C) ; SKIP IF THIS IS SAVED 1STEP SLOT
\r
5924 SKIPN 3(C) ; IS IT SAVING A REAL 1STEPPER?
\r
5926 CAME PVP,3(C) ; IS IT ME?
\r
5928 SETZM 3(C) ; CLEAR OUT SAVED 1STEPPER
\r
5930 FNDNXT: HRRZ C,(C) ; NEXT BINDING
\r
5933 NOTMIN: MOVE C,$TCHSTR
\r
5934 MOVE D,CHQUOTE NOT-YOUR-1STEPEE
\r
5947 ; FUNCTION TO RETRUN THE MAIN PROCESS
\r
5949 MFUNCTION MAIN%%,SUBR,MAIN
\r
5953 MAIN1: MOVSI A,TPVP
\r
5956 ; FUNCTION TO RETURN THE CURRENT PROCESS
\r
5964 ; FUNCTION TO RETURN THE STATE OF A PROCESS
\r
5966 MFUNCTION STATE,SUBR
\r
5971 MOVE A,1(AB) ; GET PROCESS
\r
5973 MOVE B,@STATES(A) ; GET STATE
\r
5978 IRP A,,[ILLEGAL,RUNABLE,RESUMABLE,RUNNING,DEAD,BLOCKED]
\r
5986 TITLE DECLARATION PROCESSOR
\r
5992 .GLOBAL STBL,TYPFND,TYPSGR,CHKDCL,TESTR,VALG,INCR1,TYPG,ISTRUC,TMATCH,SAT
\r
5993 .GLOBAL TYPMIS,CHKAB,CHKARG,IGDECL,LOCQQ,APLQ,CALER,IEQUAL,IIGLOC,IGLOC
\r
5994 .GLOBAL CHLOCI,INCONS,SPCCHK,WTYP1
\r
5996 ; Subr to allow user to access the DECL checking code
\r
5998 MFUNCTION CHECKD,SUBR,[DECL?]
\r
6006 PUSHJ P,TMATCX ; CHECK THEM
\r
6009 RETT: MOVSI A,TATOM
\r
6018 ; Subr to turn DECL checking on and off.
\r
6020 MFUNCTION %DECL,SUBR,[DECL-CHECK]
\r
6032 ; Change special unspecial normal mode
\r
6034 MFUNCTION SPECM%,SUBR,[SPECIAL-MODE]
\r
6040 MOVE C,SPCCHK ; GET CURRENT
\r
6041 JUMPGE AB,MODER ; RET CURRENT
\r
6042 GETYP 0,(AB) ; CHECK IT IS ATOM
\r
6047 CAMN 0,MQUOTE UNSPECIAL
\r
6049 CAMN 0,MQUOTE SPECIAL
\r
6054 MODER: MOVSI A,TATOM
\r
6055 MOVE B,MQUOTE SPECIAL
\r
6057 MOVE B,MQUOTE UNSPECIAL
\r
6060 ; Function to turn special checking on and of
\r
6062 MFUNCTION SPECC%,SUBR,[SPECIAL-CHECK]
\r
6081 ; Finction to set decls for GLOBAL values.
\r
6083 MFUNCTION GDECL,FSUBR
\r
6101 HRRZ D,(C) ; MAKE SURE PAIRS
\r
6102 JUMPE D,GDECLL ; LOSER, GO AWAY
\r
6107 MOVEM 0,1(TB) ; READY FOR NEXT CALL
\r
6108 MOVE C,1(C) ; SAVE ATOM LIST
\r
6114 JRST GDECL1 ; OUT OF ATOMS
\r
6115 GETYP 0,(C) ; IS THIS AN ATOM
\r
6117 JRST GDECLL ; NO, LOSE
\r
6121 PUSHJ P,IIGLOC ; GET ITS VAL (OR MAKE ONE)
\r
6122 GETYP 0,(B) ; UNBOUND?
\r
6124 JRST CHKCUR ; CHECK CURRENT VALUE
\r
6125 MOVE C,3(TB) ; GET DECL
\r
6129 CHKCUR: HRRZ D,3(TB)
\r
6147 TYPMI3: MOVE E,(TP) ; POINT BACK TO SLOT
\r
6148 MOVE A,-1(E) ; ATOM TO A
\r
6150 MOVE D,(E) ; GET OLD VALUE
\r
6152 JRST TYPMIS ; GO COMPLAIN
\r
6154 GDECLL: PUSH TP,$TATOM
\r
6155 PUSH TP,EQUOTE BAD-ARGUMENT-LIST
\r
6158 MFUNCTION UNMANIFEST,SUBR
\r
6162 PUSH P,[HLLZS -2(B)]
\r
6165 MFUNCTION MANIFEST,SUBR
\r
6169 PUSH P,[HLLOS -2(B)]
\r
6170 MANLP: JUMPGE AB,RETT
\r
6180 MFUNCTION MANIFQ,SUBR,[MANIFEST?]
\r
6189 PUSHJ P,IGLOC ; GET POINTER IF ANY
\r
6198 MFUNCTION GETDECL,SUBR,[GET-DECL]
\r
6205 HRRZ C,-2(B) ; GET GLOBAL DECL
\r
6206 GETD1: JUMPE C,RETF
\r
6215 RETMAN: MOVSI A,TATOM
\r
6216 MOVE B,MQUOTE MANIFEST
\r
6219 GTLOCA: HLRZ C,2(B) ; LOCAL DECL
\r
6222 MFUNCTION PUTDECL,SUBR,[PUT-DECL]
\r
6227 SKIPA E,[HRLM B,2(C)]
\r
6228 MOVE E,[HRRM B,-2(C)]
\r
6230 GETYP 0,(B) ; ANY VALUE
\r
6233 MOVE C,(B) ; GET CURRENT VALUE
\r
6239 PUTD1: MOVE C,2(AB) ; GET DECL BACK
\r
6241 PUSHJ P,INCONS ; CONS IT UP
\r
6242 MOVE C,1(AB) ; LOCATIVE BACK
\r
6248 TYPMI4: MOVE E,1(AB) ; GET LOCATIVE
\r
6249 MOVE A,-1(E) ; NOW ATOM
\r
6250 MOVEI C,2(AB) ; POINT TO DECL
\r
6251 MOVE D,(E) ; AND CURRENT VAL
\r
6255 GTLOC: GETYP 0,(AB)
\r
6260 HRRZ 0,(AB) ; LOCAL OR GLOBAL
\r
6263 MOVE B,1(AB) ; RETURN LOCATIVE IN B
\r
6266 ; Interface between EVAL and declaration processor.
\r
6267 ; E points into stack at a binding and C points to decl list.
\r
6269 CHKDCL: SKIPE IGDECL ; IGNORING DECLS?
\r
6270 POPJ P, ; YUP, JUST LEAVE
\r
6272 PUSH TP,$TTP ; SAVE BINDING
\r
6274 MOVE A,-4(E) ; GET ATOM
\r
6275 MOVSI 0,TLIST ; SETUP FOR INTERRUPTABLE
\r
6280 SETZB B,0 ; CLOBBER FOR INTGO
\r
6283 HRRZ D,(C) ; MAKE SURE EVEN ELEMENTS
\r
6285 GETYP B,(C) ; MUST BE LIST OF ATOMS
\r
6288 MOVE B,1(C) ; GET LIST
\r
6291 CAMN A,1(B) ; SKIP IF NOT WINNER
\r
6292 JRST DCLQ ; MAY BE WINNER
\r
6293 DCL3: HRRZ B,(B) ; CDR ON
\r
6294 JUMPN B,DCL1 ; JUMP IF MORE
\r
6296 HRRZ C,(D) ; CDR MAIN LIST
\r
6297 JUMPN C,DCL2 ; AND JUMP IF WINNING
\r
6299 PUSHJ P,E.GET ; GET BINDING BACK
\r
6300 SUB TP,[2,,2] ; POP OF JUNK
\r
6303 DCLQ: GETYP C,(B) ; CHECK ATOMIC
\r
6305 JRST BADCL ; LOSER
\r
6306 PUSHJ P,E.GET ; GOT IT
\r
6307 PUSH TP,$TLIST ; SAVE PATTERN
\r
6309 MOVE B,1(D) ; GET PATTERN
\r
6311 MOVE C,-3(E) ; PROPOSED VALUE
\r
6313 PUSHJ P,TMATCH ; MATCH TYPE
\r
6314 JRST TYPMI1 ; LOSER
\r
6315 DCLQ1: MOVE E,-2(TP)
\r
6316 MOVE C,-5(E) ; CHECK FOR SPEC CHANGE
\r
6317 SKIPE 0 ; MAKE SURE NON ZERO IS -1
\r
6319 SKIPL SPCCHK ; SKIP IF NORMAL UNSPECIAL
\r
6320 SETCM 0 ; COMPLEMENT
\r
6321 ANDI 0,1 ; ONE BIT
\r
6322 CAMN C,[TATOM,,-1]
\r
6324 CAME C,[TATOM,,-2]
\r
6327 IOR C,0 ; MUNG BIT
\r
6331 MOVEM C,(E) ; STORE DECLS
\r
6336 TYPMI1: MOVE E,-2(TP)
\r
6340 MOVE E,-2(TP) ; GET POINTER TO BIND
\r
6341 MOVE D,-3(E) ; GET VAL
\r
6343 HRRZ C,(TP) ; DCL LIST
\r
6344 MOVE A,-4(E) ; GET ATOM
\r
6346 TYPMIS: PUSH TP,$TATOM
\r
6347 PUSH TP,EQUOTE TYPE-MISMATCH
\r
6353 JSP E,CHKARG ; HACK DEFER
\r
6356 MOVEI A,4 ; 3 ERROR ARGS
\r
6359 BADCL: PUSHJ P,E.GET
\r
6361 PUSH TP,EQUOTE BAD-DECLARATION-LIST
\r
6364 ; ROUTINE TO RESSET INT STUFF
\r
6366 E.GET: MOVE E,(TP)
\r
6372 ; Declarations processor for MUDDLE type declarations.
\r
6373 ; Receives a pattern in a and B and an object in C and D.
\r
6374 ; It skip returns if the object fits otherwise it doesn't.
\r
6375 ; Declaration syntax errors are caught and sent to ERROR.
\r
6377 TMATCH: MOVEI 0,1 ; RET SPECIAL INDICATOR
\r
6378 SKIPE IGDECL ; IGNORING DECLS?
\r
6379 JRST CPOPJ1 ; YUP, ACT LIKE THEY WON
\r
6381 TMATCX: GETYP 0,A ; GET PATTERNS TYPE
\r
6382 CAIN 0,TFORM ; MUST BE FORM OR ATOM
\r
6385 JRST TERR1 ; WRONG TYPE FOR A DCL
\r
6387 ; SIMPLE TYPE MATCHER
\r
6389 TYPMAT: GETYP E,C ; OBJECTS TYPE TO E
\r
6390 PUSH P,E ; SAVE IT
\r
6391 PUSHJ P,TYPFND ; CONVERT TYPE NAME TO CODE
\r
6392 JRST SPECS ; NOT A TYPE NAME, TRY SPECIALS
\r
6393 POP P,E ; RESTORE TYPE OF OBJECT
\r
6394 MOVEI 0,0 ; SPECIAL INDICATOR
\r
6395 CAIN E,(D) ; SKIP IF LOSERS
\r
6396 CPOPJ1: AOS (P) ; GOOD RETURN
\r
6399 SPECS: POP P,A ; RESTORE OBJECTS TYPE
\r
6401 JRST CPOPJ1 ; RETURN IMMEDIATELY IF ANYTHING WINS
\r
6402 CAMN B,MQUOTE STRUCTURED
\r
6403 JRST ISTRUC ; LET ISTRUC DO THE WORK
\r
6404 CAMN B,MQUOTE APPLICABLE
\r
6406 CAME B,MQUOTE LOCATIVE
\r
6410 ; ARRIVE HERE FOR A FORM IN THE DCLS
\r
6412 TMAT1: JUMPE B,TERR3 ; EMPTY FORM LOSES
\r
6413 HRRZ E,(B) ; CDR IT
\r
6414 JUMPE E,TMAT3 ; CANT BE SPECIAL/UNSPECIAL, LEAVE
\r
6415 PUSHJ P,0ATGET ; GET POSSIBLE ATOM IN 0
\r
6416 JRST TEXP1 ; NOT ATOM
\r
6417 CAME 0,MQUOTE SPECIAL
\r
6418 CAMN 0,MQUOTE UNSPECIAL
\r
6419 JRST TMAT2 ; IGNORE SPECIAL/UNSPECIAL
\r
6420 TMAT3: PUSHJ P,TEXP1
\r
6423 MOVEI 0,0 ; RET UNSPECIAL INDICATION
\r
6426 TEXP1: JUMPE B,TERR3 ; EMPTY FORM
\r
6427 GETYP 0,A ; CHECK CURRENT TYPE
\r
6428 CAIN 0,TATOM ; IF ATOM,
\r
6429 JRST TYPMA1 ; SIMPLE MATCH
\r
6432 GETYP 0,(B) ; WHAT IS FIRST ELEMEMT
\r
6433 CAIE 0,TFORM ; FORM=> <<OR ..>....> OR <<PRIMTYPE FOO>....>
\r
6435 PUSH TP,$TLIST ; SAVE LIST
\r
6437 MOVE B,1(B) ; GET FORM
\r
6441 TDZA 0,0 ; REMEMBER LACK OF SKIP
\r
6445 MOVE B,(TP) ; GET BACK SAVED LIST
\r
6447 JUMPE 0,CPOPJ ; LOSERS EXIT IMMEDIATELY
\r
6448 HRRZ B,(B) ; OTHERWISE REST THE LIST AND FALL INTO ELETYPE
\r
6450 ; CHECKS TYPES OF ELEMENTS OF STRUCTURES
\r
6452 ELETYP: JUMPE B,CPOPJ1 ; EMPTY=> WON
\r
6453 PUSH TP,$TLIST ; SAVE DCL LIST
\r
6455 MOVE A,C ; GET OBJ IN A AND B
\r
6457 PUSHJ P,TYPSGR ; GET REST/NTH CODE
\r
6458 JRST ELETYL ; LOSER
\r
6461 PUSH P,C ; SAVE CODE
\r
6462 PUSH TP,[0] ; AND SLOTS
\r
6465 ; MAIN ELEMENT SCANNING LOOP
\r
6467 ELETY1: XCT TESTR(C) ; SKIP IF OBJ NOT EMPTY
\r
6468 JRST ELETY2 ; CHEK EMPTY WINNER
\r
6469 XCT TYPG(C) ; GET ELEMENT
\r
6471 JSP E,CHKAB ; CHECK OUT DEFER
\r
6472 MOVEM A,-1(TP) ; AND SAVE IT
\r
6475 MOVE D,B ; FOR OTHER MATCHERS
\r
6476 MOVE B,-4(TP) ; GET PATTERN
\r
6478 GETYP 0,(B) ; GET TYPE OF <1 pattern>
\r
6479 MOVE B,1(B) ; GET ATOM OR WHATEVER
\r
6480 CAIE 0,TATOM ; ATOM ... SIMPLE TYPE
\r
6482 PUSHJ P,TYPMAT ; DO SIMPLE TYPE MATCH
\r
6483 JRST ELETY4 ; LOSER
\r
6485 ; HERE TO REST EVERYTHING AND GO ON BACK
\r
6487 ELETY6: MOVE D,-2(TP) ; GET OBJ POINTER
\r
6488 MOVE C,(P) ; GET INCREMENT CODE
\r
6490 MOVEM D,-2(TP) ; SAVED INCREMENTED GOODIR
\r
6494 ELETY9: HRRZ B,@-4(TP) ; CDR IT
\r
6498 ; HERE IF PATTERN EMPTY
\r
6500 ELETY8: AOS -1(P) ; SKIP RETURN
\r
6501 ELETY4: SETZM DSTO(PVP)
\r
6506 ELETYL: SUB TP,[2,,2]
\r
6509 ; HERE TO HANDLE EMPTY OBJECT
\r
6511 ELETY2: MOVE B,-4(TP) ; GET PATTERN
\r
6512 GETYP 0,(B) ; CHECK FOR [REST ...]
\r
6515 JRST ELETY4 ; LOSER
\r
6516 HLRZ 0,1(B) ; SIZE OF IT
\r
6517 CAILE 0,-4 ; MUST BE 2
\r
6519 MOVE B,1(B) ; GET IT
\r
6520 PUSHJ P,0ATGET ; LOOK FOR REST
\r
6522 CAMN 0,MQUOTE REST
\r
6523 JRST ELETY8 ; WINNER!!!!
\r
6524 JRST ELETY4 ; LOSER
\r
6526 ; HERE TO CHECK OUT A FORM ELEMNT
\r
6528 ELETY3: CAIE 0,TFORM
\r
6531 PUSHJ P,TEXP1 ; AND ANALYSE IT
\r
6532 JRST ELETY4 ; LOSER
\r
6533 MOVE 0,-3(TP) ; RESET DSTO
\r
6535 JRST ELETY6 ; WINNER
\r
6537 ; CHECK FOR VECTOR IN PATTERN
\r
6539 ELETY7: CAIE 0,TVEC ; SKIP IF WINNER
\r
6540 JRST TERR12 ; YET ANOTHER ERROR
\r
6541 HLRE C,B ; CHECK LEENGTH
\r
6542 CAMLE C,[-4] ; MUST BE 2 LONG
\r
6544 PUSHJ P,0ATGET ; 1ST ELEMENT ATOM?
\r
6545 JRST ELET71 ; COULD BE FORM
\r
6546 CAME 0,MQUOTE REST
\r
6548 MOVNI 0,1 ; FLAG USED IN RESTIT
\r
6549 PUSHJ P,RESTIT ; CHECK REST OF STRUCTUR
\r
6551 JRST ELETY8 ; WIN AND DONE
\r
6553 ; CHECK FOR [fix .... ]
\r
6555 ELET71: CAIE 0,TFIX
\r
6559 MOVE 0,1(B) ; GET NUMBER
\r
6560 IMULI 0,-1(C) ; COUNT MORE
\r
6561 PUSHJ P,RESTIT ; AND CHECK FIX NUM OF ELEMENTS
\r
6563 MOVE D,-2(TP) ; GET OBJECT BACK
\r
6564 MOVE 0,-3(TP) ; RESET DSTO
\r
6566 MOVE C,(P) ; RESTORE CODE FOR RESTING ETC.
\r
6570 ; HERE TO DO A TASTEFUL TYPMAT
\r
6575 TDZA 0,0 ; REMEMBER LOSSAGE
\r
6576 MOVEI 0,1 ; OR WINNAGE
\r
6578 POP TP,C ; RESTORE OBJECT
\r
6579 JUMPN 0,CPOPJ1 ; SKIPPED BEFORE, SKIP AGAIN
\r
6582 ; HERE TO SKIP SPECIAL/UNSPECIAL
\r
6584 TMAT2: CAME 0,MQUOTE SPECIAL
\r
6587 PUSH P,0 ; SAVE INDICATOR
\r
6588 GETYP A,(E) ; TYPE OF NEW PAT
\r
6589 MOVE B,1(E) ; VALUE
\r
6597 ; LOOK FOR <OR... OR <PRIMTYPE....
\r
6599 TEXP12: CAIE 0,TATOM
\r
6601 MOVE 0,1(B) ; GET ATOM
\r
6602 CAMN 0,MQUOTE QUOTE
\r
6603 JRST MQUOT ; MATCH A QUOTED OBJECT
\r
6605 CAMN 0,MQUOTE PRIMTYPE
\r
6606 JRST ACTORT ; FALL INTO ACTOR HACKER
\r
6609 MOVE B,0 ; GET ATOM
\r
6610 PUSH TP,C ; SAVE OBJ
\r
6618 JUMPN 0,.+3 ; TO ELETYP IF WON
\r
6620 POPJ P, ; ELSE LOSE
\r
6636 ; THIS CODE HANDLES ORs AND PRIMTYPEs
\r
6637 ACTRT1: SKIPA E,[PACT]
\r
6639 ACTORT: MOVEI E,TEXP1
\r
6640 JUMPE B,TERR6 ; EMPTY, LOSE
\r
6641 PUSHJ P,0ATGET ; ATOM TO 0
\r
6645 HRRZ 0,(B) ; REST IT FLUSHING OR
\r
6647 PUSH TP,$TLIST ; SAVE LSIT
\r
6649 PUSH P,E ; SAVE ELEMENT CHECKER
\r
6651 ORLP: SKIPN B,(TP) ; ANY LEFT?
\r
6652 JRST ORDON ; NOPE, LOSE
\r
6653 HRRZ 0,(B) ; SAVE THE REST
\r
6655 GETYP 0,(B) ; WHAT ARE WE ORing
\r
6656 MOVE A,(B) ; TYPE WORD
\r
6657 MOVE B,1(B) ; AND ITEM
\r
6658 PUSHJ P,@(P) ; EITHER PACT OR TEXP1
\r
6659 JRST ORLP ; HAVEN'T WON YET
\r
6660 AOS -1(P) ; SKIP RETURN FOR WINNER
\r
6662 ORDON: SUB TP,[2,,2] ; FLUSH TEMP
\r
6666 ; HERE TO PRIMTYPE ACTORS
\r
6668 PACT: CAIE 0,TFORM
\r
6670 JUMPE B,TERR6 ; EMPTY FORM
\r
6671 MOVE 0,1(B) ; FIRST ELEMENT MUST BE PRIMTYPE
\r
6672 PACT2: CAME 0,MQUOTE PRIMTYPE
\r
6674 HRRZ B,(B) ; GET PRIMTYPE
\r
6676 GETYP A,C ; GET OBJ TYPE
\r
6677 GETYP 0,(B) ; GET PATTERN TYPE
\r
6678 CAIE 0,TATOM ; BETTER BE ATOM
\r
6680 PUSH TP,$TLIST ; SAVE DCL LIST
\r
6684 PUSHJ P,SAT ; GET STORAGE TYPE
\r
6687 MOVE B,@STBL(A) ; GET PRIM NAME
\r
6690 MOVSI C,(D) ; FAKE OUT TYPMAT
\r
6701 PACT1: CAIE 0,TATOM
\r
6705 PTEMP: MOVE B,-2(TP)
\r
6707 CAMN B,MQUOTE TEMPLATE
\r
6712 ; RESTIT - TYPE CHECK SELECTED NUMBER OF ELEMENTS IN STRUCTURE
\r
6714 RESTIT: PUSH TP,$TVEC ; SAVE TYPE
\r
6715 ADD B,[2,,2] ; SKIP OVER CRUFT
\r
6716 PUSH TP,B ; AND VAL
\r
6719 RESTI1: PUSH P,A ; SAVE DISP HACK
\r
6720 PUSH P,0 ; AND COUNT HACK
\r
6721 RESTI4: SKIPL (P) ; SKIP IF DOING ALL
\r
6722 SOSL (P) ; SKIP IF DONE
\r
6724 AOS -2(P) ; SKIP RET
\r
6725 RESTI5: SUB P,[2,,2] ; POP JUNK
\r
6728 RESTI6: MOVE C,-3(P) ; REST CODE
\r
6729 MOVE D,-6(TP) ; SET UP FOR REST
\r
6730 MOVE E,-7(TP) ; DONT FORGET DSTO
\r
6732 XCT TESTR(C) ; DONE?
\r
6733 JRST RESTI2 ; YES, CHECK WINNAGE
\r
6735 XCT VALG(C) ; GET VAL ANDTYPE
\r
6736 JSP E,CHKAB ; CHECK DEFER
\r
6737 XCT INCR1(C) ; REST IT
\r
6738 MOVEM D,-6(TP) ; SAVE LIST
\r
6740 MOVEM E,-7(TP) ; FIXUP
\r
6744 SKIPL A,(TP) ; ANY MORE?
\r
6745 MOVE A,-2(TP) ; NO RECYCLE
\r
6746 ADD A,[2,,2] ; BUMP
\r
6747 MOVEM A,(TP) ; AND SAVE
\r
6748 MOVE B,-1(A) ; GET ELEMENT
\r
6753 MOVEI E,TYPMAT ; ATOM --> SIMPLE TYPE
\r
6754 CAIN 0,TFORM ; FORM--> HAIRY PATTERN
\r
6756 PUSHJ P,(E) ; DO IT
\r
6760 RESTI2: SKIPGE (P) ; SKIP IF WON
\r
6761 AOS -2(P) ; COUNTERACT CPOPJ1
\r
6767 ; HERE TO MATHC A QUOTED OBJ
\r
6768 ; B/ FORM QUOTE... C,D/ OBJECT TO MATCH AGAINST
\r
6770 MQUOT: HRRZ B,(B) ; LOOK AT NEXT
\r
6772 GETYP A,(B) ; GET TYPE
\r
6774 MOVE B,1(B) ; AND VALUE
\r
6775 JSP E,CHKAB ; HACK DEFER
\r
6788 ; GET ATOM IN AC 0
\r
6790 0ATGET: GETYP 0,(B)
\r
6791 CAIE 0,TATOM ; SKIP IF ATOM
\r
6793 MOVE 0,1(B) ; GET ATOM
\r
6796 TERR9: MOVS A,0 ; TYPE TO A
\r
6800 TERR1: MOVE E,EQUOTE DECL-ELEMENT-NOT-FORM-OR-ATOM
\r
6803 TERR2: MOVSI A,TATOM
\r
6804 MOVE E,EQUOTE ATOM-NOT-TYPE-NAME-OR-SPECIAL-SYMBOL
\r
6807 TERR3: MOVE E,EQUOTE EMPTY-FORM-IN-DECL
\r
6809 TERR7: MOVE E,EQUOTE EMPTY-OR/PRIMTYPE-FORM
\r
6812 TERR8: MOVS A,0 ; TYPE TO A
\r
6813 MOVE E,EQUOTE NON-TYPE-FOR-PRIMTYPE-ARG
\r
6815 TERR12: MOVE E,EQUOTE ELEMENT-TYPE-NOT-ATOM-FORM-OR-VECTOR
\r
6817 TERR13: MOVE E,EQUOTE VECTOR-LESS-THAN-2-ELEMENTS
\r
6819 TERR14: MOVE E,EQUOTE FIRST-VECTOR-ELEMENT-NOT-REST-OR-A-FIX
\r
6821 TERRD: PUSH TP,$TATOM
\r
6822 PUSH TP,EQUOTE BAD-TYPE-SPECIFICATION
\r
6837 \f\fTITLE EVAL -- MUDDLE EVALUATOR
\r
6841 ; GERALD JAY SUSSMAN, 1971. REWRITTEN MANY TIMES SINCE C. REEVE (1972--1974)
\r
6844 .GLOBAL BINDID,LPROG,GLOBSP,GLOBASE,SPBASE,TPBASE,PTIME,SWAP,CHFRAM
\r
6845 .GLOBAL IGVAL,CHKARG,NXTDCL,TPOVFL,CHFRM,PROCHK,CHFSWP,VECBOT,TYPSGR
\r
6846 .GLOBAL ILVAL,ER1ARG,SPECBIND,MAKACT,SPECSTORE,MAKTUP,TPALOC,IBIND,SSPECS
\r
6847 .GLOBAL IDVAL,EVECTO,EUVECT,CHARGS,BCKTRK,CELL,ILOC,IGLOC,CHKDCL,SSPEC1
\r
6848 .GLOBAL PDLBUF,MESS,FACTI,CHKARG,MAKENV,PSTAT,BNDV,UNBOU,UNAS,IGDECL
\r
6849 .GLOBAL 1STEPR,SEGMNT,SEGLST,NAPT,EVTYPE,EVATYP,APTYPE,APLTYP,APLQ,IDVAL1
\r
6850 .GLOBAL TESTR,VALG,TYPG,INCR1,TMATCH,TYPMIS,SAT,MAKACT,NTPALO,SPECBND
\r
6851 .GLOBAL TPGROW,CHKAB,TYPSEG,NXTLM,MONCH0,CHFINI,RMONC0,IMPURIFY,ICONS,INCONS
\r
6852 .GLOBAL CILVAL,CISET,CIGVAL,CSETG,MAPPLY,CLLOC,CGLOC,CASSQ,CGASSQ,CBOUND
\r
6853 .GLOBAL IIGLOC,CHUNW,IUNWIN,UNWIN2,SPCCHK,CURFCN,TMPLNT,TD.LNT,TBINIT
\r
6855 .GLOBAL AGC,GVLINC,LVLINC,CGBOUN,IEVECT,MAKTU2
\r
6862 ; ENTRY TO EXPAND A MACRO
\r
6864 MFUNCTION EXPAND,SUBR
\r
6868 MOVEI A,PVLNT*2+1(PVP)
\r
6870 MOVE B,TBINIT+1(PVP)
\r
6877 ; MAIN EVAL ENTRANCE
\r
6879 MFUNCTION EVAL,SUBR
\r
6883 SKIPE C,1STEPR+1(PVP) ; BEING 1 STEPPED?
\r
6884 JRST 1STEPI ; YES HANDLE
\r
6885 EVALON: HLRZ A,AB ;GET NUMBER OF ARGS
\r
6886 CAIE A,-2 ;EXACTLY 1?
\r
6887 JRST AEVAL ;EVAL WITH AN ALIST
\r
6888 SEVAL: GETYP A,(AB) ;GET TYPE OF ARG
\r
6889 SKIPE C,EVATYP+1(TVP) ; USER TYPE TABLE?
\r
6891 SEVAL1: CAIG A,NUMPRI ;PRIMITIVE?
\r
6892 JRST @EVTYPE(A) ;YES-DISPATCH
\r
6894 SELF: MOVE A,(AB) ;TYPES WHICH EVALUATE
\r
6896 JRST EFINIS ;TO SELF-EG NUMBERS
\r
6898 ; HERE FOR USER EVAL DISPATCH
\r
6900 EVDISP: ADDI C,(A) ; POINT TO SLOT
\r
6902 SKIPE (C) ; SKIP EITHER A LOSER OR JRST DISP
\r
6903 JRST EVDIS1 ; APPLY EVALUATOR
\r
6904 SKIPN C,1(C) ; GET ADDR OR GO TO PURE DISP
\r
6908 EVDIS1: PUSH TP,(C)
\r
6912 MCALL 2,APPLY ; APPLY HACKER TO OBJECT
\r
6916 ; EVAL DISPATCH TABLE
\r
6918 DISTBL EVTYPE,SELF,[[TFORM,EVFORM],[TLIST,EVLIST],[TVEC,EVECT],[TUVEC,EUVEC]
\r
6922 ;WATCH FOR SUBTLE BUG 43 LERR,LPROG OR BINDID
\r
6924 CAIE A,-4 ;EXACTLY 2 ARGS?
\r
6925 JRST WNA ;NO-ERROR
\r
6926 GETYP A,2(AB) ;CHECK THAT WE HAVE A FRAME
\r
6931 JRST TRYPRO ; COULD BE PROCESS
\r
6932 MOVEI B,2(AB) ; POINT TO FRAME
\r
6933 AEVAL2: PUSHJ P,CHENV ; HACK ENVIRONMENT CHANGE
\r
6934 AEVAL1: PUSH TP,(AB)
\r
6937 AEVAL3: HRRZ 0,FSAV(TB)
\r
6942 TRYPRO: CAIE A,TPVP ; SKIP IF IT IS A PROCESS
\r
6944 MOVE C,3(AB) ; GET PROCESS
\r
6945 CAMN C,PVP ; DIFFERENT FROM ME?
\r
6946 JRST SEVAL ; NO, NORMAL EVAL WINS
\r
6947 MOVE B,SPSTO+1(C) ; GET SP FOR PROCESS
\r
6948 MOVE D,TBSTO+1(C) ; GET TOP FRAME
\r
6949 HLL D,OTBSAV(D) ; TIME IT
\r
6950 MOVEI C,PVLNT*2+1(C) ; CONS UP POINTER TO PROC DOPE WORD
\r
6951 HRLI C,TFRAME ; LOOK LIK E A FRAME
\r
6952 PUSHJ P,SWITSP ; SPLICE ENVIRONMENT
\r
6955 ; ROUTINE TO CHANGE LOOK UP PATH FOR BINDINGS
\r
6957 CHENV: PUSHJ P,CHFRM ; CHECK OUT FRAME
\r
6958 MOVE C,(B) ; POINT TO PROCESS
\r
6959 MOVE D,1(B) ; GET TB POINTER FROM FRAME
\r
6960 CAMN SP,SPSAV(D) ; CHANGE?
\r
6961 POPJ P, ; NO, JUST RET
\r
6962 MOVE B,SPSAV(D) ; GET SP OF INTEREST
\r
6963 SWITSP: MOVSI 0,TSKIP ; SET UP SKIP
\r
6964 HRRI 0,1(TP) ; POINT TO UNBIND PATH
\r
6966 ADD A,[BINDID,,BINDID] ; BIND THE BINDING ID
\r
6970 AOS A,PTIME ; NEW ID
\r
6972 MOVE E,TP ; FOR SPECBIND
\r
6975 PUSH TP,C ; SAVE PROCESS
\r
6977 PUSHJ P,SPECBE ; BIND BINDID
\r
6978 MOVE SP,TP ; GET NEW SP
\r
6979 SUB SP,[3,,3] ; SET UP SP FORK
\r
6983 ; HERE TO EVALUATE A FORM (99% OF EVAL'S WORK)
\r
6985 EVFORM: SKIPN C,1(AB) ; EMPTY FORM, RETURN FALSE
\r
6987 GETYP A,(C) ; 1ST ELEMENT OF FORM
\r
6988 CAIE A,TATOM ; ATOM?
\r
6989 JRST EV0 ; NO, EVALUATE IT
\r
6990 MOVE B,1(C) ; GET ATOM
\r
6991 PUSHJ P,IGVAL ; GET ITS GLOBAL VALUE
\r
6993 ; SPECIAL HACK TO SPEED UP LVAL AND GVAL CALLS
\r
6997 JRST ATMVAL ; FAST ATOM VALUE
\r
7000 CAIE 0,TUNBOU ; BOUND?
\r
7001 JRST IAPPLY ; YES APPLY IT
\r
7003 MOVE C,1(AB) ; LOOK FOR LOCAL
\r
7008 JRST IAPPLY ; WIN, GO APPLY IT
\r
7011 PUSH TP,EQUOTE UNBOUND-VARIABLE
\r
7013 MOVE C,1(AB) ; FORM BACK
\r
7016 PUSH TP,MQUOTE VALUE
\r
7017 MCALL 3,ERROR ; REPORT THE ERROR
\r
7020 EFALSE: MOVSI A,TFALSE ; SPECIAL FALSE FOR EVAL OF EMPTY FORM
\r
7024 ATMVAL: HRRZ D,(C) ; CDR THE FORM
\r
7025 HRRZ 0,(D) ; AND AGAIN
\r
7027 GETYP 0,(D) ; MAKE SURE APPLYING TO ATOM
\r
7030 MOVEI E,IGVAL ; ASSUME GLOBAAL
\r
7031 CAIE B,GVAL ; SKIP IF OK
\r
7032 MOVEI E,ILVAL ; ELSE USE LOCAL
\r
7033 PUSH P,B ; SAVE SUBR
\r
7034 MOVE B,(D)+1 ; CLR BUG #1637 (GET THE ATOM FOR THE SUBR)
\r
7035 PUSHJ P,(E) ; AND GET VALUE
\r
7037 JRST EFINIS ; RETURN FROM EVAL
\r
7039 MOVSI A,TSUBR ; CAUSE REAL SUBR TO GET EROR
\r
7042 ; HERE FOR 1ST ELEMENT NOT A FORM
\r
7044 EV0: PUSHJ P,FASTEV ; EVAL IT
\r
7046 ; HERE TO APPLY THINGS IN FORMS
\r
7048 IAPPLY: PUSH TP,(AB) ; SAVE THE FORM
\r
7051 PUSH TP,B ; SAVE THE APPLIER
\r
7052 PUSH TP,$TFIX ; AND THE ARG GETTER
\r
7054 PUSHJ P,APLDIS ; GO TO INTERNAL APPLIER
\r
7055 JRST EFINIS ; LEAVE EVAL
\r
7057 ; HERE TO EVAL 1ST ELEMENT OF A FORM
\r
7059 FASTEV: SKIPE 1STEPR+1(PVP) ; BEING 1 STEPPED?
\r
7060 JRST EV02 ; YES, LET LOSER SEE THIS EVAL
\r
7061 GETYP A,(C) ; GET TYPE
\r
7062 SKIPE D,EVATYP+1(TVP) ; USER TABLE?
\r
7063 JRST EV01 ; YES, HACK IT
\r
7064 EV03: CAIG A,NUMPRI ; SKIP IF SELF
\r
7065 SKIPA A,EVTYPE(A) ; GET DISPATCH
\r
7066 MOVEI A,SELF ; USE SLEF
\r
7068 EV04: CAIE A,SELF ; IF EVAL'S TO SELF, JUST USE IT
\r
7074 HLLZ A,(C) ; GET IT
\r
7076 JSP E,CHKAB ; CHECK DEFERS
\r
7077 POPJ P, ; AND RETURN
\r
7079 EV01: ADDI D,(A) ; POINT TO SLOT OF USER EVAL TABLE
\r
7081 SKIPE (D) ; EITHER NOT GIVEN OR SIMPLE
\r
7083 SKIPN 1(D) ; SKIP IF SIMPLE
\r
7084 JRST EV03 ; NOT GIVEN
\r
7089 HLLZS (TP) ; FIX UP LH
\r
7096 ; MAPF/MAPR CALL TO APPLY
\r
7100 MAPPLY: JRST APPLY
\r
7102 ; APPLY, FALLS INTO EVAL'S APPLY CODE AT APLDIS
\r
7104 MFUNCTION APPLY,SUBR
\r
7108 JUMPGE AB,TFA ; MUST BE AT LEAST 1 ARGUMENT
\r
7113 PUSH TP,(AB) ; SAVE FCN
\r
7115 PUSH TP,$TFIX ; AND ARG GETTER
\r
7116 PUSH TP,[SETZ APLARG]
\r
7120 ; STACKFROM, ALSO FALLS INTO EVAL'S APPLIER AT APLDIS
\r
7122 MFUNCTION STACKFORM,FSUBR
\r
7129 MOVEI A,3 ; CHECK ALL GOODIES SUPPLIED
\r
7133 HRRZ B,(B) ; CDR IT
\r
7136 HRRZ C,1(AB) ; GET LIST BACK
\r
7137 PUSHJ P,FASTEV ; DO A FAST EVALUATION
\r
7139 HRRZ C,@1(AB) ; POINT TO ARG GETTING FORMS
\r
7141 PUSH TP,A ; AND FCN
\r
7144 PUSH TP,[SETZ EVALRG]
\r
7149 ; OFFSETS FOR TEMPORARIES ETC. USED IN APPLYING STUFF
\r
7151 E.FRM==0 ; POINTS TO FORM BEING EVALED (OR ARGS FOR APPLY STACKFORM)
\r
7152 E.FCN==2 ; FUNCTION/SUBR/RSUBR BEING APPLIED
\r
7153 E.ARG==4 ; POINTS TO ARG GETTING ROUTINE (<0 => MUST EVAL ARGS)
\r
7154 E.EXTR==6 ; CONTAINS 1ST ARG IN USER APPLY CASE
\r
7155 E.SEG==10 ; POINTS TO SEGMENT IN FORM BEING HACKED
\r
7156 E.CNT==12 ; COUNTER FOR TUPLES OF ARGS
\r
7157 E.DECL==14 ; POINTS TO DECLARATION LIST IN FUNCTIONS
\r
7158 E.ARGL==16 ; POINTS TO ARG LIST IN FUNCTIONS
\r
7159 E.HEW==20 ; POINTS TO HEWITT ATOM IF IT EXISTS
\r
7161 E.VAL==E.ARGL ; VALUE TYPE FOR RSUBRS
\r
7163 MINTM==E.EXTR+2 ; MIN # OF TEMPS EVER ALLOCATED
\r
7164 E.TSUB==E.CNT+2 ; # OF TEMPS FOR SUBR/NUMBER APPLICATION
\r
7165 XP.TMP==E.HEW-E.EXTR ; # EXTRA TEMPS FOR FUNCTION APPLICATION
\r
7166 R.TMP==4 ; TEMPS AFTER ARGS ARE BOUND
\r
7167 TM.OFF==E.HEW+2-R.TMP ; TEMPS TO FLUSH AFTER BIND OF ARGS
\r
7169 RE.FCN==0 ; AFTER BINDING CONTAINS FCN BODY
\r
7170 RE.ARG==2 ; ARG LIST AFTER BINDING
\r
7172 ; GENERAL THING APPLYER
\r
7174 APLDIS: PUSH TP,[0] ; SLOT USED FOR USER APPLYERS
\r
7176 APLDIX: GETYP A,E.FCN(TB) ; GET TYPE
\r
7178 APLDI: SKIPE D,APLTYP+1(TVP) ; USER TABLE EXISTS?
\r
7179 JRST APLDI1 ; YES, USE IT
\r
7180 APLDI2: CAIG A,NUMPRI ; SKIP IF NOT PRIM
\r
7184 APLDI1: ADDI D,(A) ; POINT TO SLOT
\r
7186 SKIPE (D) ; SKIP IF NOT GIVEN OR STANDARD
\r
7188 APLDI4: SKIPE D,1(D) ; GET DISP
\r
7190 JRST APLDI2 ; USE SYSTEM DISPATCH
\r
7192 APLDI3: SKIPE E.EXTR+1(TB) ; SKIP IF HAVEN'T BEEN HERE BEFORE
\r
7194 MOVE A,(D) ; GET ITS HANDLER
\r
7195 EXCH A,E.FCN(TB) ; AND USE AS FCN
\r
7196 MOVEM A,E.EXTR(TB) ; SAVE
\r
7198 EXCH A,E.FCN+1(TB)
\r
7199 MOVEM A,E.EXTR+1(TB) ; STASH OLD FCN AS EXTRG
\r
7200 GETYP A,(D) ; GET TYPE
\r
7204 ; APPLY DISPATCH TABLE
\r
7206 DISTBL APTYPE,<SETZ NAPTL>,[[TSUBR,APSUBR],[TFSUBR,APFSUB],[TRSUBR,APRSUB],[TFIX,APNUM]
\r
7207 [TEXPR,APEXPR],[TFUNAR,APFUNARG],[TENTER,APENTR],[TMACRO,APMACR]]
\f\r
7209 ; SUBR TO SAY IF TYPE IS APPLICABLE
\r
7211 MFUNCTION APPLIC,SUBR,[APPLICABLE?]
\r
7220 ; HERE TO DETERMINE IF A TYPE IS APPLICABLE
\r
7223 SKIPN B,APLTYP+1(TVP)
\r
7224 JRST USEPUR ; USE PURE TABLE
\r
7226 ADDI B,(A) ; POINT TO SLOT
\r
7227 SKIPG 1(B) ; SKIP IF WINNER
\r
7228 SKIPE (B) ; SKIP IF POTENIAL LOSER
\r
7230 SKIPE 1(B) ; SKIP IF MUST USE PURE TABBLE
\r
7232 USEPUR: CAIG A,NUMPRI ; SKIP IF NOT PRIM
\r
7233 SKIPL APTYPE(A) ; SKIP IF APLLICABLE
\r
7241 SKIPN E.EXTR(TB) ; IF EXTRA ARG
\r
7242 SKIPGE E.ARG+1(TB) ; OR APPLY/STACKFORM, LOSE
\r
7244 MOVE A,E.FCN+1(TB) ; GET FCN
\r
7245 HRRZ C,@E.FRM+1(TB) ; GET ARG LIST
\r
7246 SUB TP,[MINTM,,MINTM] ; FLUSH UNWANTED TEMPS
\r
7248 PUSH TP,C ; ARG TO STACK
\r
7249 .MCALL 1,(A) ; AND CALL
\r
7250 POPJ P, ; AND LEAVE
\r
7255 PUSHJ P,PSH4ZR ; SET UP ZEROED SLOTS
\r
7256 SKIPN A,E.EXTR(TB) ; FUNNY ARGS
\r
7257 JRST APSUB1 ; NO, GO
\r
7258 MOVE B,E.EXTR+1(TB) ; YES , GET VAL
\r
7259 JRST APSUB2 ; AND FALL IN
\r
7261 APSUB1: PUSHJ P,@E.ARG+1(TB) ; EAT AN ARG
\r
7262 JRST APSUBD ; DONE
\r
7265 AOS E.CNT+1(TB) ; COUNT IT
\r
7268 APSUBD: MOVE A,E.CNT+1(TB) ; FINISHED, GET COUNT
\r
7269 MOVE B,E.FCN+1(TB) ; AND SUBR
\r
7273 PUSHJ P,BLTDN ; FLUSH CRUFT
\r
7277 BLTDN: MOVEI C,(TB) ; POINT TO DEST
\r
7278 HRLI C,E.TSUB(C) ; AND SOURCE
\r
7279 BLT C,-E.TSUB(TP) ;BL..............T
\r
7280 SUB TP,[E.TSUB,,E.TSUB]
\r
7283 APENDN: PUSHJ P,BLTDN
\r
7284 APNDN1: .ECALL A,(B)
\r
7287 ; FLAGS FOR RSUBR HACKER
\r
7294 ; APPLY OBJECTS OF TYPE RSUBR
\r
7298 MOVE C,E.FCN+1(TB) ; GET THE RSUBR
\r
7299 CAML C,[-5,,] ; IS IT LONG ENOUGH FOR DECLS
\r
7300 JRST APSUBR ; NO TREAT AS A SUBR
\r
7301 GETYP 0,4(C) ; GET TYPE OF 3D ELEMENT
\r
7302 CAIE 0,TDECL ; DECLARATION?
\r
7303 JRST APSUBR ; NO, TREAT AS SUBR
\r
7304 PUSHJ P,PSH4ZR ; ALLOCATE SOME EXTRA ROOM
\r
7305 PUSH TP,$TDECL ; PUSH UP THE DECLS
\r
7307 PUSH TP,$TLOSE ; SAVE ROOM FOR VAL DECL
\r
7310 SKIPN E.EXTR(TB) ; "EXTRA" ARG?
\r
7312 MOVE 0,[SETZ EXTRGT] ; CHANGE THE ACCESS FCN
\r
7313 EXCH 0,E.ARG+1(TB)
\r
7314 HRRM 0,E.ARG(TB) ; REMEMBER IT
\r
7316 APRSU1: MOVEI 0,0 ; INIT FLAG REGISTER
\r
7319 APRSU2: HRRZ A,E.DECL+1(TB) ; GET DECL LIST
\r
7320 JUMPE A,APRSU3 ; DONE!
\r
7321 HRRZ B,(A) ; CDR IT
\r
7322 MOVEM B,E.DECL+1(TB)
\r
7323 PUSHJ P,NXTDCL ; IS NEXT THING A STRING?
\r
7324 JRST APRSU4 ; NO, BETTER BE A TYPE
\r
7325 CAMN B,[ASCII /VALUE/]
\r
7326 JRST RSBVAL ; SAVE VAL DECL
\r
7327 TRON 0,F.NFST ; IF NOT FIRST, LOSE
\r
7328 CAME B,[ASCII /CALL/] ; CALL DECL
\r
7330 SKIPGE E.ARG+1(TB) ; LEGAL?
\r
7333 MOVE D,E.FRM+1(TB) ; GET FORM
\r
7334 JRST APRS10 ; HACK IT
\r
7336 APRSU5: TROE 0,F.STR ; STRING STRING?
\r
7338 CAME B,[<ASCII /OPTIO/>+1] ; OPTIONA?
\r
7340 TROE 0,F.OPT ; CHECK AND SET
\r
7341 JRST MPD ; OPTINAL OPTIONAL LOSES
\r
7342 JRST APRSU2 ; TO MAIN LOOP
\r
7344 APRSU7: CAME B,[ASCII /QUOTE/]
\r
7347 TROE 0,F.QUO ; TURN ON AND CHECK QUOTE
\r
7348 JRST MPD ; QUOTE QUOTE LOSES
\r
7349 JRST APRSU2 ; GO TO END OF LOOP
\r
7352 APRSU8: CAME B,[ASCII /ARGS/]
\r
7354 SKIPGE E.ARG+1(TB) ; SKIP IF LEGAL
\r
7356 HRRZ D,@E.FRM+1(TB) ; GET ARG LIST
\r
7359 APRS10: HRRZ A,(A) ; GET THE DECL
\r
7360 MOVEM A,E.DECL+1(TB) ; CLOBBER
\r
7361 HRRZ B,(A) ; CHECK FOR TOO MUCH
\r
7363 MOVE B,1(A) ; GET DECL
\r
7364 HLLZ A,(A) ; GOT THE DECL
\r
7365 MOVEM 0,(P) ; SAVE FLAGS
\r
7366 JSP E,CHKAB ; CHECK DEFER
\r
7371 AOS E.CNT+1(TB) ; COUNT ARG
\r
7372 JRST APRDON ; GO CALL RSUBR
\r
7374 RSBVAL: HRRZ A,E.DECL+1(TB) ; GET DECL
\r
7376 HRRZ B,(A) ; POINT TO DECL
\r
7377 MOVEM B,E.DECL+1(TB) ; SAVE NEW DECL POINTER
\r
7381 MOVEM A,E.VAL+1(TB) ; SAVE VAL DECL
\r
7383 MOVEM A,E.VAL(TB) ; SET ITS TYPE
\r
7387 APRSU9: CAME B,[ASCII /TUPLE/]
\r
7389 MOVEM 0,(P) ; SAVE FLAGS
\r
7390 HRRZ A,(A) ; CDR DECLS
\r
7391 MOVEM A,E.DECL+1(TB)
\r
7393 JUMPN B,MPD ; LOSER
\r
7394 PUSH P,[0] ; COUNT ELEMENTS IN TUPLE
\r
7396 APRTUP: PUSHJ P,@E.ARG+1(TB) ; GOBBLE ARGS
\r
7397 JRST APRTPD ; DONE
\r
7400 AOS (P) ; COUNT IT
\r
7401 JRST APRTUP ; AND GO
\r
7403 APRTPD: POP P,C ; GET COUNT
\r
7404 ADDM C,E.CNT+1(TB) ; UPDATE MAIN COUNT
\r
7405 ASH C,1 ; # OF WORDS
\r
7406 HRLI C,TINFO ; BUILD FENCE POST
\r
7408 PUSHJ P,TBTOTP ; GEN REL OFFSET TO TOP
\r
7410 HRROI D,-1(TP) ; POINT TO TOP
\r
7411 SUBI D,(C) ; TO BASE
\r
7413 MOVSI C,TARGS ; BUILD TYPE WORD
\r
7415 MOVE A,E.DECL+1(TB)
\r
7417 HLLZ A,(A) ; TYPE/VAL
\r
7418 JSP E,CHKAB ; CHECK
\r
7419 PUSHJ P,TMATCH ; GOTO TYPE CHECKER
\r
7422 SUB TP,[2,,2] ; REMOVE FENCE POST
\r
7424 APRDON: SUB P,[1,,1] ; FLUSH CRUFT
\r
7425 MOVE A,E.CNT+1(TB) ; GET # OF ARGS
\r
7426 MOVE B,E.FCN+1(TB)
\r
7427 GETYP 0,E.FCN(TB) ; COULD BE ENTRY
\r
7428 MOVEI C,(TB) ; PREPARE TO BLT DOWN
\r
7429 HRLI C,E.TSUB+2(C)
\r
7430 BLT C,-E.TSUB+2(TP)
\r
7431 SUB TP,[E.TSUB+2,,E.TSUB+2]
\r
7434 .ACALL A,(B) ; CALL THE RSUBR
\r
7439 APRSU4: MOVEM 0,(P) ; SAVE FLAGS
\r
7440 MOVE B,1(A) ; GET DECL
\r
7443 MOVE 0,(P) ; RESTORE FLAGS
\r
7445 PUSH TP,B ; AND SAVE
\r
7446 SKIPL E.ARG+1(TB) ; ALREADY EVAL'D
\r
7448 JRST APREVA ; MUST EVAL ARG
\r
7450 HRRZ C,@E.FRM+1(TB) ; GET ARG?
\r
7451 TRNE 0,F.OPT ; OPTIONAL
\r
7453 JUMPE C,TFA ; NO, TOO FEW ARGS
\r
7454 MOVEM C,E.FRM+1(TB)
\r
7455 HLLZ A,(C) ; GET ARG
\r
7457 JSP E,CHKAB ; CHECK THEM
\r
7459 APRTYC: MOVE C,A ; SET UP FOR TMATCH
\r
7462 EXCH A,-1(TP) ; SAVE STUFF
\r
7463 APRS11: PUSHJ P,TMATCH ; CHECK TYPE
\r
7466 MOVE 0,(P) ; RESTORE FLAGS
\r
7469 JRST APRSU2 ; AND GO ON
\r
7471 APREVA: PUSHJ P,@E.ARG+1(TB) ; EVAL ONE
\r
7472 TDZA C,C ; C=0 ==> NONE LEFT
\r
7474 MOVE 0,(P) ; FLAGS
\r
7475 JUMPN C,APRTYC ; GO CHECK TYPE
\r
7476 APRDN: SUB TP,[2,,2] ; FLUSH DECL
\r
7477 TRNE 0,F.OPT ; OPTIONAL?
\r
7478 JRST APRDON ; ALL DONE
\r
7481 APRSU3: TRNE 0,F.STR ; END IN STRING?
\b \r
7483 PUSHJ P,@E.ARG+1(TB) ; SEE IF ANYMORE ARGS
\r
7488 ; STANDARD ARGUMENT GETTERS USED IN APPLYING THINGS
\r
7490 ARGCDR: HRRZ C,@E.FRM+1(TB) ; POINT TO ARGLIST (NOTE: POINTS 1 BEFORE WHERE ARG IS)
\r
7491 JUMPE C,CPOPJ ; LEAVE IF DONE
\r
7492 MOVEM C,E.FRM+1(TB)
\r
7493 GETYP 0,(C) ; GET TYPE OF ARG
\r
7495 JRST ARGCD1 ; SEG MENT HACK
\r
7499 ARGCD1: PUSH TP,$TFORM ; PRETEND WE ARE A FORM
\r
7503 MOVEM B,E.SEG+1(TB)
\r
7504 PUSHJ P,TYPSEG ; GET SEG TYPE CODE
\r
7505 HRRM C,E.ARG(TB) ; SAVE IT IN OBSCCURE PLACE
\r
7506 MOVE C,[SETZ SGARG]
\r
7507 MOVEM C,E.ARG+1(TB) ; SET NEW ARG GETTER
\r
7509 ; FALL INTO SEGARG
\r
7512 HRRZ C,E.ARG(TB) ; SEG CODE TO C
\r
7513 MOVE D,E.SEG+1(TB)
\r
7516 PUSHJ P,NXTLM ; GET NEXT ELEMENT
\r
7517 JRST SEGRG1 ; DONE
\r
7518 MOVEM D,E.SEG+1(TB)
\r
7519 MOVE D,DSTO(PVP) ; KEEP TYPE WINNING
\r
7522 JRST CPOPJ1 ; RETURN
\r
7524 SEGRG1: SETZM DSTO(PVP)
\r
7526 MOVEM C,E.ARG+1(TB) ; RESET ARG GETTER
\r
7529 ; ARGUMENT GETTER FOR APPLY
\r
7532 SKIPL A,E.FRM+1(TB) ; ANY ARGS LEFT
\r
7533 POPJ P, ; NO, EXIT IMMEDIATELY
\r
7535 MOVEM A,E.FRM+1(TB)
\r
7536 MOVE B,-1(A) ; RET NEXT ARG
\r
7540 ; STACKFORM ARG GETTER
\r
7542 EVALRG: SKIPN C,@E.FRM+1(TB) ; ANY FORM?
\r
7545 GETYP A,A ; CHECK FOR FALSE
\r
7548 MOVE C,E.FRM+1(TB) ; GET OTHER FORM
\r
7553 ; HERE TOO APPLY NUMBERS
\r
7555 APNUM: PUSHJ P,PSH4ZR ; TP SLOSTS
\r
7556 SKIPN A,E.EXTR(TB) ; FUNNY ARG?
\r
7557 JRST APNUM1 ; NOPE
\r
7558 MOVE B,E.EXTR+1(TB) ; GET ARG
\r
7561 APNUM1: PUSHJ P,@E.ARG+1(TB) ; GET ARG
\r
7566 PUSH TP,E.FCN+1(TB)
\r
7567 PUSHJ P,@E.ARG+1(TB)
\r
7570 PUSHJ P,BLTDN ; FLUSH JUNK
\r
7574 ; HERE TO APPLY SUSSMAN FUNARGS
\r
7578 SKIPN C,E.FCN+1(TB)
\r
7580 HRRZ D,(C) ; MUST BE AT LEAST 2 LONG
\r
7582 GETYP 0,(D) ; CHECK FOR LIST
\r
7585 HRRZ 0,(D) ; SHOULD BE END
\r
7587 GETYP 0,(C) ; 1ST MUST BE FCN
\r
7592 PUSHJ P,APEXPF ; BIND THE ARGS AND AUX'S
\r
7593 HRRZ C,RE.FCN+1(TB) ; GET BODY OF FUNARG
\r
7594 MOVE B,1(C) ; GET FCN
\r
7595 MOVEM B,RE.FCN+1(TB) ; AND SAVE
\r
7596 HRRZ C,(C) ; CDR FUNARG BODY
\r
7598 MOVSI 0,TLIST ; SET UP TYPE
\r
7599 MOVEM 0,CSTO(PVP) ; FOR INTS TO WIN
\r
7602 JUMPE C,DOF ; RUN IT
\r
7604 CAIE 0,TLIST ; BETTER BE LIST
\r
7608 PUSHJ P,NEXTDC ; GET POSSIBILITY
\r
7609 JRST FUNERR ; LOSER
\r
7612 HRRZ B,(B) ; GET TO VALUE
\r
7617 HLLZ A,(B) ; GET VAL
\r
7619 JSP E,CHKAB ; HACK DEFER
\r
7620 PUSHJ P,PSHAB4 ; PUT VAL IN
\r
7624 ; HERE TO RUN FUNARG
\r
7626 DOF: SETZM CSTO(PVP) ; DONT CONFUSE GC
\r
7627 PUSHJ P,SPECBIND ; BIND 'EM UP
\r
7632 ; HERE TO DO MACROS
\r
7634 APMACR: HRRZ E,OTBSAV(TB)
\r
7635 HRRZ E,PCSAV(E) ; SEE WHERE FROM
\r
7636 CAIN E,AEVAL3 ; SKIP IF NOT RIGHT
\r
7638 SKIPG E.ARG+1(TB) ; SKIP IF REAL FORM EXISTS
\r
7641 MOVE B,E.FRM+1(TB)
\r
7642 SUB TP,[E.EXTR+2,,E.EXTR+2] ; FLUSH JUNK
\r
7645 MCALL 1,EXPAND ; EXPAND THE MACRO
\r
7648 MCALL 1,EVAL ; EVAL THE RESULT
\r
7651 APMAC1: MOVE C,E.FCN+1(TB) ; GET MACRO BODY
\r
7655 JSP E,CHKAB ; FIX DEFERS
\r
7657 MOVEM B,E.FCN+1(TB)
\r
7660 ; HERE TO APPLY EXPRS (FUNCTIONS)
\r
7662 APEXPR: PUSHJ P,APEXP ; BIND ARGS AND AUX'S
\r
7663 RUNFUN: HRRZ A,RE.FCN(TB) ; AMOUNT OF FCN TO SKIP
\r
7664 MOVEI C,RE.FCN+1(TB) ; POINT TO FCN
\r
7665 HRRZ C,(C) ; SKIP SOMETHING
\r
7666 SOJGE A,.-1 ; UNTIL 1ST FORM
\r
7667 MOVEM C,RE.FCN+1(TB) ; AND STORE
\r
7668 JRST DOPROG ; GO RUN PROGRAM
\r
7670 APEXP: SKIPN C,E.FCN+1(TB) ; CHECK FRO BODY
\r
7672 APEXPF: PUSH P,[0] ; COUNT INIT CRAP
\r
7673 ADD TP,[XP.TMP,,XP.TMP] ; SLOTS FOR HACKING
\r
7676 SETZM 1-XP.TMP(TP) ; ZERO OUT
\r
7677 MOVEI A,-XP.TMP+2(TP)
\r
7679 BLT A,(TP) ; ZERO SLOTS
\r
7680 PUSHJ P,CARATC ; SEE IF HEWITT ATOM EXISTS
\r
7681 JRST APEXP1 ; NO, GO LOOK FOR ARGLIST
\r
7682 MOVEM E,E.HEW+1(TB) ; SAVE ATOM
\r
7683 MOVSM 0,E.HEW(TB) ; AND TYPE
\r
7684 AOS (P) ; COUNT HEWITT ATOM
\r
7685 APEXP1: GETYP 0,(C) ; LOOK AT NEXT THING
\r
7686 CAIE 0,TLIST ; BETTER BE LIST!!!
\r
7688 MOVE B,1(C) ; GET LIST
\r
7689 MOVEM B,E.ARGL+1(TB) ; SAVE
\r
7690 MOVSM 0,E.ARGL(TB) ; WITH TYPE
\r
7691 HRRZ C,(C) ; CDR THE FCN
\r
7692 JUMPE C,NOBODY ; BODYLESS FCN
\r
7693 GETYP 0,(C) ; SEE IF DCL LIST SUPPLIED
\r
7695 JRST APEXP2 ; NO, START PROCESSING ARGS
\r
7696 AOS (P) ; COUNT DCL
\r
7698 MOVEM B,E.DECL+1(TB)
\r
7699 MOVSM 0,E.DECL(TB)
\r
7700 HRRZ C,(C) ; CDR ON
\r
7703 ; CHECK FOR EXISTANCE OF EXTRA ARG
\r
7705 APEXP2: POP P,A ; GET COUNT
\r
7706 HRRM A,E.FCN(TB) ; AND SAVE
\r
7707 SKIPN E.EXTR(TB) ; SKIP IF FUNNY EXTRA ARG EXISTS
\r
7709 MOVE 0,[SETZ EXTRGT]
\r
7710 EXCH 0,E.ARG+1(TB)
\r
7711 HRRM 0,E.ARG(TB) ; SAVE OLD GETTER AROUND
\r
7715 ; LOOK FOR "BIND" DECLARATION
\r
7717 APEXP3: PUSHJ P,UNPROG ; UNASSIGN LPROG IF NEC
\r
7718 APXP3A: SKIPN A,E.ARGL+1(TB) ; GET ARGLIST
\r
7719 JRST APEXP4 ; NONE, VERIFY NONE WERE GIVEN
\r
7720 PUSHJ P,NXTDCL ; SEE IF A DECL IS THERE
\r
7721 JRST BNDRG ; NO, GO BIND NORMAL ARGS
\r
7722 HRRZ C,(A) ; CDR THE DCLS
\r
7723 CAME B,[ASCII /BIND/]
\r
7724 JRST CH.CAL ; GO LOOK FOR "CALL"
\r
7725 PUSHJ P,CARTMC ; MUST BE AN ATOM
\r
7726 MOVEM C,E.ARGL+1(TB) ; AND SAVE CDR'D ARGS
\r
7727 PUSHJ P,MAKENV ; GENERATE AN ENVIRONMENT
\r
7728 PUSHJ P,PSBND1 ; PUSH THE BINDING AND CHECK THE DCL
\r
7729 JRST APXP3A ; IN CASE <"BIND" B "BIND" C......
\r
7732 ; LOOK FOR "CALL" DCL
\r
7734 CH.CAL: CAME B,[ASCII /CALL/]
\r
7735 JRST CHOPT ; TRY SOMETHING ELSE
\r
7736 SKIPG E.ARG+1(TB) ; DONT SKIP IF CANT WIN
\r
7738 PUSHJ P,CARTMC ; BETTER BE AN ATOM
\r
7739 MOVEM C,E.ARGL+1(TB)
\r
7740 MOVE A,E.FRM(TB) ; RETURN FORM
\r
7741 MOVE B,E.FRM+1(TB)
\r
7742 PUSHJ P,PSBND1 ; BIND AND CHECK
\r
7745 ; BIND NORMAL ARGS BY CALLING BNDEM1, RETURNS WHEN ALL DONE
\r
7747 BNDRG: PUSHJ P,BNDEM1 ; GO BIND THEM UP
\r
7748 TRNN A,4 ; SKIP IF HIT A DCL
\r
7749 JRST APEXP4 ; NOT A DCL, MUST BE DONE
\r
7751 ; LOOK FOR "OPTIONAL" DECLARATION
\r
7753 CHOPT: CAME B,[<ASCII /OPTIO/>+1]
\r
7754 JRST CHREST ; TRY TUPLE/ARGS
\r
7755 MOVEM C,E.ARGL+1(TB) ; SAVE RESTED ARGLIST
\r
7756 PUSHJ P,BNDEM2 ; DO ALL SUPPLIED OPTIONALS
\r
7757 TRNN A,4 ; SKIP IF NEW DCL READ
\r
7760 ; CHECK FOR "ARGS" DCL
\r
7762 CHREST: CAME B,[ASCII /ARGS/]
\r
7763 JRST CHRST1 ; GO LOOK FOR "TUPLE"
\r
7764 SKIPGE E.ARG+1(TB) ; SKIP IF LEGAL
\r
7766 PUSHJ P,CARTMC ; GOBBLE ATOM
\r
7767 MOVEM C,E.ARGL+1(TB) ; SAVE CDR'D ARG
\r
7768 HRRZ B,@E.FRM+1(TB) ; GET ARG LIST
\r
7769 MOVSI A,TLIST ; GET TYPE
\r
7773 ; HERE TO CHECK FOR "TUPLE"
\r
7775 CHRST1: CAME B,[ASCII /TUPLE/]
\r
7777 PUSHJ P,CARTMC ; GOBBLE ATOM
\r
7778 MOVEM C,E.ARGL+1(TB)
\r
7780 PUSHJ P,PSHBND ; SET UP BINDING
\r
7781 SETZM E.CNT+1(TB) ; ZERO ARG COUNTER
\r
7783 TUPLP: PUSHJ P,@E.ARG+1(TB) ; GET AN ARG
\r
7784 JRST TUPDON ; FINIS
\r
7790 TUPDON: PUSHJ P,MAKINF ; MAKE INFO CELL
\r
7791 PUSH TP,$TINFO ; FENCE POST TUPLE
\r
7793 ADDI D,TM.OFF ; COMPENSATE FOR MOVEMENT
\r
7795 MOVE C,E.CNT+1(TB) ; GET COUNT
\r
7796 ASH C,1 ; TO WORDS
\r
7797 HRRM C,-1(TP) ; INTO FENCE POST
\r
7798 MOVEI B,-TM.OFF-1(TP) ; SETUP ARG POINTER
\r
7799 SUBI B,(C) ; POINT TO BASE OF TUPLE
\r
7800 MOVNS C ; FOR AOBJN POINTER
\r
7801 HRLI B,(C) ; GOOD ARGS POINTER
\r
7802 MOVEM A,TM.OFF-4(B) ; STORE
\r
7803 MOVEM B,TM.OFF-3(B)
\r
7806 ; CHECK FOR VALID ENDING TO ARGS
\r
7808 APEXP5: PUSHJ P,NEXTD ; READ NEXT THING IN ARGLIST
\r
7809 JRST APEXP8 ; DONE
\r
7810 TRNN A,4 ; SKIP IF DCL
\r
7811 JRST MPD.4 ; LOSER
\r
7812 APEXP7: MOVSI A,-NWINS ; CHECK FOR A WINNER
\r
7815 JUMPE A,MPD.6 ; NOT A WINNER
\r
7817 ; HERE TO BLT THE WORLD DOWN ON TOP OF ALL THE USELESS TEMPS
\r
7819 APEXP8: MOVE 0,E.HEW+1(TB) ; GET HEWITT ATOM
\r
7820 MOVE E,E.FCN(TB) ; SAVE COUNTER
\r
7821 MOVE C,E.FCN+1(TB) ; FCN
\r
7822 MOVE B,E.ARGL+1(TB) ; ARG LIST
\r
7823 MOVE D,E.DECL+1(TB) ; AND DCLS
\r
7824 MOVEI A,R.TMP(TB) ; SET UP BLT
\r
7826 BLT A,-TM.OFF(TP) ; BLLLLLLLLLLLLLT
\r
7827 SUB TP,[TM.OFF,,TM.OFF] ; FLUSH CRUFT
\r
7828 MOVEM E,RE.FCN(TB)
\r
7829 MOVEM C,RE.FCN+1(TB)
\r
7830 MOVEM B,RE.ARGL+1(TB)
\r
7836 GETYP A,-5(TP) ; TUPLE ON TOP?
\r
7837 CAIE A,TINFO ; SKIP IF YES
\r
7839 HRRZ A,-5(TP) ; GET SIZE
\r
7842 SUB E,A ; POINT TO BINDINGS
\r
7843 SKIPE C,(TP) ; IF DCL
\r
7844 PUSHJ P,CHKDCL ; CHECK TYPE SPEC ON TUPLE
\r
7845 APEXP9: PUSHJ P,USPCBE ; DO ACTUAL BINDING
\r
7847 MOVE E,-2(TP) ; RESTORE HEWITT ATOM
\r
7848 MOVE D,(TP) ; AND DCLS
\r
7851 JRST AUXBND ; GO BIND AUX'S
\r
7853 ; HERE TO VERIFY CHECK IF ANY ARGS LEFT
\r
7855 APEXP4: PUSHJ P,@E.ARG+1(TB)
\r
7857 JRST TMA ; TOO MANY ARGS
\r
7860 PUSHJ P,@E.ARG+1(TB)
\r
7866 ; LIST OF POSSIBLE TERMINATING NAMES
\r
7869 AS.ACT: ASCII /ACT/
\r
7870 AS.NAM: ASCII /NAME/
\r
7871 AS.AUX: ASCII /AUX/
\r
7872 AS.EXT: ASCII /EXTRA/
\r
7876 ; HERE TO BIND AUX VARIABLES FOR PROGS AND FCNS
\r
7878 AUXBND: PUSH P,E ; SAVE HEWITT ATOM ( WILL PUT ON MARKED STACK
\r
7880 PUSH P,D ; SAME WITH DCL LIST
\r
7881 PUSH P,[-1] ; FLAG SAYING WE ARE FCN
\r
7882 SKIPN C,RE.ARG+1(TB) ; GET ARG LIST
\r
7884 GETYP 0,(C) ; GET TYPE
\r
7885 CAIE 0,TDEFER ; SKIP IF CHSTR
\r
7886 MOVMS (P) ; SAY WE ARE IN OPTIONALS
\r
7891 PUSH P,[0] ; WE ARE IN AUXS
\r
7893 AUXB1: HRRZ C,RE.ARG+1(TB) ; POINT TO ARGLIST
\r
7894 PUSHJ P,NEXTDC ; GET NEXT THING OFF OF ARG LIST
\r
7896 TRNE A,4 ; SKIP IF SOME KIND OF ATOM
\r
7897 JRST TRYDCL ; COUDL BE DCL
\r
7898 TRNN A,1 ; SKIP IF QUOTED
\r
7900 SKIPN (P) ; SKIP IF QUOTED OK
\r
7902 AUXB2: PUSHJ P,PSHBND ; SET UP BINDING
\r
7903 PUSH TP,$TDECL ; SAVE HEWITT ATOM
\r
7905 PUSH TP,$TATOM ; AND DECLS
\r
7908 TRNN A,2 ; SKIP IF INIT VAL EXISTS
\r
7909 JRST AUXB3 ; NO, USE UNBOUND
\r
7911 ; EVALUATE EXPRESSION
\r
7913 HRRZ C,(B) ; CDR ATOM OFF
\r
7915 ; CHECK FOR SPECIAL FORMS <TUPLE ...> <ITUPLE ...>
\r
7917 GETYP 0,(C) ; GET TYPE OF GOODIE
\r
7918 CAIE 0,TFORM ; SMELLS LIKE A FORM
\r
7920 HRRZ D,1(C) ; GET 1ST ELEMENT
\r
7921 GETYP 0,(D) ; AND ITS VAL
\r
7922 CAIE 0,TATOM ; FEELS LIKE THE RIGHT FORM
\r
7925 MOVE 0,1(D) ; GET THE ATOM
\r
7926 CAME 0,MQUOTE TUPLE
\r
7927 CAMN 0,MQUOTE ITUPLE
\r
7928 JRST DOTUPL ; SURE GLAD I DIDN'T STEP IN THAT FORM
\r
7931 AUXB13: PUSHJ P,FASTEV
\r
7933 AUXB4: MOVEM A,-7(E) ; STORE VAL IN BINDING
\r
7936 ; HERE TO CHECK AGAINST DECLARATIONS AND COMPLETE THE BINDING
\r
7938 AUXB5: SUB E,[4,,4] ; POINT TO BINDING TOP
\r
7939 SKIPE C,-2(TP) ; POINT TO DECLARATINS
\r
7940 PUSHJ P,CHKDCL ; CHECK IT
\r
7941 PUSHJ P,USPCBE ; AND BIND UP
\r
7942 SKIPE C,RE.ARG+1(TB) ; CDR DCLS
\r
7943 HRRZ C,(C) ; IF ANY TO CDR
\r
7944 MOVEM C,RE.ARG+1(TB)
\r
7945 MOVE A,(TP) ; NOW PUT HEWITT ATOM AND DCL AWAY
\r
7949 SUB TP,[4,,4] ; FLUSH SLOTS
\r
7959 ; HERE TO HANDLE "CALLS" TO TUPLE AND ITUPLE
\r
7961 DOTUPL: PUSH TP,$TLIST ; SAVE THE MAGIC FORM
\r
7963 CAME 0,MQUOTE TUPLE
\r
7964 JRST DOITUP ; DO AN ITUPLE
\r
7966 ; FALL INTO A TUPLE PUSHING LOOP
\r
7968 DOTUP1: HRRZ C,@(TP) ; CDR THE FORM
\r
7969 JUMPE C,ATUPDN ; FINISHED
\r
7970 MOVEM C,(TP) ; SAVE CDR'D RESULT
\r
7971 GETYP 0,(C) ; CHECK FOR SEGMENT
\r
7973 JRST DTPSEG ; GO PULL IT APART
\r
7974 PUSHJ P,FASTEV ; EVAL IT
\r
7975 PUSHJ P,CNTARG ; PUSH IT UP AND COUNT THEM
\r
7978 ; HERE WHEN WE FINISH
\r
7980 ATUPDN: SUB TP,[2,,2] ; FLUSH THE LIST
\r
7981 ASH E,1 ; E HAS # OF ARGS DOUBLE IT
\r
7982 MOVEI D,(TP) ; FIND BASE OF STACK AREA
\r
7984 MOVSI C,-3(D) ; PREPARE BLT POINTER
\r
7985 BLT C,C ; HEWITT ATOM AND DECL TO 0,A,B,C
\r
7987 ; NOW PREPEARE TO BLT TUPLE DOWN
\r
7989 MOVEI D,-3(D) ; NEW DEST
\r
7990 HRLI D,4(D) ; SOURCE
\r
7991 BLT D,-4(TP) ; SLURP THEM DOWN
\r
7993 HRLI E,TINFO ; SET UP FENCE POST
\r
7994 MOVEM E,-3(TP) ; AND STORE
\r
7995 PUSHJ P,TBTOTP ; GET OFFSET
\r
7996 ADDI D,3 ; FUDGE FOR NOT AT TOP OF STACK
\r
7998 MOVEM 0,-1(TP) ; RESTORE HEW ATOM AND DECLS
\r
8003 PUSHJ P,MAKINF ; MAKE 1ST WORD OF FUNNYS
\r
8005 HRRZ E,-5(TP) ; RESTORE WORDS OF TUPLE
\r
8006 HRROI B,-5(TP) ; POINT TO TOP OF TUPLE
\r
8007 SUBI B,(E) ; NOW BASE
\r
8008 TLC B,-1(E) ; FIX UP AOBJN PNTR
\r
8009 ADDI E,2 ; COPNESATE FOR FENCE PST
\r
8011 SUBM TP,E ; E POINT TO BINDING
\r
8012 JRST AUXB4 ; GO CLOBBER IT IN
\r
8015 ; HERE TO HANDLE SEGMENTS IN THESE FUNNY FORMS
\r
8017 DTPSEG: PUSH TP,$TFORM ; SAVE THE HACKER
\r
8019 MCALL 1,EVAL ; AND EVALUATE IT
\r
8020 MOVE D,B ; GET READY FOR A SEG LOOP
\r
8022 PUSHJ P,TYPSEG ; TYPE AND CHECK IT
\r
8024 DTPSG1: INTGO ; DONT BLOW YOUR STACK
\r
8025 PUSHJ P,NXTLM ; ELEMENT TO A AND B
\r
8026 JRST DTPSG2 ; DONE
\r
8027 PUSHJ P,CNTARG ; PUSH AND COUNT
\r
8030 DTPSG2: SETZM DSTO(PVP)
\r
8031 JRST DOTUP1 ; REST OF ARGS STILL TO DO
\r
8033 ; HERE TO HACK <ITUPLE .....>
\r
8035 DOITUP: HRRZ C,@(TP) ; GET COUNT FILED
\r
8038 PUSHJ P,FASTEV ; EVAL IT
\r
8045 HRRZ C,@(TP) ; GET EXP TO EVAL
\r
8046 MOVEI 0,0 ; DONT LOSE IN 1 ARG CASE
\r
8047 HRRZ 0,(C) ; VERIFY WINNAGE
\r
8048 JUMPN 0,TUPTMA ; TOO MANY
\r
8051 PUSH P,B ; SAVE COUNT
\r
8054 PUSHJ P,FASTEV ; EVAL IT ONCE
\r
8066 DOIDO1: MOVE B,-1(P) ; RESTORE COUNT
\r
8069 DOIDON: MOVEI E,(B)
\r
8072 ; FOR CASE OF NO EVALE
\r
8074 DOILOS: SUB TP,[2,,2]
\r
8082 ; ROUTINE TO PUSH NEXT TUPLE ELEMENT
\r
8084 CNTARG: AOS E,-1(TP) ; KEEP ARG COUNT UP TO DATE IN E
\r
8085 CNTRG: EXCH A,-1(TP) ; STORE ELEM AND GET SAVED
\r
8092 ; DUMMY TUPLE AND ITUPLE
\r
8094 MFUNCTION TUPLE,SUBR
\r
8098 PUSH TP,EQUOTE NOT-IN-ARG-LIST
\r
8101 MFUNCTIO ITUPLE,SUBR
\r
8105 ; PROCESS A DCL IN THE AUX VAR LISTS
\r
8107 TRYDCL: SKIPN (P) ; SKIP IF NOT IN AUX'S
\r
8109 CAME B,AS.AUX ; "AUX" ?
\r
8110 CAMN B,AS.EXT ; OR "EXTRA"
\r
8112 CAME B,[ASCII /TUPLE/]
\r
8114 PUSHJ P,MAKINF ; BUILD EMPTY TUPLE
\r
8116 PUSH TP,$TINFO ; FENCE POST
\r
8119 AUXB6: HRRZ C,(C) ; CDR PAST DCL
\r
8120 MOVEM C,RE.ARG+1(TB)
\r
8121 AUXB8: PUSHJ P,CARTMC ; GET ATOM
\r
8122 AUXB12: PUSHJ P,PSHBND ; UP GOES THE BINDING
\r
8123 PUSH TP,$TATOM ; HIDE HEWITT ATOM AND DCL
\r
8132 AUXB10: CAME B,[ASCII /ARGS/]
\r
8134 MOVEI B,0 ; NULL ARG LIST
\r
8136 JRST AUXB6 ; GO BIND
\r
8138 AUXB9: SETZM (P) ; NOW READING AUX
\r
8140 MOVEM C,RE.ARG+1(TB)
\r
8143 ; CHECK FOR NAME/ACT
\r
8145 AUXB7: CAME B,AS.NAM
\r
8148 JRST MPD.12 ; LOSER
\r
8149 HRRZ C,(C) ; CDR ON
\r
8150 HRRZ 0,(C) ; BETTER BE END
\r
8152 PUSHJ P,CARTMC ; FORCE ATOM READ
\r
8153 SETZM RE.ARG+1(TB)
\r
8154 AUXB11: PUSHJ P,MAKACT ; MAKE ACTIVATION
\r
8155 JRST AUXB12 ; AND BIND IT
\r
8158 ; DONE BIND HEWITT ATOM IF NECESARY
\r
8160 AUXDON: SKIPN E,-2(P)
\r
8165 ; FINISHED, RETURN
\r
8167 AUXD1: SUB P,[3,,3]
\r
8171 ; MAKE AN ACTIVATION OR ENVIRONMNENT
\r
8173 MAKACT: MOVEI B,(TB)
\r
8175 MAKAC1: HRRI A,PVLNT*2+1(PVP) ; POINT TO PROCESS
\r
8176 HLL B,OTBSAV(B) ; GET TIME
\r
8179 MAKENV: MOVSI A,TENV
\r
8183 ; SEVERAL USEFUL LITTLE ROUTINES FOR HACKING THIS STUFF
\r
8185 ; CARAT/CARATC/CARATM/CARTMC ALL LOOK FOR THE NEXT ATOM
\r
8187 CARAT: HRRZ C,E.ARGL+1(TB) ; PICK UP ARGLIST
\r
8188 CARATC: JUMPE C,CPOPJ ; FOUND
\r
8189 GETYP 0,(C) ; GET ITS TYPE
\r
8191 CPOPJ: POPJ P, ; RETURN, NOT ATOM
\r
8192 MOVE E,1(C) ; GET ATOM
\r
8193 HRRZ C,(C) ; CDR DCLS
\r
8196 CARATM: HRRZ C,E.ARGL+1(TB)
\r
8197 CARTMC: PUSHJ P,CARATC
\r
8198 JRST MPD.7 ; REALLY LOSE
\r
8202 ; SUBROUTINES TO PUSH BINDINGS ETC. UP ON THE STACK
\r
8204 PSBND1: PUSHJ P,PSHBND ; PUSH THEBINDING
\r
8205 JRST CHDCL ; NOW CHECK IT AGAINST DECLARATION
\r
8207 PSHBND: SKIPGE SPCCHK ; SKIP IF NORMAL SPECIAL
\r
8208 PUSH TP,BNDA1 ; ATOM IN E
\r
8209 SKIPL SPCCHK ; SKIP IF NORMAL UNSPEC OR NO CHECK
\r
8211 PUSH TP,E ; PUSH IT
\r
8218 ; ROUTINE TO PUSH 4 0'S
\r
8224 ; EXTRRA ARG GOBBLER
\r
8226 EXTRGT: HRRZ A,E.ARG(TB) ; RESET SLOT
\r
8227 CAIE A,ARGCDR ; IF NOT ARGCDR
\r
8228 TLO A,400000 ; SET FLAG
\r
8229 MOVEM A,E.ARG+1(TB)
\r
8230 MOVE A,E.EXTR(TB) ; RET ARG
\r
8231 MOVE B,E.EXTR+1(TB)
\r
8234 ; CHECK A/B FOR DEFER
\r
8237 CAIE 0,TDEFER ; SKIP IF DEFER
\r
8240 MOVE B,1(B) ; GET REAL THING
\r
8242 ; IF DECLARATIONS EXIST, DO THEM
\r
8245 CHDCLE: SKIPN C,E.DECL+1(TB)
\r
8249 ; ROUTINE TO READ NEXT THING FROM ARGLIST
\r
8251 NEXTD: HRRZ C,E.ARGL+1(TB) ; GET ARG LIST
\r
8252 NEXTDC: JUMPE C,CPOPJ
\r
8253 PUSHJ P,CARATC ; TRY FOR AN ATOM
\r
8255 MOVEI A,0 ; SET FLAG
\r
8258 NEXTD1: CAIE 0,TFORM ; FORM?
\r
8259 JRST NXT.L ; COULD BE LIST
\r
8260 PUSHJ P,CHQT ; VERIFY 'ATOM
\r
8264 NXT.L: CAIE 0,TLIST ; COULD BE (A <EXPRESS>) OR ('A <EXPRESS>)
\r
8265 JRST NXT.S ; BETTER BE A DCL
\r
8266 PUSHJ P,LNT.2 ; VERIFY LENGTH IS 2
\r
8268 CAIE 0,TATOM ; TYPE OF 1ST RET IN 0
\r
8269 JRST LST.QT ; MAY BE 'ATOM
\r
8270 MOVE E,1(B) ; GET ATOM
\r
8273 LST.QT: CAIE 0,TFORM ; FORM?
\r
8276 MOVEI C,(B) ; VERIFY 'ATOM
\r
8278 MOVEI B,(C) ; POINT BACK TO LIST
\r
8283 NXT.S: MOVEI A,(C) ; LET NXTDCL FIND OUT
\r
8285 JRST MPD.3 ; LOSER
\r
8286 MOVEI A,4 ; SET DCL READ FLAG
\r
8289 ; ROUTINE TO CHECK LENGTH OF LIST/FORM FOR BEING 2
\r
8291 LNT.2: HRRZ B,1(C) ; GET LIST/FORM
\r
8295 HRRZ B,(B) ; BETTER END HERE
\r
8297 HRRZ B,1(C) ; LIST BACK
\r
8298 GETYP 0,(B) ; TYPE OF 1ST ELEMENT
\r
8301 ; ROUTINE TO VERIFY FORM IS 'ATOM AND RET ATOM
\r
8303 CHQT: PUSHJ P,LNT.2 ; 1ST LENGTH CHECK
\r
8308 CAME 0,MQUOTE QUOTE
\r
8309 JRST MPD.5 ; BETTER BE QUOTE
\r
8311 GETYP 0,(E) ; TYPE
\r
8314 MOVE E,1(E) ; GET QUOTED ATOM
\r
8317 ; ARG BINDER FOR REGULAR ARGS AND OPTIONALS
\r
8319 BNDEM1: PUSH P,[0] ; REGULAR FLAG
\r
8321 BNDEM2: PUSH P,[1]
\r
8322 BNDEM: PUSHJ P,NEXTD ; GET NEXT THING
\r
8323 JRST CCPOPJ ; END OF THINGS
\r
8324 TRNE A,4 ; CHECK FOR DCL
\r
8326 TRNE A,2 ; SKIP IF NOT (ATM ..) OR ('ATM ...)
\r
8327 SKIPE (P) ; SKIP IF REG ARGS
\r
8328 JRST .+2 ; WINNER, GO ON
\r
8329 JRST MPD.6 ; LOSER
\r
8331 PUSH TP,BNDA1 ; SAVE ATOM
\r
8335 SKIPL E.ARG+1(TB) ; SKIP IF MUST EVAL ARG
\r
8336 TRNN A,1 ; SKIP IF ARG QUOTED
\r
8338 HRRZ D,@E.FRM+1(TB) ; GET AND CDR ARG
\r
8339 JUMPE D,TFACHK ; OH OH MAYBE TOO FEW ARGS
\r
8340 MOVEM D,E.FRM+1(TB) ; STORE WINNER
\r
8341 HLLZ A,(D) ; GET ARG
\r
8343 JSP E,CHKAB ; HACK DEFER
\r
8344 JRST BNDEM3 ; AND GO ON
\r
8346 RGLARG: PUSH P,A ; SAVE FLAGS
\r
8347 PUSHJ P,@E.ARG+1(TB)
\r
8348 JRST TFACH1 ; MAY GE TOO FEW
\r
8350 BNDEM3: HRRZ C,@E.ARGL+1(TB) ; CDR THHE ARGS
\r
8351 MOVEM C,E.ARGL+1(TB)
\r
8352 PUSHJ P,PSHAB4 ; PUSH VALUE AND SLOTS
\r
8353 PUSHJ P,CHDCL ; CHECK DCLS
\r
8354 JRST BNDEM ; AND BIND ON!
\r
8356 ; HERE WHEN ARGS RUN OUT, IF NOT OPTIONAL, GIVE TFA
\r
8359 TFACHK: SUB TP,[2,,2] ; FLUSH ATOM
\r
8360 SKIPN (P) ; SKIP IF OPTIONALS
\r
8362 CCPOPJ: SUB P,[1,,1]
\r
8365 BNDEM4: HRRZ C,@E.ARGL+1(TB) ; POINT TO REST OF ARGL
\r
8369 ; EVALUATE LISTS, VECTORS, UNIFROM VECTORS
\r
8371 EVLIST: PUSH P,[-1] ;-1 -- THIS IS A LIST
\r
8372 JRST EVL1 ;GO TO HACKER
\r
8374 EVECT: PUSH P,[0] ;0 -- THIS IS A GENERAL VECTOR
\r
8377 EUVEC: PUSH P,[1] ;1 -- THIS IS A UNIFORM VECTOR
\r
8379 EVL1: PUSH P,[0] ;PUSH A COUNTER
\r
8380 GETYPF A,(AB) ;GET FULL TYPE
\r
8382 PUSH TP,1(AB) ;AND VALUE
\r
8384 EVL2: INTGO ;CHECK INTERRUPTS
\r
8385 SKIPN A,1(TB) ;ANYMORE
\r
8386 JRST EVL3 ;NO, QUIT
\r
8387 SKIPL -1(P) ;SKIP IF LIST
\r
8388 JUMPG A,EVL3 ;JUMP IF VECTOR EMPTY
\r
8389 GETYPF B,(A) ;GET FULL TYPE
\r
8390 SKIPGE C,-1(P) ;SKIP IF NOT LIST
\r
8391 HLLZS B ;CLOBBER CDR FIELD
\r
8392 JUMPG C,EVL7 ;HACK UNIFORM VECS
\r
8393 EVL8: PUSH P,B ;SAVE TYPE WORD ON P
\r
8394 CAMN B,$TSEG ;SEGMENT?
\r
8395 MOVSI B,TFORM ;FAKE OUT EVAL
\r
8396 PUSH TP,B ;PUSH TYPE
\r
8397 PUSH TP,1(A) ;AND VALUE
\r
8398 JSP E,CHKARG ; CHECK DEFER
\r
8399 MCALL 1,EVAL ;AND EVAL IT
\r
8400 POP P,C ;AND RESTORE REAL TYPE
\r
8401 CAMN C,$TSEG ;SEGMENT?
\r
8402 JRST DOSEG ;YES, HACK IT
\r
8403 AOS (P) ;COUNT ELEMENT
\r
8404 PUSH TP,A ;AND PUSH IT
\r
8406 EVL6: SKIPGE A,-1(P) ;DONT SKIP IF LIST
\r
8407 HRRZ B,@1(TB) ;CDR IT
\r
8408 JUMPL A,ASTOTB ;AND STORE IT
\r
8409 MOVE B,1(TB) ;GET VECTOR POINTER
\r
8410 ADD B,AMNT(A) ;INCR BY APPROPRIATE AMOUNT
\r
8411 ASTOTB: MOVEM B,1(TB) ;AND STORE BACK
\r
8412 JRST EVL2 ;AND LOOP BACK
\r
8414 AMNT: 2,,2 ;INCR FOR GENERAL VECTOR
\r
8415 1,,1 ;SAME FOR UNIFORM VECTOR
\r
8417 CHKARG: GETYP A,-1(TP)
\r
8420 HRRZS (TP) ;MAKE SURE INDIRECT WINS
\r
8422 MOVEM A,-1(TP) ;CLOBBER IN TYPE SLOT
\r
8423 MOVE A,(TP) ;NOW GET POINTER
\r
8424 MOVE A,1(A) ;GET VALUE
\r
8425 MOVEM A,(TP) ;CLOBBER IN
\r
8430 EVL7: HLRE C,A ; FIND TYPE OF UVECTOR
\r
8431 SUBM A,C ;C POINTS TO DOPE WORD
\r
8432 GETYP B,(C) ;GET TYPE
\r
8433 MOVSI B,(B) ;TO LH NOW
\r
8434 SOJA A,EVL8 ;AND RETURN TO DO EVAL
\r
8436 EVL3: SKIPL -1(P) ;SKIP IF LIST
\r
8437 JRST EVL4 ;EITHER VECTOR OR UVECTOR
\r
8439 MOVEI B,0 ;GET A NIL
\r
8440 EVL9: MOVSI A,TLIST ;MAKE TYPE WIN
\r
8441 EVL5: SOSGE (P) ;COUNT DOWN
\r
8442 JRST EVL10 ;DONE, RETURN
\r
8443 PUSH TP,$TLIST ;SET TO CALL CONS
\r
8446 JRST EVL5 ;LOOP TIL DONE
\r
8449 EVL4: MOVEI B,EUVECT ;UNIFORM CASE
\r
8450 SKIPG -1(P) ;SKIP IF UNIFORM CASE
\r
8451 MOVEI B,EVECTO ;NO, GENERAL CASE
\r
8452 POP P,A ;GET COUNT
\r
8453 .ACALL A,(B) ;CALL CREATOR
\r
8454 EVL10: GETYPF A,(AB) ; USE SENT TYPE
\r
8458 ; PROCESS SEGMENTS FOR THESE HACKS
\r
8460 DOSEG: PUSHJ P,TYPSEG ; FIND WHAT IS BEING SEGMENTED
\r
8461 JUMPE C,LSTSEG ; CHECK END SPLICE IF LIST
\r
8463 SEG3: PUSHJ P,NXTELM ; GET THE NEXTE ELEMT
\r
8464 JRST SEG4 ; RETURN TO CALLER
\r
8466 JRST SEG3 ; TRY AGAIN
\r
8467 SEG4: SETZM DSTO(PVP)
\r
8470 TYPSEG: PUSHJ P,TYPSGR
\r
8474 TYPSGR: MOVEM A,DSTO(PVP) ;WILL BECOME INTERRUPTABLE WITH GOODIE IN D
\r
8475 GETYP A,A ; TYPE TO RH
\r
8476 PUSHJ P,SAT ;GET STORAGE TYPE
\r
8477 MOVE D,B ; GOODIE TO D
\r
8479 MOVNI C,1 ; C <0 IF ILLEGAL
\r
8480 CAIN A,S2WORD ;LIST?
\r
8482 CAIN A,S2NWORD ;GENERAL VECTOR?
\r
8484 CAIN A,SNWORD ;UNIFORM VECTOR?
\r
8488 CAIN A,SSTORE ;SPECIAL AFREE STORAGE ?
\r
8489 MOVEI C,2 ;TREAT LIKE A UVECTOR
\r
8490 CAIN A,SARGS ;ARGS TUPLE?
\r
8491 JRST SEGARG ;NO, ERROR
\r
8492 CAILE A,NUMSAT ; SKIP IF NOT TEMPLATE
\r
8495 SETZM DSTO(PVP) ; DON'T CONFUSE AGC LATER!
\r
8499 HRRM A,DSTO(PVP) ; SAVE FOR HACKERS
\r
8502 SEGARG: PUSH TP,DSTO(PVP) ;PREPARE TO CHECK ARGS
\r
8504 SETZM DSTO(PVP) ;TYPE NOT SPECIAL
\r
8505 MOVEI B,-1(TP) ;POINT TO SAVED COPY
\r
8506 PUSHJ P,CHARGS ;CHECK ARG POINTER
\r
8507 POP TP,D ;AND RESTORE WINNER
\r
8508 POP TP,DSTO(PVP) ;AND TYPE AND FALL INTO VECTOR CODE
\r
8512 LSTSEG: SKIPL -1(P) ;SKIP IF IN A LIST
\r
8513 JRST SEG3 ;ELSE JOIN COMMON CODE
\r
8514 HRRZ A,@1(TB) ;CHECK FOR END OF LIST
\r
8515 JUMPN A,SEG3 ;NO, JOIN COMMON CODE
\r
8516 SETZM DSTO(PVP) ;CLOBBER SAVED GOODIES
\r
8517 JRST EVL9 ;AND FINISH UP
\r
8520 PUSHJ P,NXTLM ; GOODIE TO A AND B
\r
8525 NXTLM: XCT TESTR(C) ; SKIP IF MORE IN SEGEMNT
\r
8527 XCT TYPG(C) ; GET THE TYPE
\r
8528 XCT VALG(C) ; AND VALUE
\r
8529 JSP E,CHKAB ; CHECK DEFERRED
\r
8530 XCT INCR1(C) ; AND INCREMENT TO NEXT
\r
8531 CPOPJ1: AOS (P) ; SKIP RETURN
\r
8534 ; TABLES FOR SEGMENT OPERATIONS (0->LIST, 1->VECTOR/ARGS, 2->UVEC, 3->STRING)
\r
8542 TYPG: PUSHJ P,LISTYP
\r
8560 TM1: HRRZ A,DSTO(PVP) ; GET SAT
\r
8562 ADD A,TD.LNT+1(TVP)
\r
8565 HLRZ 0,C ; GET AMNT RESTED
\r
8573 TM2: HRRZ 0,DSTO(PVP)
\r
8578 MOVEI C,0 ; GET "1ST ELEMENT"
\r
8579 PUSHJ P,TMPLNT ; GET NTH IN A AND B
\r
8586 CHRDON: HRRZ B,DSTO(PVP) ; POIT TO DOPE WORD
\r
8591 LISTYP: GETYP A,(D)
\r
8598 1CHINC: SOS DSTO(PVP)
\r
8609 ;COMPILER's CALL TO DOSEG
\r
8610 SEGMNT: PUSHJ P,TYPSEG
\r
8612 SEGLOP: PUSHJ P,NXTELM
\r
8614 AOS (P)-2 ; INCREMENT COMPILER'S COUNT
\r
8617 SEGRET: SETZM DSTO(PVP)
\r
8620 SEGLST: PUSHJ P,TYPSEG
\r
8622 SEGLS3: SETZM DSTO(PVP)
\r
8624 SEGLS1: SOSGE -2(P) ; START COUNT DOWN
\r
8632 SEGLS2: PUSHJ P,NXTELM
\r
8641 ;SPECBIND BINDS IDENTIFIERS. IT IS CALLED BY PUSHJ P,SPECBIND.
\r
8642 ;SPECBIND IS PROVIDED WITH A CONTIGUOUS SET OF TRIPLETS ON TP.
\r
8643 ;EACH TRIPLET IS AS FOLLOWS:
\r
8644 ;THE FIRST ELEMENT IS THE IDENTIFIER TO BE BOUND, ITS TYPE WORD IS [TATOM,,-1],
\r
8645 ;THE SECOND IS THE VALUE TO WHICH IT IS TO BE ASSIGNED,
\r
8646 ;AND THE THIRD IS A PAIR OF ZEROES.
\r
8654 USPCBE: PUSH P,$TUBIND
\r
8658 MOVE E,TP ;GET THE POINTER TO TOP
\r
8659 SPECBE: PUSH P,$TBIND
\r
8660 ADD E,[1,,1] ;BUMP POINTER ONCE
\r
8661 SETZB 0,D ;CLEAR TEMPS
\r
8663 MOVEI 0,(TB) ; FOR CHECKS
\r
8665 BINDLP: MOVE A,-4(E) ; CHECK FOR VEC BIND
\r
8668 MOVE A,-6(E) ;GET TYPE
\r
8669 CAME A,BNDA1 ; FOR UNSPECIAL
\r
8670 CAMN A,BNDA ;NORMAL ID BIND?
\r
8671 CAILE 0,-6(E) ; MAKE SURE NOT GOING UNDER FRAME
\r
8673 SUB E,[6,,6] ;MOVE PTR
\r
8675 HRRM E,(D) ;YES -- LOBBER
\r
8676 SKIPN (P) ;UPDATED?
\r
8677 MOVEM E,(P) ;NO -- DO IT
\r
8679 MOVE A,0(E) ;GET ATOM PTR
\r
8681 PUSHJ P,ILOC ;GET LAST BINDING
\r
8682 MOVS A,OTBSAV (TB) ;GET TIME
\r
8683 HRL A,5(E) ; GET DECL POINTER
\r
8684 MOVEM A,4(E) ;CLOBBER IT AWAY
\r
8685 MOVE A,(E) ; SEE IF SPEC/UNSPEC
\r
8686 TRNN A,1 ; SKIP, ALWAYS SPEC
\r
8687 SKIPA A,-1(P) ; USE SUPPLIED
\r
8689 MOVEM A,(E) ;IDENTIFY AS BIND BLOCK
\r
8690 HRRZ C,SPBASE(PVP) ; CHECK FOR CROSS OF PROC
\r
8692 CAIL A,(B) ; LOSER
\r
8693 CAILE C,(B) ; SKIP IFF WINNER
\r
8695 MOVEM B,5(E) ;IN RESTORE CELLS
\r
8697 MOVE C,1(E) ;GET ATOM PTR
\r
8699 MOVEI B,0 ; FOR SPCUNP
\r
8700 CAIL A,HIBOT ; SKIP IF IMPURE ATOM
\r
8702 HRRZ A,BINDID+1(PVP) ;GET PROCESS NUMBER
\r
8703 HRLI A,TLOCI ;MAKE LOC PTR
\r
8704 MOVE B,E ;TO NEW VALUE
\r
8706 MOVEM A,(C) ;CLOBBER ITS VALUE
\r
8707 MOVEM B,1(C) ;CELL
\r
8708 MOVE D,E ;REMEMBER LINK
\r
8709 JRST BINDLP ;DO NEXT
\r
8711 NONID: CAILE 0,-4(E)
\r
8719 MOVE D,1(E) ;GET PTR TO VECTOR
\r
8720 MOVE C,(D) ;EXCHANGE TYPES
\r
8724 MOVE C,1(D) ;EXCHANGE DATUMS
\r
8729 HRLM A,(E) ;IDENTIFY BIND BLOCK
\r
8730 MOVE D,E ;REMEMBER LINK
\r
8741 ; HERE TO IMPURIFY THE ATOM
\r
8743 SPCUNP: PUSH TP,$TSP
\r
8746 PUSH TP,-1(P) ; LINK BACK IS AN SP
\r
8751 MOVE 0,-2(TP) ; RESTORE LINK BACK POINTER
\r
8760 ; ENTRY FROM COMPILER TO SET UP A BINDING
\r
8762 IBIND: SUBI E,-5(SP) ; CHANGE TO PDL POINTER
\r
8773 JRST SPECB1 ; NOW BIND IT
\r
8775 ; "FAST CALL TO SPECBIND"
\r
8779 ; Compiler's call to SPECBIND all atom bindings, no TBVLs etc.
\r
8782 MOVE E,TP ; POINT TO BINDING WITH E
\r
8783 SPECB1: PUSH P,[0] ; SLOTS OF INTEREST
\r
8787 SPECB2: MOVEI 0,(TB) ; FOR FRAME CHECK
\r
8788 MOVE A,-5(E) ; LOOK AT FIRST THING
\r
8789 CAMN A,BNDA ; SKIP IF LOSER
\r
8790 CAILE 0,-5(E) ; SKIP IF REAL WINNER
\r
8793 SUB E,[5,,5] ; POINT TO BINDING
\r
8794 SKIPE A,(P) ; LINK?
\r
8795 HRRM E,(A) ; YES DO IT
\r
8796 SKIPN -1(P) ; FIRST ONE?
\r
8797 MOVEM E,-1(P) ; THIS IS IT
\r
8799 MOVE A,1(E) ; POINT TO ATOM
\r
8800 MOVE 0,BINDID+1(PVP) ; QUICK CHECK
\r
8802 CAMN 0,(A) ; WINNERE?
\r
8803 JRST SPECB4 ; YES, GO ON
\r
8805 PUSH P,B ; SAVE REST OF ACS
\r
8808 MOVE B,A ; FOR ILOC TO WORK
\r
8809 PUSHJ P,ILOC ; GO LOOK IT UP
\r
8810 HRRZ C,SPBASE+1(PVP)
\r
8812 CAIL A,(B) ; SKIP IF LOSER
\r
8813 CAILE C,(B) ; SKIP IF WINNER
\r
8814 MOVEI B,0 ; SAY NO BACK POINTER
\r
8815 MOVE C,1(E) ; POINT TO ATOM
\r
8816 MOVEI A,(C) ; PURE ATOM?
\r
8817 CAIGE A,HIBOT ; SKIP IF OK
\r
8819 PUSH P,-4(P) ; MAKE HAPPINESS
\r
8820 PUSHJ P,SPCUNP ; IMPURIFY
\r
8822 MOVE A,BINDID+1(PVP)
\r
8824 MOVEM A,(C) ; STOR POINTER INDICATOR
\r
8831 SPECB4: MOVE A,1(A) ; GET LOCATIVE
\r
8832 SPECB5: EXCH A,5(E) ; CLOBBER INTO REBIND SLOT (GET DECL)
\r
8833 HLL A,OTBSAV(TB) ; TIME IT
\r
8834 MOVSM A,4(E) ; SAVE DECL AND TIME
\r
8836 HRLM A,(E) ; CHANGE TO A BINDING
\r
8837 MOVE A,1(E) ; POINT TO ATOM
\r
8838 MOVEM E,(P) ; REMEMBER THIS GUY
\r
8839 ADD E,[2,,2] ; POINT TO VAL CELL
\r
8840 MOVEM E,1(A) ; INTO ATOM SLOT
\r
8841 SUB E,[3,,3] ; POINT TO NEXT ONE
\r
8844 SPECB3: SKIPE A,(P)
\r
8845 HRRM SP,(A) ; LINK OLD STUFF
\r
8846 SKIPE A,-1(P) ; NEW SP?
\r
8849 INTGO ; IN CASE BLEW STACK
\r
8854 ;SPECSTORE RESTORES THE BINDINGS SP TO THE ENVIRONMENT POINTER IN
\r
8855 ;SPSAV (TB). IT IS CALLED BY PUSHJ P,SPECSTORE.
\r
8859 HRRZ E,SPSAV (TB) ;GET TARGET POINTER
\r
8862 MOVE SP,SPSAV(TB) ; GET NEW SP
\r
8868 STLOO1: CAIL E,(SP) ;ARE WE DONE?
\r
8870 HLRZ C,(SP) ;GET TYPE OF BIND
\r
8873 CAIE C,TBIND ;NORMAL IDENTIFIER?
\r
8874 JRST ISTORE ;NO -- SPECIAL HACK
\r
8877 MOVE C,1(SP) ;GET TOP ATOM
\r
8878 MOVSI 0,TLOCI ; MAYBE LOCI OR UNBOUND
\r
8882 HRR 0,BINDID+1(PVP) ;STORE SIGNATURE
\r
8883 MOVEM 0,(C) ;CLOBBER INTO ATOM
\r
8886 SPLP: HRRZ SP,(SP) ;FOLOW LINK
\r
8887 JUMPN SP,STLOO1 ;IF MORE
\r
8888 SKIPE E ; OK IF E=0
\r
8894 ISTORE: CAIE C,TBVL
\r
8903 CHSKIP: CAIN C,TSKIP
\r
8905 CAIE C,TUNWIN ; UNWIND HACK
\r
8907 HRRZ C,-2(P) ; WHERE FROM?
\r
8909 JRST SPLP ; IGNORE
\r
8910 MOVEI E,(TP) ; FIXUP SP
\r
8920 ; ENTRY FOR FUNNY COMPILER UNBIND (1)
\r
8925 SSPEC2: SUBI E,(SP) ; MAKE SP BE AOBJN
\r
8932 ; ENTRY FOR FUNNY COMPILER UNBIND (2)
\r
8935 SUBI E,1 ; MAKE SURE GET CURRENT BINDING
\r
8936 PUSHJ P,STLOOP ; UNBIND
\r
8937 MOVEI E,(TP) ; NOW RESET SP
\r
8939 \fEFINIS: SKIPN C,1STEPR+1(PVP) ; SKIP NIF BEING ONE PROCEEDED
\r
8942 PUSH TP,MQUOTE EVLOUT
\r
8943 PUSH TP,A ;SAVE EVAL RESULTS
\r
8945 PUSH TP,[TINFO,,2] ; FENCE POST
\r
8948 PUSHJ P,MAKINF ; MAKE ARG BLOCK INFO
\r
8951 HRLI B,-4 ; AOBJN TO ARGS BLOCK
\r
8953 PUSH TP,1STEPR(PVP)
\r
8954 PUSH TP,1STEPR+1(PVP) ; PROCESS DOING THE 1STEPPING
\r
8956 MOVE A,-3(TP) ; GET BACK EVAL VALUE
\r
8960 1STEPI: PUSH TP,$TATOM
\r
8961 PUSH TP,MQUOTE EVLIN
\r
8962 PUSH TP,$TAB ; PUSH EVALS ARGGS
\r
8964 PUSHJ P,MAKINF ; TURN INTO ARGS BLOCK
\r
8965 MOVEM A,-1(TP) ; AND CLOBBER
\r
8966 PUSH TP,[TINFO,,2] ; FENCE POST 2D TUPLE
\r
8969 PUSHJ P,MAKINF ; TURN IT INTO ARGS BLOCK
\r
8971 MOVEI B,-6(TP) ; SETUP TUPLE
\r
8974 PUSH TP,1STEPR(PVP)
\r
8975 PUSH TP,1STEPR+1(PVP)
\r
8976 MCALL 2,RESUME ; START UP 1STEPERR
\r
8977 SUB TP,[6,,6] ; REMOVE CRUD
\r
8978 GETYP A,A ; GET 1STEPPERS TYPE
\r
8979 CAIE A,TDISMI ; IF DISMISS, STOP 1 STEPPING
\r
8982 ; HERE TO PUSH DOWN THE 1 STEP STATE AND RUN
\r
8985 ADD D,[1STEPR,,1STEPR] ; POINT TO 1 STEP SLOT
\r
8986 PUSH TP,$TSP ; SAVE CURRENT SP
\r
8989 PUSH TP,D ; BIND IT
\r
8991 PUSH TP,[0] ; NO 1 STEPPER UNTIL POPJ
\r
8994 ; NOW PUSH THE ARGS UP TO RE-CALL EVAL
\r
8997 EFARGL: JUMPGE AB,EFCALL
\r
9003 EFCALL: ACALL A,EVAL ; NOW DO THE EVAL
\r
9004 MOVE C,(TP) ; PRE-UNBIND
\r
9005 MOVEM C,1STEPR+1(PVP)
\r
9006 MOVE SP,-4(TP) ; AVOID THE UNBIND
\r
9007 SUB TP,[6,,6] ; AND FLUSH LOSERS
\r
9008 JRST EFINIS ; AND TRY TO FINISH UP
\r
9010 MAKINF: HLRZ A,OTBSAV(TB) ; TIME IT
\r
9015 TBTOTP: MOVEI D,(TB) ; COMPUTE REL DIST FROM TP TO TB
\r
9018 ; ARRIVE HERE TO COMPLETE A COMPILER GENERATED TUPLE
\r
9019 ; D/ LENGTH OF THE TUPLE IN WORDS
\r
9021 MAKTU2: MOVE D,-1(P) ; GET LENGTH
\r
9022 MAKTUP: HRLI D,TINFO ; FIRST WORD OF FENCE POST
\r
9024 HRROI B,(TP) ; TOP OF TUPLE
\r
9026 TLC B,-1(D) ; AOBJN IT
\r
9029 HLRZ A,OTBSAV(TB) ; TIME IT
\r
9033 ; HERE TO ALLOCATE SLOTS FOR COMPILER (AMNT IN A)
\r
9035 TPALOC: HRLI A,(A)
\r
9038 PUSHJ P,TPOVFL ; IN CASE IT LOST
\r
9039 INTGO ; TAKE THE GC IF NEC
\r
9049 NTPALO: PUSH TP,[0]
\r
9053 \f;EVALUATES A IDENTIFIER -- GETS LOCAL VALUE IF THERE IS ONE, OTHERWISE GLOBAL.
\r
9055 MFUNCTION VALUE,SUBR
\r
9060 IDVAL: PUSHJ P,IDVAL1
\r
9066 PUSH TP,B ;SAVE ARG IN CASE NEED TO CHECK GLOBAL VALUE
\r
9067 PUSHJ P,ILVAL ;LOCAL VALUE FINDER
\r
9068 CAME A,$TUNBOUND ;IF NOT UNBOUND OR UNASSIGNED
\r
9069 JRST RIDVAL ;DONE - CLEAN UP AND RETURN
\r
9070 POP TP,B ;GET ARG BACK
\r
9073 RIDVAL: SUB TP,[2,,2]
\r
9076 ;GETS THE LOCAL VALUE OF AN IDENTIFIER
\r
9078 MFUNCTION LVAL,SUBR
\r
9086 ; MAKE AN ATOM UNASSIGNED
\r
9088 MFUNCTION UNASSIGN,SUBR
\r
9089 JSP E,CHKAT ; GET ATOM ARG
\r
9091 UNASIT: CAMN A,$TUNBOU ; IF UNBOUND
\r
9095 SETOM 1(B) ; MAKE SURE
\r
9096 RETATM: MOVE B,1(AB)
\r
9100 ; UNASSIGN GLOBALLY
\r
9102 MFUNCTION GUNASSIGN,SUBR
\r
9107 MOVE B,1(AB) ; ATOM BACK
\r
9109 CAIL 0,HIBOT ; SKIP IF IMPURE
\r
9110 PUSHJ P,IMPURIFY ; YES, MAKE IT IMPURE
\r
9111 PUSHJ P,IGLOC ; RESTORE LOCATIVE
\r
9112 HRRZ 0,-2(B) ; SEE IF MANIFEST
\r
9113 GETYP A,(B) ; AND CURRENT TYPE
\r
9122 ; GETS A LOCATIVE TO THE LOCAL VALUE OF AN IDENTIFIER.
\r
9124 MFUNCTION LLOC,SUBR
\r
9133 ;TESTS TO SEE IF AN IDENTIFIER IS LOCALLY BOUND
\r
9135 MFUNCTION BOUND,SUBR,[BOUND?]
\r
9142 ;TESTS TO SEE IF AN IDENTIFIER IS LOCALLY ASSIGNED
\r
9144 MFUNCTION ASSIGP,SUBR,[ASSIGNED?]
\r
9152 ;GETS THE GLOBAL VALUE OF AN IDENTIFIER
\r
9154 MFUNCTION GVAL,SUBR
\r
9161 ;GETS A LOCATIVE TO THE GLOBAL VALUE OF AN IDENTIFIER
\r
9163 MFUNCTION GLOC,SUBR
\r
9179 MOVE C,1(AB) ; GE ATOM
\r
9181 CAIGE 0,HIBOT ; SKIP IF PURE ATOM
\r
9184 ; MAKE ATOM AND VALUE IMPURE IF GETTING GLOC TO IT
\r
9186 MOVE B,C ; ATOM TO B
\r
9188 JRST GLOC ; AND TRY AGAIN
\r
9190 ;TESTS TO SEE IF AN IDENTIFIER IS GLOBALLY ASSIGNED
\r
9192 MFUNCTION GASSIG,SUBR,[GASSIGNED?]
\r
9199 ; TEST FOR GLOBALLY BOUND
\r
9201 MFUNCTION GBOUND,SUBR,[GBOUND?]
\r
9211 CHKAT1: GETYP A,(AB)
\r
9218 CHKAT: HLRE A,AB ; - # OF ARGS
\r
9219 ASH A,-1 ; TO ACTUAL WORDS
\r
9221 MOVE C,SP ; FOR BINDING LOOKUPS
\r
9222 AOJE A,CHKAT1 ; ONLY ONE ARG, NO ENVIRONMENT
\r
9223 AOJL A,TMA ; TOO MANY
\r
9224 GETYP A,2(AB) ; MAKE SURE OF TENV OR TFRAME
\r
9228 CAIN A,TACT ; FOR PFISTERS LOSSAGE
\r
9230 CAIE A,TPVP ; OR PROCESS
\r
9232 MOVE B,3(AB) ; GET PROCESS
\r
9233 MOVE C,SP ; IN CASE ITS ME
\r
9234 CAME B,PVP ; SKIP IF DIFFERENT
\r
9235 MOVE C,SPSTO+1(B) ; GET ITS SP
\r
9237 CHKAT3: MOVEI B,2(AB) ; POINT TO FRAME POINTER
\r
9238 PUSHJ P,CHFRM ; VALIDITY CHECK
\r
9239 MOVE B,3(AB) ; GET TB FROM FRAME
\r
9240 MOVE C,SPSAV(B) ; GET ENVIRONMENT POINTER
\r
9245 ;ILOC RETURNS IN A AND B A LOCATIVE TO THE LOCAL VALUE OF THE IDENTIFIER PASSED TO IT
\r
9246 ;IN A AND B. IF THE IDENTIFIER IS LOCALLY UNBOUND IT RETURNS $TUNBOUND IN A AND 0 IN B,
\r
9247 ; IT IS CALLED BY PUSHJ P,ILOC.
\r
9249 ILOC: MOVE C,SP ; SETUP SEARCH START
\r
9250 AILOC: MOVSI A,TLOCI ;MAKE A LOCATIVE TYPE CELL
\r
9253 MOVEI E,0 ; FLAG TO CLOBBER ATOM
\r
9254 JUMPE B,SCHSP ; IF LOOKING FOR SLOT, SEARCH NOW
\r
9255 CAME C,SP ; ENVIRONMENT CHANGE?
\r
9256 JRST SCHSP ; YES, MUST SEARCH
\r
9257 HRR A,BINDID+1(PVP) ;FOR THE CURRENT PROCESS
\r
9258 CAME A,(B) ;IS THERE ONE IN THE VALUE CELL?
\r
9259 JRST SCHLP ;NO -- SEARCH THE LOCAL BINDINGS
\r
9260 MOVE B,1(B) ;YES -- GET LOCATIVE POINTER
\r
9262 ILCPJ: MOVE E,SPCCHK
\r
9263 TRNN E,1 ; SKIP IF DOING SPEC UNSPEC CHECK
\r
9268 CAMGE B,CURFCN+1(PVP)
\r
9272 CAMGE B,SPBASE+1(PVP)
\r
9276 POPJ P, ;FROM THE VALUE CELL
\r
9278 SCHLP: MOVEI D,(B)
\r
9279 CAIL D,HIBOT ; SKIP IF IMPURE ATOM
\r
9280 SCHSP: MOVEI E,1 ; DONT STORE LOCATIVE
\r
9282 PUSH P,E ; PUSH SWITCH
\r
9283 MOVE E,PVP ; GET PROC
\r
9284 SCHLP1: JUMPE C,UNPJ ;IF NO MORE -- LOSE
\r
9285 CAMN B,1(C) ;ARE WE POINTING AT THE WINNER?
\r
9287 GETYP D,(C) ; CHECK SKIP
\r
9290 PUSH P,B ; CHECK DETOUR
\r
9292 PUSHJ P,CHFRAM ; NON-FATAL FRAME CHECKER
\r
9293 HRRZ E,2(C) ; CONS UP PROCESS
\r
9296 JUMPE B,SCHLP3 ; LOSER, FIX IT
\r
9298 MOVEI C,1(C) ; FOLLOW LOOKUP CHAIN
\r
9299 SCHLP2: HRRZ C,(C) ;FOLLOW LINK
\r
9303 MOVEI C,(SP) ; *** NDR'S BUG ***
\r
9304 CAME E,PVP ; USE IF CURRENT PROCESS
\r
9305 HRRZ C,SPSTO+1(E) ; USE CURRENT SP FOR PROC
\r
9308 SCHFND: EXCH B,C ;SAVE THE ATOM PTR IN C
\r
9309 MOVEI B,2(B) ;MAKE UP THE LOCATIVE
\r
9313 EXCH C,E ; RET PROCESS IN C
\r
9314 POP P,D ; RESTORE SWITCH
\r
9316 JUMPN D,ILOCPJ ; DONT CLOBBER ATOM
\r
9317 MOVEM A,(E) ;CLOBBER IT AWAY INTO THE
\r
9318 MOVEM B,1(E) ;ATOM'S VALUE CELL
\r
9321 UNPJ: SUB P,[1,,1] ; FLUSH CRUFT
\r
9322 UNPJ1: MOVE C,E ; RET PROCESS ANYWAY
\r
9325 UNPOPJ: MOVSI A,TUNBOUND
\r
9329 ;IGLOC RETURNS IN A AND B A LOCATIVE TO THE GLOBAL VALUE OF THE
\r
9330 ;IDENTIFIER PASSED TO IT IN A AND B. IF THE IDENTIFIER IS GLOBALLY
\r
9331 ;UNBPOUND IT RETURNS $TUNBOUND IN A AND 0 IN B. IT IS CALLED BY PUSHJ P,IGLOC.
\r
9334 IGLOC: MOVSI A,TLOCI ;DO WE HAVE A LOCATIVE TO
\r
9335 CAME A,(B) ;A PROCESS #0 VALUE?
\r
9336 JRST SCHGSP ;NO -- SEARCH
\r
9337 MOVE B,1(B) ;YES -- GET VALUE CELL
\r
9340 SCHGSP: MOVE D,GLOBSP+1(TVP) ;GET GLOBAL SP PTR
\r
9342 SCHG1: JUMPGE D,UNPOPJ ;IF NO MORE, LEAVE
\r
9343 CAMN B,1(D) ;ARE WE FOUND?
\r
9344 JRST GLOCFOUND ;YES
\r
9345 ADD D,[4,,4] ;NO -- TRY NEXT
\r
9349 EXCH B,D ;SAVE ATOM PTR
\r
9350 ADD B,[2,,2] ;MAKE LOCATIVE
\r
9354 MOVEM A,(D) ;CLOBBER IT AWAY
\r
9358 IIGLOC: PUSH TP,$TATOM
\r
9368 PUSHJ P,BSETG ; MAKE A SLOT
\r
9369 SETOM 1(B) ; UNBOUNDIFY IT
\r
9378 ;ILVAL RETURNS IN A AND B THE LOCAL VALUE OF THE IDENTIFIER PASSED TO IT IN A AND B
\r
9379 ;IF THE IDENTIFIER IS UNBOUND ITS VALUE IS $TUNBOUND IN A AND 0 IN B. IF
\r
9380 ;IT IS UNASSIGNED ITS VALUE IS $TUNBOUND IN A AND -1 IN B. CALL - PUSHJ P,IVAL
\r
9383 PUSHJ P,AILOC ; USE SUPPLIED SP
\r
9386 PUSHJ P,ILOC ;GET LOCATIVE TO VALUE
\r
9387 CHVAL: CAMN A,$TUNBOUND ;BOUND
\r
9388 POPJ P, ;NO -- RETURN
\r
9389 MOVSI A,TLOCD ; GET GOOD TYPE
\r
9390 HRR A,2(B) ; SHOULD BE TIME OR 0
\r
9392 PUSHJ P,RMONC0 ; CHECK READ MONITOR
\r
9394 MOVE A,(B) ;GET THE TYPE OF THE VALUE
\r
9395 MOVE B,1(B) ;GET DATUM
\r
9398 ;IGVAL -- LIKE ILVAL EXCEPT FOR GLOBAL VALUES
\r
9400 IGVAL: PUSHJ P,IGLOC
\r
9405 ; COMPILERS INTERFACE TO LVAL/GVAL/SETG/SET
\r
9407 CILVAL: MOVE 0,BINDID+1(PVP) ; CURRENT BIND
\r
9409 CAME 0,(B) ; HURRAY FOR SPEED
\r
9410 JRST CILVA1 ; TOO BAD
\r
9411 MOVE C,1(B) ; POINTER
\r
9412 MOVE A,(C) ; VAL TYPE
\r
9413 TLNE A,.RDMON ; MONITORS?
\r
9417 JRST CUNAS ; COMPILER ERROR
\r
9418 MOVE B,1(C) ; GOT VAL
\r
9422 HLRZ 0,-2(C) ; SPECIAL CHECK
\r
9425 CAMGE C,CURFCN+1(PVP)
\r
9430 CILVA1: SUBM M,(P) ; FIX (P)
\r
9431 PUSH TP,$TATOM ; SAVE ATOM
\r
9433 MCALL 1,LVAL ; GET ERROR/MONITOR
\r
9435 POPJM: SUBM M,(P) ; REPAIR DAMAGE
\r
9438 ; COMPILERS INTERFACE TO SET C/ ATOM A,B/ NEW VALUE
\r
9440 CISET: MOVE 0,BINDID+1(PVP) ; CURRENT BINDING ENVIRONMENT
\r
9442 CAME 0,(C) ; CAN WE WIN?
\r
9443 JRST CISET1 ; NO, MORE HAIR
\r
9444 MOVE D,1(C) ; POINT TO SLOT
\r
9445 HLLZ 0,(D) ; MON CHECK
\r
9446 CISET3: TLNE 0,.WRMON
\r
9447 JRST CISET4 ; YES, LOSE
\r
9449 IOR A,0 ; LEAVE MONITOR ON
\r
9452 JRST CISET5 ; SPEC/UNSPEC CHECK
\r
9453 CISET6: MOVEM A,(D) ; STORE
\r
9457 CISET5: HLRZ 0,-2(D)
\r
9460 CAMGE D,CURFCN+1(PVP)
\r
9464 CISET1: SUBM M,(P) ; FIX ADDR
\r
9465 PUSH TP,$TATOM ; SAVE ATOM
\r
9469 MOVE B,C ; GET ATOM
\r
9470 PUSHJ P,ILOC ; SEARCH
\r
9471 MOVE D,B ; POSSIBLE POINTER
\r
9474 MOVE A,-1(TP) ; VAL BACK
\r
9476 CAIE E,TUNBOU ; SKIP IF WIN
\r
9477 JRST CISET2 ; GO CLOBBER IT IN
\r
9481 CISET2: MOVE C,-2(TP) ; ATOM BACK
\r
9482 SUBM M,(P) ; RESET (P)
\r
9486 ; HERE TO DO A MONITORED SET
\r
9488 CISET4: SUBM M,(P) ; AGAIN FIX (P)
\r
9498 CLLOC: MOVE 0,BINDID+1(PVP) ; GET CURRENT LOCATIVE
\r
9504 TRNE 0,1 ; SKIP IF NOT CHECKING
\r
9506 CLLOC3: MOVSI A,TLOCD
\r
9507 HRR A,2(B) ; GET BIND TIME
\r
9510 CLLOC1: SUBM M,(P)
\r
9513 PUSHJ P,ILOC ; LOOK IT UP
\r
9516 CLLOC4: SUBM M,(P)
\r
9519 CLLOC2: MCALL 1,LLOC
\r
9522 CLLOC9: HLRZ 0,-2(B)
\r
9525 CAMGE B,CURFCN+1(PVP)
\r
9531 CBOUND: SUBM M,(P)
\r
9533 JUMPE B,PJFALS ; IF UNBOUND RET FALSE AND NO SSKIP
\r
9543 ; COMPILER ASSIGNED?
\r
9554 ; COMPILER GVAL B/ ATOM
\r
9556 CIGVAL: MOVE 0,(B) ; GLOBAL VAL HERE?
\r
9557 CAME 0,$TLOCI ; TIME=0 ,TYPE=TLOCI => GLOB VAL
\r
9558 JRST CIGVA1 ; NO, GO LOOK
\r
9559 MOVE C,1(B) ; POINT TO SLOT
\r
9560 MOVE A,(C) ; GET TYPE
\r
9563 GETYP 0,A ; CHECK FOR UNBOUND
\r
9564 CAIN 0,TUNBOU ; SKIP IF WINNER
\r
9570 CIGVA1: SUBM M,(P)
\r
9573 .MCALL 1,GVAL ; GET ERROR/MONITOR
\r
9576 ; COMPILER INTERFACET TO SETG
\r
9578 CSETG: MOVE 0,(C) ; GET V CELL
\r
9579 CAME 0,$TLOCI ; SKIP IF FAST
\r
9581 HRRZ D,1(C) ; POINT TO SLOT
\r
9582 MOVE 0,(D) ; OLD VAL
\r
9583 CSETG3: CAIG D,HIBOT ; SKIP IF PURE ATOM
\r
9584 TLNE 0,.WRMON ; MONITOR
\r
9590 CSETG1: SUBM M,(P) ; FIX UP P
\r
9596 PUSHJ P,IGLOC ; FIND GLOB LOCATIVE
\r
9599 MOVEI D,(B) ; SETUP TO RESTORE NEW VAL
\r
9607 CSETG4: MOVE C,-2(TP) ; ATOM BACK
\r
9608 SUBM M,(P) ; RESET (P)
\r
9612 CSETG2: SUBM M,(P)
\r
9613 PUSH TP,$TATOM ; CAUSE A SETG MONITOR
\r
9622 CGLOC: MOVE 0,(B) ; GET CURRENT GUY
\r
9623 CAME 0,$TLOCI ; WIN?
\r
9624 JRST CGLOC1 ; NOPE
\r
9625 HRRZ D,1(B) ; POINT TO SLOT
\r
9626 CAILE D,HIBOT ; PURE?
\r
9632 CGLOC1: SUBM M,(P)
\r
9638 ; COMPILERS GASSIGNED?
\r
9640 CGASSQ: MOVE 0,(B)
\r
9651 ; COMPILERS GBOUND?
\r
9653 CGBOUN: MOVE 0,(B)
\r
9662 MFUNCTION REP,FSUBR,[REPEAT]
\r
9664 MFUNCTION PROG,FSUBR
\r
9666 GETYP A,(AB) ;GET ARG TYPE
\r
9667 CAIE A,TLIST ;IS IT A LIST?
\r
9668 JRST WRONGT ;WRONG TYPE
\r
9669 SKIPN C,1(AB) ;GET AND CHECK ARGUMENT
\r
9670 JRST TFA ;TOO FEW ARGS
\r
9671 SETZB E,D ; INIT HEWITT ATOM AND DECL
\r
9672 PUSHJ P,CARATC ; IS 1ST THING AN ATOM
\r
9674 PUSHJ P,RSATY1 ; CDR AND GET TYPE
\r
9675 CAIE 0,TLIST ; MUST BE LIST
\r
9677 MOVE B,1(C) ; GET ARG LIST
\r
9682 JRST NOP.DC ; JUMP IF NO DCL
\r
9685 PUSHJ P,RSATYP ; CDR ON
\r
9686 NOP.DC: PUSH TP,$TLIST
\r
9687 PUSH TP,B ; AND ARG LIST
\r
9688 PUSHJ P,PRGBND ; BIND AUX VARS
\r
9689 MOVE E,MQUOTE LPROG,[LPROG ]INTRUP
\r
9690 PUSHJ P,MAKACT ; MAKE ACTIVATION
\r
9691 PUSHJ P,PSHBND ; BIND AND CHECK
\r
9692 PUSHJ P,SPECBI ; NAD BIND IT
\r
9694 ; HERE TO RUN PROGS FUNCTIONS ETC.
\r
9696 DOPROG: MOVEI A,REPROG
\r
9697 HRLI A,TDCLI ; FLAG AS FUNNY
\r
9698 MOVEM A,(TB) ; WHERE TO AGAIN TO
\r
9700 MOVEM C,3(TB) ; RESTART POINTER
\r
9701 JRST .+2 ; START BY SKIPPING DECL
\r
9703 DOPRG1: PUSHJ P,FASTEV
\r
9704 HRRZ C,@1(TB) ;GET THE REST OF THE BODY
\r
9705 DOPRG2: MOVEM C,1(TB)
\r
9710 REPROG: SKIPN C,@3(TB)
\r
9718 PFINIS: GETYP 0,(TB)
\r
9719 CAIE 0,TDCLI ; DECL'D ?
\r
9721 HRRZ 0,(TB) ; SEE IF RSUBR
\r
9722 JUMPE 0,RSBVCK ; CHECK RSUBR VALUE
\r
9723 HRRZ C,3(TB) ; GET START OF FCN
\r
9724 GETYP 0,(C) ; CHECK FOR DECL
\r
9726 JRST PFINI1 ; NO, JUST RETURN
\r
9727 MOVE E,MQUOTE VALUE
\r
9728 PUSHJ P,PSHBND ; BUILD FAKE BINDING
\r
9729 MOVE C,1(C) ; GET DECL LIST
\r
9731 PUSHJ P,CHKDCL ; AND CHECK IT
\r
9732 MOVE A,-3(TP) ; GET VAL BAKC
\r
9736 PFINI1: HRRZ C,FSAV(TB)
\r
9741 RSATYP: HRRZ C,(C)
\r
9742 RSATY1: JUMPE C,TFA
\r
9746 ; HERE TO CHECK RSUBR VALUE
\r
9752 MOVE A,1(TB) ; GET DECL
\r
9761 RSBVC1: MOVE C,1(TB)
\r
9764 MOVE A,MQUOTE VALUE
\r
9768 MFUNCTION MRETUR,SUBR,[RETURN]
\r
9770 HLRE A,AB ; GET # OF ARGS
\r
9771 ASH A,-1 ; TO NUMBER
\r
9772 AOJL A,RET2 ; 2 OR MORE ARGS
\r
9773 PUSHJ P,PROGCH ;CHECK IN A PROG
\r
9776 MOVEI B,-1(TP) ; VERIFY IT
\r
9777 COMRET: PUSHJ P,CHFSWP
\r
9779 MOVEI C,0 ; REAL NONE
\r
9781 JUMPN A,CHFINI ; WINNER
\r
9785 ; SEE IF MUST CHECK RETURNS TYPE
\r
9787 CHFINI: GETYP 0,(TB) ; SPECIAL TYPE IF SO
\r
9789 JRST FINIS ; NO, JUST FINIS
\r
9790 MOVEI 0,PFINIS ; CAUSE TO FALL INTO FUNCTION CODE
\r
9797 CAIE A,TACT ; AS FOR "EXIT" SHOULD BE ACTIVATION
\r
9799 MOVEI B,(AB)+2 ; ADDRESS OF FRAME POINTER
\r
9804 MFUNCTION AGAIN,SUBR
\r
9806 HLRZ A,AB ;GET # OF ARGS
\r
9809 JUMPN A,TMA ;0 ARGS?
\r
9810 PUSHJ P,PROGCH ;CHECK FOR IN A PROG
\r
9814 NLCLA: GETYP A,(AB)
\r
9819 AGAD: MOVEI B,-1(TP) ; POINT TO FRAME
\r
9821 HRRZ C,(B) ; GET RET POINT
\r
9822 GOJOIN: PUSH TP,$TFIX
\r
9825 PUSHJ P,CHUNW ; RESTORE FRAME, UNWIND IF NEC.
\r
9827 HRRZ 0,FSAV(TB) ; CHECK FOR RSUBR
\r
9838 MOVEM SP,SPSAV(TB)
\r
9839 MOVEM TP,TPSAV(TB)
\r
9840 MOVE C,OTBSAV(TB) ; AND RESTORE P FROM FATHER
\r
9852 PUSHJ P,PROGCH ;CHECK FOR A PROG
\r
9861 MCALL 2,MEMQ ;DOES IT HAVE THIS TAG?
\r
9862 JUMPE B,NXTAG ;NO -- ERROR
\r
9863 FNDGO: EXCH B,(TP) ;SAVE PLACE TO GO
\r
9868 NLCLGO: CAIE A,TTAG ;CHECK TYPE
\r
9871 MOVEI B,2(B) ; POINT TO SLOT
\r
9874 GETYP 0,(A) ; SEE IF COMPILED
\r
9880 GODON1: PUSH TP,(A) ;SAVE BODY
\r
9883 PUSHJ P,CHUNW ;GO BACK TO CORRECT FRAME
\r
9884 MOVE B,(TP) ;RESTORE ITERATION MARKER
\r
9893 MFUNCTION TAG,SUBR
\r
9897 GETYP A,(AB) ;GET TYPE OF ARGUMENT
\r
9898 CAIE A,TFIX ; FIX ==> COMPILED
\r
9910 ATOTAG: CAIE A,TATOM ;CHECK THAT IT IS AN ATOM
\r
9914 PUSHJ P,PROGCH ;CHECK PROG
\r
9915 PUSH TP,A ;SAVE VAL
\r
9922 JUMPE B,NXTAG ;IF NOT FOUND -- ERROR
\r
9923 EXCH A,-1(TP) ;SAVE PLACE
\r
9933 PROGCH: MOVE B,MQUOTE LPROG,[LPROG ]INTRUP
\r
9934 PUSHJ P,ILVAL ;GET VALUE
\r
9940 ; HERE TO UNASSIGN LPROG IF NEC
\r
9942 UNPROG: MOVE B,MQUOTE LPROG,[LPROG ]INTRUP
\r
9945 CAIE 0,TACT ; SKIP IF MUST UNBIND
\r
9949 MOVE E,MQUOTE LPROG,[LPROG ]INTRUP
\r
9951 UNMAP: HRRZ 0,FSAV(TB) ; CHECK FOR FUNNY
\r
9952 CAIN 0,MAPPLY ; SKIP IF NOT
\r
9954 MOVE B,MQUOTE LMAP,[LMAP ]INTRUP
\r
9961 MOVE E,MQUOTE LMAP,[LMAP ]INTRUP
\r
9963 UNSPEC: PUSH TP,BNDV
\r
9965 ADD B,[CURFCN,,CURFCN]
\r
9974 MFUNCTION MEXIT,SUBR,[EXIT]
\r
9982 PUSHJ P,CHUNW ;RESTORE FRAME
\r
9983 JRST CHFINI ; CHECK FOR WINNING VALUE
\r
9986 MFUNCTION COND,FSUBR
\r
9992 PUSH TP,1(AB) ;CREATE UNNAMED TEMP
\r
9993 MOVEI B,0 ; SET TO FALSE IN CASE
\r
9995 CLSLUP: SKIPN C,1(TB) ;IS THE CLAUSELIST NIL?
\r
9996 JRST IFALS1 ;YES -- RETURN NIL
\r
9997 GETYP A,(C) ;NO -- GET TYPE OF CAR
\r
9998 CAIE A,TLIST ;IS IT A LIST?
\r
10000 MOVE A,1(C) ;YES -- GET CLAUSE
\r
10003 PUSH TP,B ; EVALUATION OF
\r
10005 PUSH TP,1(A) ;THE PREDICATE
\r
10010 JRST NXTCLS ;FALSE TRY NEXT CLAUSE
\r
10011 MOVE C,1(TB) ;IF NOT, DO FIRST CLAUSE
\r
10014 JUMPE C,FINIS ;(UNLESS DONE WITH IT)
\r
10015 JRST DOPRG2 ;AS THOUGH IT WERE A PROG
\r
10016 NXTCLS: HRRZ C,@1(TB) ;SET THE CLAUSLIST
\r
10017 HRRZM C,1(TB) ;TO CDR OF THE CLAUSLIST
\r
10022 IFALS1: MOVSI A,TFALSE ;RETURN FALSE
\r
10027 MFUNCTION UNWIND,FSUBR
\r
10031 GETYP 0,(AB) ; CHECK THE ARGS FOR WINNAGE
\r
10032 SKIPN A,1(AB) ; NONE?
\r
10034 HRRZ B,(A) ; CHECK FOR 2D
\r
10039 ; Unbind LPROG and LMAPF so that nothing cute happens
\r
10043 ; Push thing to do upon UNWINDing
\r
10049 PUSHJ P,IUNWIN ; GOT TO INTERNAL SET UP
\r
10051 ; Now EVAL the first form
\r
10054 HRRZ 0,(A) ; SAVE POINTER TO OTHER GUY
\r
10059 JSP E,CHKAB ; DEFER?
\r
10062 MCALL 1,EVAL ; EVAL THE LOSER
\r
10066 ; Now push slots to hold undo info on the way down
\r
10082 PUSH TP,$TTB ; DESTINATION FRAME
\r
10084 PUSH TP,[0] ; ARGS TO WHOEVER IS DOING IT
\r
10087 ; Now bind UNWIND word
\r
10089 PUSH TP,$TUNWIN ; FIRST WORD OF IT
\r
10090 HRRM SP,(TP) ; CHAIN
\r
10092 PUSH TP,TB ; AND POINT TO HERE
\r
10097 PUSH TP,P ; SAVE PDL ALSO
\r
10098 MOVEM TP,-2(TP) ; SAVE FOR LATER
\r
10101 ; Do a non-local return with UNWIND checking
\r
10103 CHUNW: HRRZ E,SPSAV(B) ; GET DESTINATION FRAME
\r
10104 CHUNW1: PUSH TP,(C) ; FINAL VAL
\r
10106 JUMPN C,.+3 ; WAS THERE REALLY ANYTHING
\r
10109 PUSHJ P,STLOOP ; UNBIND
\r
10110 CHUNPC: SKIPA ; WILL NOT SKIP UNLESS UNWIND FOUND
\r
10117 HRRI TB,(B) ; UPDATE TB
\r
10122 ; Here if an UNDO found
\r
10124 GOTUND: MOVE TB,1(SP) ; GET FRAME OF UNDO
\r
10125 MOVE A,-1(TP) ; GET FUNNY ARG FOR PASS ON
\r
10127 MOVE TP,3(SP) ; GET FUTURE TP
\r
10128 MOVEM C,-6(TP) ; SAVE ARG
\r
10130 MOVE C,(TP) ; SAVED P
\r
10132 MOVEM C,PSAV(TB) ; MAKE CONTIN WIN
\r
10133 MOVEM TP,TPSAV(TB)
\r
10134 MOVEM SP,SPSAV(TB)
\r
10135 HRRZ C,(P) ; PC OF CHUNW CALLER
\r
10136 HRRM C,-11(TP) ; SAVE ALSO AND GET WHERE TO GO PC
\r
10137 MOVEM B,-10(TP) ; AND DESTINATION FRAME
\r
10138 HRRZ C,-1(TP) ; WHERE TO UNWIND PC
\r
10139 HRRZ 0,FSAV(TB) ; RSUBR?
\r
10142 TLZA C,-1 ; 0 LH OF C AND SKIP
\r
10143 HRLI C,M ; RELATIVIZE
\r
10144 MOVEM C,PCSAV(TB)
\r
10147 UNWIN1: MOVE B,-12(TP) ; POINT TO THING TO DO UNWINDING
\r
10155 UNWIN2: MOVEI C,-7(TP) ; POINT TO SAVED RET VALS
\r
10159 HRRZ SP,(SP) ; UNBIND THIS GUY
\r
10160 MOVEI E,(TP) ; AND FIXUP SP
\r
10165 JRST CHUNW ; ANY MORE TO UNWIND?
\r
10168 ; CHFSWP - CHECK FRAMES VALIDITY AND SWAP PROCESS IF NECESSARY.
\r
10169 ; CALLED BY ALL CONTROL FLOW
\r
10170 ; ROUTINES (GO,RETURN,EXIT,AGAIN,ERRET...)
\r
10172 CHFSWP: PUSHJ P,CHFRM ; CHECK FOR VALID FRAME
\r
10173 HRRZ D,(B) ; PROCESS VECTOR DOPE WD
\r
10174 HLRZ C,(D) ; LENGTH
\r
10175 SUBI D,-1(C) ; POINT TO TOP
\r
10176 MOVNS C ; NEGATE COUNT
\r
10177 HRLI D,2(C) ; BUILD PVP
\r
10180 MOVE A,(B) ; GET FRAME
\r
10182 CAMN E,D ; SKIP IF SWAP NEEDED
\r
10184 PUSH TP,A ; SAVE FRAME
\r
10187 PUSHJ P,PROCHK ; FIX UP PROCESS LISTS
\r
10188 MOVE A,PSTAT+1(B) ; GET STATE
\r
10191 MOVE D,B ; PREPARE TO SWAP
\r
10192 POP P,0 ; RET ADDR
\r
10195 JSP C,SWAP ; SWAP IN
\r
10196 MOVE C,ABSTO+1(E) ; GET OLD ARRGS
\r
10197 MOVEI A,RUNING ; FIX STATES
\r
10198 MOVEM A,PSTAT+1(PVP)
\r
10200 MOVEM A,PSTAT+1(E)
\r
10203 NOTRES: PUSH TP,$TATOM
\r
10204 PUSH TP,EQUOTE PROCESS-NOT-RESUMABLE
\r
10208 ;SETG IS USED TO SET THE GLOBAL VALUE OF ITS FIRST ARGUMENT,
\r
10209 ;AN IDENTIFIER, TO THE VALUE OF ITS SECOND ARGUMENT. ITS VALUE IS
\r
10210 ; ITS SECOND ARGUMENT.
\r
10212 MFUNCTION SETG,SUBR
\r
10214 GETYP A,(AB) ;GET TYPE OF FIRST ARGUMENT
\r
10215 CAIE A,TATOM ;CHECK THAT IT IS AN ATOM
\r
10216 JRST NONATM ;IF NOT -- ERROR
\r
10217 MOVE B,1(AB) ;GET POINTER TO ATOM
\r
10221 CAIL 0,HIBOT ; PURE ATOM?
\r
10222 PUSHJ P,IMPURIFY ; YES IMPURIFY
\r
10223 PUSHJ P,IGLOC ;GET LOCATIVE TO VALUE
\r
10224 CAMN A,$TUNBOUND ;IF BOUND
\r
10225 PUSHJ P,BSETG ;IF NOT -- BIND IT
\r
10226 MOVE C,2(AB) ; GET PROPOSED VVAL
\r
10228 MOVSI A,TLOCD ; MAKE SURE MONCH WINS
\r
10229 PUSHJ P,MONCH0 ; WOULD YOU BELIEVE MONITORS!!!!
\r
10230 EXCH D,B ;SAVE PTR
\r
10232 HRRZ E,-2(D) ; POINT TO POSSIBLE GDECL (OR MAINIFEST)
\r
10233 JUMPE E,OKSETG ; NONE ,OK
\r
10234 CAIE E,-1 ; MANIFEST?
\r
10236 GETYP 0,(D) ; IF UNBOUND, LET IT HAPPEN
\r
10240 MANILO: GETYP C,(D)
\r
10248 MOVE B,MQUOTE REDEFINE
\r
10249 PUSHJ P,ILVAL ; SEE IF REDEFINE OK
\r
10256 PUSH TP,EQUOTE ATTEMPT-TO-CHANGE-MANIFEST-VARIABLE
\r
10262 SETGTY: PUSH TP,$TVEC
\r
10273 OKSTG: MOVE D,(TP)
\r
10277 OKSETG: MOVEM A,(D) ;DEPOSIT INTO THE
\r
10278 MOVEM B,1(D) ;INDICATED VALUE CELL
\r
10281 TYPMI3: MOVE C,(TP)
\r
10289 BSETG: HRRZ A,GLOBASE+1(TVP)
\r
10290 HRRZ B,GLOBSP+1(TVP)
\r
10294 MOVEI B,0 ; MAKE SURE OF NO EMPTY SLOTS
\r
10296 CAMN A,$TUNBOU ; SKIP IF SLOT FOUND
\r
10298 MOVE E,(TP) ; GET ATOM
\r
10299 MOVEM E,-1(B) ; CLOBBER ATOM SLOT
\r
10301 ; BSETG1: PUSH TP,GLOBASE(TVP) ; MUST REALLY GROW STACK
\r
10302 ; PUSH TP,GLOBASE+1 (TVP)
\r
10310 MOVE C,GLOBASE+1(TVP)
\r
10313 MOVE B,GVLINC ; GROW BY INDICATED GVAL SLOTS
\r
10314 DPB B,[001100,,(C)]
\r
10315 ; MOVEM A,GLOBASE(TVP)
\r
10316 MOVE C,[6,,4] ; INDICATOR FOR AGC
\r
10318 MOVE B,GLOBASE+1(TVP)
\r
10319 MOVE 0,GVLINC ; ADJUST GLOBAL SPBASE
\r
10324 MOVEM B,GLOBASE+1(TVP)
\r
10325 ; MOVEM B,GLOBASE+1(TVP)
\r
10329 MOVE B,GLOBSP+1(TVP)
\r
10335 MOVEM B,GLOBSP+1(TVP)
\r
10341 MFUNCTION DEFMAC,FSUBR
\r
10348 MFUNCTION DFNE,FSUBR,[DEFINE]
\r
10353 DFNE2: GETYP A,(AB)
\r
10356 SKIPN B,1(AB) ; GET ATOM
\r
10358 GETYP A,(B) ; MAKE SURE ATOM
\r
10363 MCALL 1,EVAL ; EVAL IT TO AN ATOM
\r
10366 PUSH TP,A ; SAVE TWO COPIES
\r
10368 PUSHJ P,IGVAL ; SEE IF A VALUE EXISTS
\r
10369 CAMN A,$TUNBOU ; SKIP IF A WINNER
\r
10371 PUSHJ P,ASKUSR ; CHECK WITH USER
\r
10378 SKIPN (P) ; SKIP IF MACRO
\r
10380 MOVEI D,(B) ; READY TO CONS
\r
10387 DFNE1: POP TP,B ; RETURN ATOM
\r
10392 ASKUSR: MOVE B,MQUOTE REDEFINE
\r
10393 PUSHJ P,ILVAL ; SEE IF REDEFINE OK
\r
10399 ASKUS1: PUSH TP,$TATOM
\r
10402 PUSH TP,EQUOTE ALREADY-DEFINED-ERRET-NON-FALSE-TO-REDEFINE
\r
10412 ;SET CLOBBERS THE LOCAL VALUE OF THE IDENTIFIER GIVEN BY ITS
\r
10413 ;FIRST ARGUMENT TO THE SECOND ARG. ITS VALUE IS ITS SECOND ARGUMENT.
\r
10415 MFUNCTION SET,SUBR
\r
10416 HLRE D,AB ; 2 TIMES # OF ARGS TO D
\r
10417 ASH D,-1 ; - # OF ARGS
\r
10419 JUMPG D,TFA ; NOT ENOUGH
\r
10422 JUMPE D,SET1 ; NO ENVIRONMENT
\r
10423 AOJL D,TMA ; TOO MANY
\r
10424 GETYP A,4(AB) ; CHECK ARG IS A FRAME OR PROCESS
\r
10427 JRST SET2 ; WINNING ENVIRONMENT/FRAME
\r
10429 JRST SET2 ; TO MAKE PFISTER HAPPY
\r
10432 MOVE B,5(AB) ; GET PROCESS
\r
10433 MOVE C,SPSTO+1(B)
\r
10435 SET2: MOVEI B,4(AB) ; POINT TO FRAME
\r
10436 PUSHJ P,CHFRM ; CHECK IT OUT
\r
10437 MOVE B,5(AB) ; GET IT BACK
\r
10438 MOVE C,SPSAV(B) ; GET BINDING POINTER
\r
10439 HRRZ B,4(AB) ; POINT TO PROCESS
\r
10440 HLRZ A,(B) ; GET LENGTH
\r
10441 SUBI B,-1(A) ; POINT TO START THEREOF
\r
10442 HLL B,PVP ; GET -LNTRH, (ALL PROCESS VECS SAME LENGTH)
\r
10443 SET1: PUSH TP,$TPVP ; SAVE PROCESS
\r
10445 PUSH TP,$TSP ; SAVE PATH POINTER
\r
10447 GETYP A,(AB) ;GET TYPE OF FIRST
\r
10448 CAIE A,TATOM ;ARGUMENT --
\r
10449 JRST WTYP1 ;BETTER BE AN ATOM
\r
10450 MOVE B,1(AB) ;GET PTR TO IT
\r
10455 PUSHJ P,AILOC ;GET LOCATIVE TO VALUE
\r
10456 GOTLOC: CAMN A,$TUNBOUND ;BOUND?
\r
10457 PUSHJ P, BSET ;BIND IT
\r
10459 MOVE C,2(AB) ; GET NEW VAL
\r
10461 MOVSI A,TLOCD ; FOR MONCH
\r
10463 PUSHJ P,MONCH0 ; HURRAY FOR MONITORS!!!!!
\r
10465 HLRZ A,2(E) ; GET DECLS
\r
10466 JUMPE A,SET3 ; NONE, GO
\r
10470 HLLZ A,(A) ; GET PATTERN
\r
10471 PUSHJ P,TMATCH ; MATCH TMEM
\r
10472 JRST TYPMI2 ; LOSES
\r
10477 SET3: MOVEM C,(E) ;CLOBBER IDENTIFIER
\r
10483 CAMN PVP,-2(TP) ; SKIP IF PROC DIFFERS
\r
10484 MOVEM C,-2(TP) ; ELSE USE RESULT FROM LOC SEARCH
\r
10485 MOVE B,-2(TP) ; GET PROCESS
\r
10486 HRRZ A,TPBASE+1(B) ;GET ACTUAL STACK BASE
\r
10487 HRRZ B,SPBASE+1(B) ;AND FIRST BINDING
\r
10488 SUB B,A ;ARE THERE 6
\r
10489 CAIL B,6 ;CELLS AVAILABLE?
\r
10491 MOVE C,(TP) ; GET POINTER BACK
\r
10492 MOVEI B,0 ; LOOK FOR EMPTY SLOT
\r
10494 CAMN A,$TUNBOUND ; SKIP IF FOUND
\r
10496 MOVE E,1(AB) ; GET ATOM
\r
10497 MOVEM E,-1(B) ; AND STORE
\r
10499 BSET1: MOVE B,-2(TP) ; GET PROCESS
\r
10500 ; PUSH TP,TPBASE(B) ;NO -- GROW THE TP
\r
10501 ; PUSH TP,TPBASE+1(B) ;AT THE BASE END
\r
10507 ; MOVE C,-2(TP) ; GET PROCESS
\r
10508 ; MOVEM A,TPBASE(C) ;SAVE RESULT
\r
10509 PUSH P,0 ; MANUALLY GROW VECTOR
\r
10511 MOVE C,TPBASE+1(B)
\r
10518 DPB D,[001100,,-1(C)]
\r
10519 MOVE C,[5,,3] ; SET UP INDICATORS FOR AGC
\r
10521 MOVE B,TPBASE+1(PVP) ; MODIFY POINTER
\r
10522 MOVE 0,LVLINC ; ADJUST SPBASE POINTER
\r
10527 MOVEM B,TPBASE+1(PVP)
\r
10530 ; MOVEM B,TPBASE+1(C)
\r
10531 SETIT: MOVE C,-2(TP) ; GET PROCESS
\r
10532 MOVE B,SPBASE+1(C)
\r
10533 MOVEI A,-6(B) ;MAKE UP BINDING
\r
10534 HRRM A,(B) ;LINK PREVIOUS BIND BLOCK
\r
10540 MOVEM B,SPBASE+1(C)
\r
10542 BSET2: MOVE C,-2(TP) ; GET PROC
\r
10544 HRR A,BINDID+1(C)
\r
10545 HLRZ D,OTBSAV(TB) ; TIME IT
\r
10546 MOVEM D,2(B) ; AND FIX IT
\r
10549 ; HERE TO ELABORATE ON TYPE MISMATCH
\r
10551 TYPMI2: MOVE C,(TP) ; FIND DECLS
\r
10555 MOVE 0,(AB) ; GET ATOM
\r
10561 MFUNCTION NOT,SUBR
\r
10563 GETYP A,(AB) ; GET TYPE
\r
10564 CAIE A,TFALSE ;IS IT FALSE?
\r
10565 JRST IFALSE ;NO -- RETURN FALSE
\r
10568 MOVSI A,TATOM ;RETURN T (VERITAS)
\r
10572 MFUNCTION OR,FSUBR
\r
10577 MFUNCTION ANDA,FSUBR,AND
\r
10583 JRST WRONGT ;IF ARG DOESN'T CHECK OUT
\r
10585 SKIPN C,1(AB) ;IF NIL
\r
10586 JRST TF(E) ;RETURN TRUTH
\r
10587 PUSH TP,$TLIST ;CREATE UNNAMED TEMP
\r
10591 JUMPE C,TFI(E) ;ANY MORE ARGS?
\r
10592 MOVEM C,1(TB) ;STORE CRUFT
\r
10596 PUSH TP,1(C) ;ARGUMENT
\r
10602 JRST FINIS ;IF FALSE -- RETURN
\r
10603 HRRZ C,@1(TB) ;GET CDR OF ARGLIST
\r
10612 TFSKP: CAIE 0,TFALSE
\r
10615 MFUNCTION FUNCTION,FSUBR
\r
10625 MFUNCTION CLOSURE,SUBR
\r
10627 SKIPL A,AB ;ANY ARGS
\r
10628 JRST TFA ;NO -- LOSE
\r
10629 ADD A,[2,,2] ;POINT AT IDS
\r
10632 PUSH P,[0] ;MAKE COUNTER
\r
10634 CLOLP: SKIPL A,1(TB) ;ANY MORE IDS?
\r
10635 JRST CLODON ;NO -- LOSE
\r
10636 PUSH TP,(A) ;SAVE ID
\r
10638 PUSH TP,(A) ;GET ITS VALUE
\r
10640 ADD A,[2,,2] ;BUMP POINTER
\r
10646 MCALL 2,LIST ;MAKE PAIR
\r
10652 ACALL A,LIST ;MAKE UP LIST
\r
10653 PUSH TP,(AB) ;GET FUNCTION
\r
10657 MCALL 2,LIST ;MAKE LIST
\r
10663 ;ERROR COMMENTS FOR EVAL
\r
10664 TUPTFA: PUSH TP,$TATOM
\r
10665 PUSH TP,EQUOTE TOO-FEW-ARGS-FOR-ITUPLE
\r
10668 TUPTMA: PUSH TP,$TATOM
\r
10669 PUSH TP,EQUOTE TOO-MANY-ARGS-TO-ITUPLE
\r
10672 BADNUM: PUSH TP,$TATOM
\r
10673 PUSH TP,EQUOTE NEGATIVE-ARG-TO-ITUPLE
\r
10676 WTY1TP: PUSH TP,$TATOM
\r
10677 PUSH TP,EQUOTE FIRST-ARG-TO-ITUPLE-NOT-FIX
\r
10680 UNBOU: PUSH TP,$TATOM
\r
10681 PUSH TP,EQUOTE UNBOUND-VARIABLE
\r
10684 UNAS: PUSH TP,$TATOM
\r
10685 PUSH TP,EQUOTE UNASSIGNED-VARIABLE
\r
10690 PUSH TP,EQUOTE BAD-ENVIRONMENT
\r
10695 PUSH TP,EQUOTE BAD-FUNARG
\r
10713 MPD: PUSH TP,$TATOM
\r
10714 PUSH TP,EQUOTE MEANINGLESS-PARAMETER-DECLARATION
\r
10717 NOBODY: PUSH TP,$TATOM
\r
10718 PUSH TP,EQUOTE HAS-EMPTY-BODY
\r
10721 BADCLS: PUSH TP,$TATOM
\r
10722 PUSH TP,EQUOTE BAD-CLAUSE
\r
10725 NXTAG: PUSH TP,$TATOM
\r
10726 PUSH TP,EQUOTE NON-EXISTENT-TAG
\r
10729 NXPRG: PUSH TP,$TATOM
\r
10730 PUSH TP,EQUOTE NOT-IN-PROG
\r
10734 NAPT: PUSH TP,$TATOM
\r
10735 PUSH TP,EQUOTE NON-APPLICABLE-TYPE
\r
10738 NONEVT: PUSH TP,$TATOM
\r
10739 PUSH TP,EQUOTE NON-EVALUATEABLE-TYPE
\r
10743 NONATM: PUSH TP,$TATOM
\r
10744 PUSH TP,EQUOTE NON-ATOMIC-ARGUMENT
\r
10748 ILLFRA: PUSH TP,$TATOM
\r
10749 PUSH TP,EQUOTE FRAME-NO-LONGER-EXISTS
\r
10752 ILLSEG: PUSH TP,$TATOM
\r
10753 PUSH TP,EQUOTE ILLEGAL-SEGMENT
\r
10756 BADMAC: PUSH TP,$TATOM
\r
10757 PUSH TP,EQUOTE BAD-USE-OF-MACRO
\r
10760 BADFSB: PUSH TP,$TATOM
\r
10761 PUSH TP,EQUOTE APPLY-OR-STACKFORM-OF-FSUBR
\r
10765 ER1ARG: PUSH TP,(AB)
\r
10771 \f\f\f\f\fTITLE OPEN - CHANNEL OPENER FOR MUDDLE
\r
10775 ;C. REEVE MARCH 1973
\r
10782 IF1, .INSRT MUDSYS;STENEX >
\r
10784 ;THIS PROGRAM HAS ENTRIES: FOPEN, FCLOSE, RENAME, READB, PRINTB, FILECOPY, READSTRING,
\r
10785 ; PRINTSTRING, NETSTATE, NETACC, NETS, AND ACCESS.
\r
10787 ;THESE SUBROUTINES HANDLE I/O STREAMS FOR THE MUDDLE SYSTEM.
\r
10789 ; FOPEN - OPENS A FILE FOR EITHER READING OR WRITING. IT TAKES
\r
10790 ; FIVE OPTINAL ARGUMENTS AS FOLLOWS:
\r
10792 ; FOPEN (<DIR>,<FILE NAME1>,<FILE NAME2>,<DEVICE>,<SYSTEM NAME>)
\r
10794 ; <DIR> - DIRECTION EITHER READ (INPUT) OR PRINT (OUPUT). DEFAULT IS READ
\r
10796 ; <FILE NAME1> - FIRST FILE NAME. DEFAULT INPUT OR OUTPUT.
\r
10798 ; <FILE NAME2> - SECOND FILE NAME. DEFAULT MUDDLE.
\r
10800 ; <DEVICE> - DEVICE FROM WHICH TO OPEN. DEFAULT IS DSK.
\r
10802 ; <SNAME> - SYSTEM (DIRECTORY) NAME. DEFAULT UNAME.
\r
10804 ; FOPEN RETURNS AN OBJECT OF TYPE CHANNEL IF IT SUCCEEDS OTHERWISE NIL
\r
10807 ; FCLOSE - CLOSES A FILE. TAKES A CHANNEL OBJECT AS ITS ARGUMENT. IT ALSO TAKES
\r
10808 ; ACCESS - DOES A .ACCESS ON A CHARACTER BASIS FOR CHARACTER FILES
\r
10811 ; A CHANNEL OBJECT IS A VECTOR CONTAINIG THE FOLLOWING INFORMATION
\r
10813 ; CHANNO ;ITS I/O CHANNEL NUMBER. 0 MEANS NOT A REAL CHANNEL.
\r
10814 ; DIRECT ;DIRECTION (EITHER READ OR PRINT)
\r
10815 ; NAME1 ;FIRST NAME OF FILE AS OPENED.
\r
10816 ; NAME2 ;SECOND NAME OF FILE
\r
10817 ; DEVICE ;DEVICE UPON WHICH THE CHANNEL IS OPEN
\r
10818 ; SNAME ;DIRECTORY NAME
\r
10819 ; RNAME1 ;REAL FIRST NAME (AS RETURNED BY READING CHANNEL STATUS)
\r
10820 ; RNAME2 ;REAL SECOND NAME
\r
10821 ; RDEVIC ;REAL DEVICE
\r
10822 ; RSNAME ;SYSTEM OR DIRECTORY NAME
\r
10823 ; STATUS ;VARIOUS STATUS BITS
\r
10824 ; IOINS ;INSTRUCTION EXECUTED TO INPUT OR OUTPUT ONE CHARACTER
\r
10825 ; ACCESS ;ACCESS POINTER FOR RAND ACCESS (OR USED FOR DISPLAY INFO)
\r
10826 ; RADX ;RADIX FOR CHANNELS NUMBER CONVERSION
\r
10828 ; *** THE FOLLOWING FIELDS FOR OUTPUT ONLY ***
\r
10829 ; LINLN ;LENGTH OF A LINE IN CHARACTERS FOR THIS DEVICE
\r
10830 ; CHRPOS ;CURRENT POSITION ON CURRENT LINE
\r
10831 ; PAGLN ;LENGTH OF A PAGE
\r
10832 ; LINPOS ;CURRENT LINE BEING WRITTEN ON
\r
10834 ; *** THE FOLLOWING FILEDS FOR INPUT ONLY ***
\r
10835 ; EOFCND ;GETS EVALUATED ON EOF
\r
10836 ; LSTCH ;BACKUP CHARACTER
\r
10837 ; WAITNS ;FOR TTY INPUT, BECOMES A .SLEEP WHEN WAITING
\r
10838 ; EXBUFR ;FOR TTY INPUT, CONTAINS A WAITING BUFFER LIST
\r
10839 ; BUFSTR ;A CHARACTER STRING USED AS BUFFER FOR NON-TTY DEVICES
\r
10841 ; THIS DEFINES THE LENGTH OF THE NON-TTY BUFFER
\r
10844 ;THIS DEFINES BLOCK MODE BIT FOR OPENING
\r
10845 BLOCKM==2 ;DEFINED IN THE LEFT HALF
\r
10849 ;THIS IRP DEFINES THE FIELDS AT ASSEMBLY TIME
\r
10851 CHANLNT==4 ;INITIAL CHANNEL LENGTH
\r
10853 ; BUILD A PROTOTYPE CHANNEL AND DEFINE FILEDS
\r
10854 BUFRIN==-1 ;SPECIAL HACK SO LOSERS WON'T SEE TTY BUFFER
\r
10855 SCRPTO==-3 ;SPECIAL HACK FOR SCRIPT CHANNELS
\r
10858 IRP A,,[[CHANNO,FIX],[DIRECT,CHSTR]
\r
10859 [NAME1,CHSTR],[NAME2,CHSTR],[DEVICE,CHSTR],[SNAME,CHSTR]
\r
10860 [RNAME1,CHSTR],[RNAME2,CHSTR],[RDEVIC,CHSTR],[RSNAME,CHSTR]
\r
10861 [STATUS,FIX],[IOINS,FIX],[LINLN,FIX],[CHRPOS,FIX],[PAGLN,FIX],[LINPOS,FIX]
\r
10862 [ACCESS,FIX],[RADX,FIX],[BUFSTR,CHSTR]]
\r
10870 CHANLNT==CHANLNT+2
\r
10874 ; EQUIVALANCES FOR CHANNELS
\r
10880 DISINF==BUFSTR ;DISPLAY INFO
\r
10881 INTFCN==BUFSTR ;FUNCTION (OR SUBR, OR RSUBR) TO BE APPLIED FOR INTERNAL CHNLS
\r
10884 ;DEFINE VARIABLES ASSOCIATED WITH TTY BUFFERS
\r
10886 IRP A,,[IOIN2,ECHO,CHRCNT,ERASCH,KILLCH,BRKCH,ESCAP,SYSCHR,BRFCHR,BRFCH2,BYTPTR]
\r
10890 EXTBFR==BYTPTR+1+<100./5> ;LENGTH OF ADD'L BUFFER
\r
10895 .GLOBAL IPNAME,MOPEN,MCLOSE,MIOT,ILOOKU,6TOCHS,ICLOS,OCLOS,RGPARS,RGPRS
\r
10896 .GLOBAL OPNCHN,CHMAK,READC,TYO,SYSCHR,BRFCHR,LSTCH,BRFCH2,EXTBFR
\r
10897 .GLOBAL CHRWRD,STRTO6,TTYBLK,WAITNS,EXBUFR,TTICHN,TTOCHN,GETCHR
\r
10898 .GLOBAL CHANNO,STATUS,LINPOS,PAGLN,CHRPOS,LINLN,IOINS,ACCESS
\r
10899 .GLOBAL DIRECT,DISINF,RADX,EOFCND,BUFSTR,MODE1,MODE2,GCHACK,GMTYO
\r
10900 .GLOBAL T.CHAN,NAME1,BFCLOS,DOIOTI,DOIOTO,DOACCS,NOTTY,BYTDOP,TNXIN
\r
10901 .GLOBAL DISOPN,DISROP,DISCLS,DCHAR,DISLNL,DISPGL,INSTAT,MTYO
\r
10902 .GLOBAL ECHO,ERASCH,KILLCH,BRKCH,BYTPTR,SYSCHR,CHRCNT,ESCAP,N.CHNS
\r
10903 .GLOBAL REOPN,QUITTE,CHNL0,CHNL1,BUFRIN,IOIN2,IFALSE,GFALS,IDVAL
\r
10904 .GLOBAL BADCHN,WRONGD,CHNCLS,GSNAME,GIBLOK,APLQ,NAPT,ICONS,INCONS,IBLOCK,IDVAL1
\r
10905 .GLOBAL GRB,GWB,R1CHAR,W1CHAR,BFCLS1,TTYOP2,MPOPJ,COMPER,R1C,W1C,WXCT,RXCT
\r
10906 .GLOBAL TMTNXS,TNXSTR,RDEVIC
\r
10911 ; PAIR MOVING MACRO
\r
10913 DEFINE PMOVEM A,B
\r
10920 ; DEFINITIONS OF THE OFFSETS INTO THE TP STACK FOR OPEN
\r
10922 T.SPDL==0 ; SAVES P STACK BASE
\r
10923 T.DIR==2 ; CONTAINS DIRECTION AND MODE
\r
10924 T.NM1==4 ; NAME 1 OF FILE
\r
10925 T.NM2==6 ; NAME 2 OF FILE
\r
10926 T.DEV==10 ; DEVICE NAME
\r
10927 T.SNM==12 ; SNAME
\r
10928 T.XT==14 ; EXTRA CRUFT IF NECESSARY
\r
10929 T.CHAN==16 ; CHANNEL AS GENERATED
\r
10931 ; OFFSETS FROM PSTACK BASE (USED FOR OPENS, .RCHST AND .FDELES)
\r
10933 S.DIR==0 ; CODE FOR DIRECTION 0-IN, 1-OUT, 2-BIN, 3-BOUT,4-DISPLAY
\r
10935 S.DEV==1 ; SIXBIT DEVICE RIGHT JUSTIFIED
\r
10936 S.NM1==2 ; SIXBIT NAME1
\r
10937 S.NM2==3 ; SIXBIT NAME2
\r
10938 S.SNM==4 ; SIXBIT SNAME
\r
10952 ; FLAGS SPECIFYING STATE OF THE WORLD AT VARIOUS TIMES
\r
10954 NOSTOR==400000 ; ON MEANS DONT BUILD NEW STRINGS
\r
10955 MSTNET==200000 ; ON MEANS ONLY THE "NET" DEVICE CAN WIN
\r
10956 SNSET==100000 ; FLAG, SNAME SUPPLIED
\r
10957 DVSET==040000 ; FLAG, DEV SUPPLIED
\r
10958 N2SET==020000 ; FLAG, NAME2 SET
\r
10959 N1SET==010000 ; FLAG, NAME1 SET
\r
10961 RMT [EXPUNGE N1SET,N2SET,DVSET,SNSET,MSTNET,NOSTOR
\r
10965 ; TABLE OF LEGAL MODES
\r
10967 MODES: IRP A,,[READ,PRINT,READB,PRINTB,DISPLAY]
\r
10972 ; TABLE OF KNOWN DEVICES AND A POINTER TO THEIR OPENERS
\r
10976 DEVS: IRP A,,[DSK,TPL,SYS,COM,TTY,USR,STY,[ST ],NET,DIS,E&S,INT,PTP,PTR
\r
10977 [P ],[DK ],[UT ],[T ],NUL,[AI ]
\r
10978 [ML ],[DM ],[AR ],ARC]B,,[ODSK,ODSK,ODSK,ODSK,OTTY,OUSR,OSTY,OSTY,ONET,ODIS,ODIS
\r
10979 OINT,OPTP,OPTP,ODSK,ODSK,OUTN,OTTY,ONUL,ODSK,ODSK,ODSK,ODSK,ODSK]
\r
10984 DEVS: IRP A,,[DSK,TTY,INT,NET]B,,[ODSK,OTTY,OINT,ONET]
\r
10992 ;SUBROUTINE TO DO OPENING BEGINS HERE
\r
10994 MFUNCTION NFOPEN,SUBR,[OPEN-NR]
\r
10998 MFUNCTION FOPEN,SUBR,[OPEN]
\r
11001 PUSHJ P,MAKCHN ;MAKE THE CHANNEL
\r
11002 PUSHJ P,OPNCH ;NOW OPEN IT
\r
11005 ; SUBR TO JUST CREATE A CHANNEL
\r
11007 MFUNCTION CHANNEL,SUBR
\r
11017 ; THIS ROUTINE PARSES ARGUMENTS TO FOPEN ETC. AND BUILDS A CHANNEL BUT DOESN'T OPEN IT
\r
11019 MAKCHN: PUSH TP,$TPDL
\r
11020 PUSH TP,P ; POINT AT CURRENT STACK BASE
\r
11022 PUSH TP,CHQUOTE READ
\r
11023 MOVEI E,10 ; SLOTS OF TP NEEDED
\r
11027 EXCH E,(P) ; GET RET ADDR IN E
\r
11028 IFE ITS, PUSH P,[0]
\r
11029 IRP ATM,,[DEV,NM1,NM2,SNM]MDF,,[DSK,INPUT,>,[ ]]TMDF,,[DSK,INPUT,MUD,[ ]]
\r
11030 MOVE B,IMQUOTE ATM
\r
11031 IFN ITS, PUSH P,E
\r
11038 IFN ITS, MOVE B,CHQUOTE MDF
\r
11039 IFE ITS, MOVE B,CHQUOTE TMDF
\r
11041 MOVEM A,T.!ATM(TB)
\r
11042 MOVEM B,T.!ATM+1(TB)
\r
11045 PUSHJ P,STRTO6 ; RESULT LEFT ON P STACK AS DESIRED
\r
11048 PUSH TP,[0] ; PUSH SLOTS
\r
11051 PUSH P,[0] ; EXT SLOTS
\r
11054 PUSH P,E ; PUSH RETURN ADDRESS
\r
11057 JUMPGE AB,MAKCH0 ; NO ARGS, ALREADY DONE
\r
11058 GETYP 0,(AB) ; 1ST ARG MUST BE A STRING
\r
11061 MOVE A,(AB) ; GET ARG
\r
11063 PUSHJ P,CHMODE ; CHECK OUT OPEN MODE
\r
11065 PMOVEM (AB),T.DIR(TB) ; SAVE MODE NAME IN TEMPS
\r
11066 ADD AB,[2,,2] ; BUMP PAST DIRECTION
\r
11068 JUMPGE AB,MAKCH0 ; CHECK NAME1 BASED ON JUST MODE
\r
11070 MOVEI 0,0 ; FLAGS PRESET
\r
11071 PUSHJ P,RGPARS ; PARSE THE STRING(S)
\r
11074 ; ARGUMENTS PARSED, DO FINAL CHECKS AND BUILD CHANNEL
\r
11078 MOVE C,T.SPDL+1(TB)
\r
11079 HLRZS D,S.DEV(C) ; GET DEV
\r
11083 MOVE B,T.DEV+1(TB)
\r
11087 MOVE C,T.SPDL+1(TB)
\r
11090 CAIE D,(SIXBIT /INT/); INTERNAL?
\r
11091 JRST CHNET ; NO, MAYBE NET
\r
11092 SKIPN T.XT+1(TB) ; WAS FCN SUPPLIED?
\r
11095 ; FALLS TROUGH IF SKIP
\r
11099 ; NOW BUILD THE CHANNEL
\r
11101 ARGSOK: MOVEI A,CHANLNT ; GET LENGTH
\r
11102 PUSHJ P,GIBLOK ; GET A BLOCK OF STUFF
\r
11103 ADD B,[4,,4] ; HIDE THE TTY BUFFER SLOT
\r
11106 HRLI C,PROCHN ; POINT TO PROTOTYPE
\r
11107 HRRI C,(B) ; AND NEW ONE
\r
11108 BLT C,CHANLN-5(B) ; CLOBBER
\r
11109 MOVSI C,TLIST ; TO GIVE HIM A CLEAN LIST OF SCRIPT CHANS
\r
11110 MOVEM C,SCRPTO-1(B)
\r
11112 ; NOW BLT IN STUFF FROM THE STACK
\r
11114 MOVSI C,T.DIR(TB) ; DIRECTION
\r
11115 HRRI C,DIRECT-1(B)
\r
11117 MOVEI C,RNAME1-1(B) ; NOW "REAL" SLOTS
\r
11122 ; HERE TO VALIDIFY ARGUMENTS FOR A NET OPEN
\r
11124 CHNET: CAIE D,(SIXBIT /NET/) ; IS IT NET
\r
11125 IFN ITS, JRST MAKCH1
\r
11129 MOVSI D,TFIX ; FOR TYPES
\r
11130 MOVEI B,T.NM1(TB) ; MAKE SURE ALL ARE FIXED
\r
11132 MOVEI B,T.NM2(TB)
\r
11134 MOVEI B,T.SNM(TB)
\r
11135 LSH A,-1 ; SKIP DEV FLAG
\r
11139 MAKCH1: TRNN A,MSTNET ; CANT HAVE SEEN A FIX
\r
11144 CHFIX: TRNE A,N1SET ; SKIP IF NOT SPECIFIED
\r
11147 SETOM 1(B) ; SET TO -1
\r
11149 MOVEM D,(B) ; CORRECT TYPE
\r
11154 CHFIX1: ADDI C,1 ; POINT TO NEXT FIELD
\r
11155 LSH A,-1 ; AND NEXT FLAG
\r
11157 PARSQ: CAIE 0,TCHSTR
\r
11181 ; SUBROUTINE TO CHECK VALIDITY OF MODE AND SAVE A CODE
\r
11183 CHMODE: PUSHJ P,CHMOD ; DO IT
\r
11184 MOVE C,T.SPDL+1(TB)
\r
11188 CHMOD: PUSHJ P,STRTO6 ; TO SIXBIT
\r
11189 POP P,B ; VALUE ENDSUP ON STACK, RESTORE IT
\r
11191 CAME B,[SIXBIT /PRINTO/] ; KLUDGE TO MAKE PRINTO AS PRINTB
\r
11193 MOVEI A,3 ; CODE FOR PRINTB
\r
11196 MOVSI A,-NMODES ; SCAN TO SEE IF LEGAL MODE
\r
11199 JUMPGE A,WRONGD ; ILLEGAL MODE NAME
\r
11203 ; RGPARS -- PARSE THE STRINGS COMPRISING FILE NAMES INTO STANDARD ITS GOODIES
\r
11205 RGPRS: MOVEI 0,NOSTOR ; DONT STORE STRINGS IF ENTER HERE
\r
11207 RGPARS: HRLM 0,(P) ; LH IS FLAGS FOR THIS PROG
\r
11208 MOVSI E,-4 ; FIELDS TO FILL
\r
11210 RPARGL: GETYP 0,(AB) ; GET TYPE
\r
11211 CAIE 0,TCHSTR ; STRING?
\r
11212 JRST ARGCLB ; NO, JUST CLOBBER IT IN RAW
\r
11213 JUMPGE E,CPOPJ ; DON'T DO ANY MORE
\r
11214 PUSH TP,(AB) ; GET AN ARG
\r
11217 FPARS: PUSH TP,-1(TP) ; ANOTHER COPY
\r
11219 PUSHJ P,FLSSP ; NO LEADING SPACES
\r
11220 MOVEI A,0 ; WILL HOLD SIXBIT
\r
11221 MOVEI B,6 ; CHARS PER 6BIT WORD
\r
11222 MOVE C,[440600,,A] ; BYTE POINTER INTO A
\r
11224 FPARSL: HRRZ 0,-1(TP) ; GET COUNT
\r
11225 JUMPE 0,PARSD ; DONE
\r
11226 SOS -1(TP) ; COUNT
\r
11227 ILDB 0,(TP) ; CHAR TO 0
\r
11229 CAIE 0,"
\11 ; FILE NAME QUOTE?
\r
11234 ILDB 0,(TP) ; USE THIS
\r
11237 NOCNTQ: CAIG 0,40 ; SPACE?
\r
11238 JRST NDFLD ; YES, TERMINATE THIS FIELD
\r
11239 CAIN 0,": ; DEVICE ENDED?
\r
11241 CAIN 0,"; ; SNAME ENDED
\r
11244 GOTCNQ: PUSHJ P,A0TO6 ; CONVERT TO 6BIT AND CHECK
\r
11246 JUMPE B,FPARSL ; IGNORE IF AREADY HAVE 6
\r
11250 ; HERE IF SPACE ENCOUNTERED
\r
11252 NDFLD: MOVEI D,(E) ; COPY GOODIE
\r
11253 PUSHJ P,FLSSP ; FLUSH REDUNDANT SPACES
\r
11254 JUMPE 0,PARSD ; NO CHARS LEFT
\r
11256 NFL0: PUSH P,A ; SAVE SIXBIT WORD
\r
11257 PUSHJ P,6TOCHS ; CONVERT TO STRING
\r
11258 HRRZ 0,-1(TP) ; RESTORE CHAR COUNT
\r
11260 NFL2: MOVEI C,(D) ; COPY REL PNTR
\r
11261 SKIPGE -1(P) ; SKIP IF STRINGS TO BE STORED
\r
11263 ASH D,1 ; TIMES 2
\r
11265 MOVEM A,(D) ; STORE
\r
11267 NFL3: MOVSI A,N1SET ; FLAG IT
\r
11269 IORM A,-1(P) ; AND CLOBBER
\r
11270 MOVE D,T.SPDL+1(TB) ; GET P BASE
\r
11271 POP P,@SIXTBL(C) ; AND STORE SIXBIT OF IT
\r
11273 POP TP,-2(TP) ; MAKE NEW STRING POINTER
\r
11275 JUMPE 0,.+3 ; SKIP IF NO MORE CHARS
\r
11276 AOBJN E,FPARS ; MORE TO PARSE?
\r
11277 CPOPJ: POPJ P, ; RETURN, ALL DONE
\r
11279 SUB TP,[2,,2] ; FLUSH OLD STRING
\r
11281 ADD AB,[2,,2] ; BUMP ARG
\r
11282 JUMPL AB,RPARGL ; AND GO ON
\r
11283 CPOPJ1: AOS A,(P) ; PREPARE TO WIN
\r
11289 ; HERE IF STRING HAS ENDED
\r
11291 PARSD: PUSH P,A ; SAVE 6 BIT
\r
11292 MOVE A,-3(TP) ; CAN USE ARG STRING
\r
11295 JRST NFL2 ; AND CONTINUE
\r
11297 ; HERE IF JUST READ DEV
\r
11299 GOTDEV: MOVEI D,2 ; CODE FOR DEVICE
\r
11300 JRST GOTFLD ; GOT A FIELD
\r
11302 ; HERE IF JUST READ SNAME
\r
11304 GOTSNM: MOVEI D,3
\r
11305 GOTFLD: PUSHJ P,FLSSP
\r
11309 ; HERE FOR NON STRING ARG ENCOUNTERED
\r
11311 ARGCLB: SKIPGE (P) ; IF NOT STORING, CONSIDER THIS THE END
\r
11314 MOVE C,T.SPDL+1(TB) ; GET P-BASE
\r
11315 HLRZ A,S.DEV(C) ; GET DEVICE
\r
11316 CAIE A,(SIXBIT /INT/) ; IS IT THE INTERNAL DEVICE
\r
11317 JRST TRYNET ; NO, COUD BE NET
\r
11318 MOVE A,0 ; OFFNEDING TYPE TO A
\r
11319 PUSHJ P,APLQ ; IS IT APPLICABLE
\r
11320 JRST NAPT ; NO, LOSE
\r
11321 PMOVEM (AB),T.XT(TB)
\r
11322 ADD AB,[2,,2] ; MUST BE LAST ARG
\r
11324 JRST CPOPJ1 ; ELSE SUCCESSFUL RETURN
\r
11325 TRYNET: CAIE 0,TFIX ; FOR NET DEV, ARGS MUST BE FIX
\r
11326 JRST WRONGT ; TREAT AS WRONG TYPE
\r
11327 MOVSI A,MSTNET ; BETTER BE NET EVENTUALLY
\r
11328 IORM A,(P) ; STORE FLAGS
\r
11330 MOVE B,1(AB) ; GET NUMBER
\r
11331 MOVEI 0,(E) ; MAKE SURE NOT DEVICE
\r
11334 PUSH P,B ; SAVE NUMBER
\r
11335 MOVEI D,(E) ; SET FOR TABLE OFFSETS
\r
11338 JRST NFL2 ; GO CLOBBER IT AWAY
\r
11342 ; ROUTINE TO FLUSH LEADING SPACES FROM A FIELD
\r
11344 FLSSP: HRRZ 0,-1(TP) ; GET CHR COUNNT
\r
11345 JUMPE 0,CPOPJ ; FINISHED STRING
\r
11346 FLSS1: MOVE B,(TP) ; GET BYTR
\r
11347 ILDB C,B ; GETCHAR
\r
11350 MOVEM B,(TP) ; UPDATE BYTE POINTER
\r
11353 FLSS2: HRRM 0,-1(TP) ; UPDATE STRING
\r
11357 ;TABLE FOR STFUFFING SIXBITS AWAY
\r
11375 ; TENEX VERSION OF FILE NAME PARSER (ONLY ACCEPT ARGS IN SINGLE STRING)
\r
11377 RGPRS: MOVEI 0,NOSTOR
\r
11379 RGPARS: HRLM 0,(P) ; SAVE FOR STORE CHECKING
\r
11380 CAMGE AB,[-7,,] ; MULTI-STRING CASE POSSIBLE?
\r
11381 JRST TN.MLT ; YES, GO PROCESS
\r
11382 RGPRSS: GETYP 0,(AB) ; CHECK ARG TYPE
\r
11384 JRST WRONGT ; FOR NOW ONLY STRING ARGS WIN
\r
11387 PUSHJ P,FLSSP ; FLUSH LEADING SPACES
\r
11390 CHKLST: JUMPGE AB,CPOPJ1
\r
11391 SKIPGE (P) ; IF FROM OPEN, ALLOW ONE MORE
\r
11393 PMOVEM (AB),T.XT(TB)
\r
11399 RGPRS1: PUSH P,[0] ; ALLOW A DEVICE SPEC
\r
11400 TN.SNM: MOVE A,(TP)
\r
11404 CAIE A,"< ; START "DIRECTORY" ?
\r
11405 JRST TN.N1 ; NO LOOK FOR NAME1
\r
11406 SETOM (P) ; DEV NOT ALLOWED
\r
11407 IBP (TP) ; SKIP CHAR
\r
11409 PUSHJ P,TN.CNT ; COUNT CHARS TO ">"
\r
11410 JUMPE B,ILLNAM ; RAN OUT
\r
11411 CAIE A,"> ; SKIP IF WINS
\r
11413 PUSHJ P,TN.CPS ; COPY TO NEW STRING
\r
11414 MOVEM A,T.SNM(TB)
\r
11415 MOVEM B,T.SNM+1(TB)
\r
11417 TN.N1: PUSHJ P,TN.CNT
\r
11419 CAIE A,": ; GOT A DEVICE
\r
11425 MOVEM A,T.DEV(TB)
\r
11426 MOVEM B,T.DEV+1(TB)
\r
11427 JRST TN.SNM ; NOW LOOK FOR SNAME
\r
11429 TN.N11: CAIE A,">
\r
11432 MOVEM A,(P) ; SAVE END CHAR
\r
11433 PUSHJ P,TN.CPS ; GEN STRING
\r
11434 MOVEM A,T.NM1(TB)
\r
11435 MOVEM B,T.NM1+1(TB)
\r
11437 TN.N2: SKIPN A,(P) ; GET CHAR BACK
\r
11439 CAIN A,"; ; START VERSION?
\r
11441 CAIE A,". ; START NAME2?
\r
11442 JRST ILLNAM ; I GIVE UP!!!
\r
11443 HRRZ B,-1(TP) ; GET RMAINS OF STRING
\r
11444 PUSHJ P,TN.CPS ; AND COPY IT
\r
11445 MOVEM A,T.NM2(TB)
\r
11446 MOVEM B,T.NM2+1(TB)
\r
11447 RPDONE: SUB P,[1,,1] ; FLUSH TEMP
\r
11451 TN.CNT: HRRZ 0,-1(TP) ; CHAR COUNT
\r
11452 MOVE C,(TP) ; BPTR
\r
11453 MOVEI B,0 ; INIT COUNT TO 0
\r
11455 TN.CN1: MOVEI A,0 ; IN CASE RUN OUT
\r
11456 SOJL 0,CPOPJ ; RUN OUT?
\r
11457 ILDB A,C ; TRY ONE
\r
11458 CAIE A,"
\16 ; TNEX FILE QUOTE?
\r
11461 IBP C ; SKIP QUOTED CHAT
\r
11465 TN.CN2: CAIE A,"<
\r
11476 TN.CPS: PUSH P,B ; # OF CHARS
\r
11477 MOVEI A,4(B) ; ADD 4 TO B IN A
\r
11479 PUSHJ P,IBLOCK ; GET BLOCK OF WORDS FOR STRING
\r
11481 POP P,C ; CHAR COUNT BACK
\r
11484 HRRI A,(C) ; CHAR STRING
\r
11485 MOVE D,B ; COPY BYTER
\r
11488 ILDB 0,(TP) ; GET CHAR
\r
11489 IDPB 0,D ; AND STROE
\r
11492 MOVNI C,(A) ; - LENGTH TO C
\r
11493 ADDB C,-1(TP) ; DECREMENT WORDS COUNT
\r
11494 TRNN C,-1 ; SKIP IF EMPTY
\r
11497 SOS -1(TP) ; ELSE FLUSH TERMINATOR
\r
11500 ILLNAM: PUSH TP,$TATOM
\r
11501 PUSH TP,EQUOTE ILLEGAL-TENEX-FILE-NAME
\r
11504 TN.MLT: MOVEI A,(AB)
\r
11507 TN.ML1: GETYP 0,(A)
\r
11511 JRST RGPRSS ; ASSUME SINGLE STRING
\r
11515 MOVEI A,T.NM1(TB)
\r
11517 BLT A,T.SNM+1(TB) ; BLT 'EM IN
\r
11518 ADD AB,[10,,10] ; SKIP THESE GUYS
\r
11524 ; ROUTINE TO OPEN A CHANNEL FOR ANY DEVICE. NAMES ARE ASSUMED TO ALREADY
\r
11525 ; BE ON BOTH TP STACK AND P STACK
\r
11527 OPNCH: MOVE C,T.SPDL+1(TB) ; GET PDL BASE
\r
11529 ANDI A,1 ; JUST WANT I AND O
\r
11531 ; .TRANS S.DEV(C) ; UNDO ANY TRANSLATIONS
\r
11532 ; JRST TRLOST ; COMPLAIN
\r
11534 HRRZ A,S.DEV(C) ; GET SIXBIT DEVICE CODE
\r
11535 MOVEI E,(A) ; COPY TO E
\r
11536 ANDI E,777700 ; WITHOUT LAST
\r
11537 MOVEI D,(E) ; AND D
\r
11538 ANDI D,770000 ; WITH JUST LETTER
\r
11539 MOVSI B,-NDEVS ; AOBJN COUNTER
\r
11541 DEVLP: HRRZ 0,DEVS(B) ; GET ONE
\r
11542 CAIN 0,(A) ; FULL DEV?
\r
11544 CAIN 0,(D) ; ONE LETTER
\r
11546 CAIN 0,(E) ; 2 LTTERS
\r
11548 NXTDEV: AOBJN B,DEVLP ; LOOP THRU
\r
11551 OUSR: HRRZ A,S.DIR(C) ; BLOCK OR UNIT?
\r
11552 TRNE A,2 ; SKIP IF UNIT
\r
11554 PUSHJ P,OPEN1 ; OPEN IT
\r
11555 PUSHJ P,FIXREA ; AND READCHST IT
\r
11556 MOVE B,T.CHAN+1(TB) ; RESTORE CHANNEL
\r
11557 MOVE 0,[PUSHJ P,DOIOT] ; GET AN IOINS
\r
11559 MOVE C,T.SPDL+1(TB)
\r
11567 OSTY: HLRZ A,S.DEV(C)
\r
11568 IORI A,10 ; THE DONT LOSE BIT (DONT HANG ON INPUT DO ON OUTPUT)
\r
11574 PUSH TP,EQUOTE NO-SUCH-DEVICE?
\r
11578 ; MAKE SURE DIGITS EXIST
\r
11580 CH2DIG: LDB 0,[60600,,A]
\r
11581 CAIG 0,'9 ; CHECK DIGITNESS
\r
11583 JRST NXTDEV ; LOSER
\r
11585 CH1DIG: LDB 0,[600,,A] ; LAST CHAR
\r
11590 ; HERE TO DISPATCH IF SUCCESSFUL
\r
11592 DISPA: HLRZ B,DEVS(B)
\r
11594 HRRZ A,S.DIR(C) ; GET DIR OF OPEN
\r
11595 CAIN A,5 ; IS IT DISPLAY
\r
11596 CAIN B,ODIS ; BETTER BE OPENING DISPLAY
\r
11597 JRST (B) ; GO TO HANDLER
\r
11600 IFE ITS, JRST (B)
\r
11605 ; DISK DEVICE OPNER COME HERE
\r
11607 ODSK: MOVE A,S.SNM(C) ; GET SNAME
\r
11608 .SUSET [.SSNAM,,A] ; CLOBBER IT
\r
11609 PUSHJ P,OPEN0 ; DO REAL LIVE OPEN
\r
11613 ; TENEX DISK FILE OPENER
\r
11615 ODSK: MOVE B,T.CHAN+1(TB) ; GET CHANNEL
\r
11616 PUSHJ P,STSTK ; EXPAND STRING ONTO STACK (E POINTS TO OLD P)
\r
11617 MOVE A,DIRECT-1(B)
\r
11619 PUSHJ P,STRTO6 ; GET DIR NAME
\r
11621 MOVE D,T.SPDL+1(TB)
\r
11623 CAMN C,[SIXBIT /PRINTO/]
\r
11624 IORI D,100 ; TURN ON BIT TO SAY USE OLD FILE
\r
11625 MOVSI A,101 ; START SETTING UP BITS EXTRA BIT FOR MSB
\r
11626 TRNE D,1 ; SKIP IF INPUT
\r
11627 TRNE D,100 ; WITE OVER?
\r
11628 TLOA A,100000 ; FORCE NEW VERSION
\r
11629 TLO A,400000 ; FORCE OLD
\r
11630 HRROI B,1(E) ; POIT TO STRING
\r
11632 TDZA 0,0 ; SAVE FACT OF NO SKIP
\r
11633 MOVEI 0,1 ; INDICATE SKIPPED
\r
11634 MOVE P,E ; RESTORE PSTACK
\r
11635 JUMPE 0,GTJLOS ; FIND OUT WHAT HAPPENED
\r
11637 MOVE B,T.CHAN+1(TB) ; GET CHANNEL
\r
11638 HRRZM A,CHANNO(B) ; SAVE IT
\r
11639 ANDI A,-1 ; READ Y TO DO OPEN
\r
11640 MOVSI B,440000 ; USE 36. BIT BYES
\r
11641 HRRI B,200000 ; ASSUME READ
\r
11642 TRNE D,1 ; SKIP IF READ
\r
11643 HRRI B,300000 ; WRITE BIT
\r
11644 HRRZ 0,FSAV(TB) ; SEE IF REF DATE HACK
\r
11646 TRO B,400 ; SET DON'T MUNG REF DATE BIT
\r
11649 MOVEI 0,C.OPN+C.READ
\r
11650 TRNE D,1 ; SKIP FOR READ
\r
11651 MOVEI 0,C.OPN+C.PRIN
\r
11652 MOVE B,T.CHAN+1(TB)
\r
11653 HRRM 0,-4(B) ; MUNG THOSE BITS
\r
11654 ASH A,1 ; POINT TO SLOT
\r
11655 ADDI A,CHNL0(TVP) ; TO REAL SLOT
\r
11656 MOVEM B,1(A) ; SAVE CHANNEL
\r
11657 PUSHJ P,TMTNXS ; GET STRING FROM TENEX
\r
11658 MOVE B,CHANNO(B) ; JFN TO A
\r
11659 HRROI A,1(E) ; BASE OF STRING
\r
11660 MOVE C,[111111,,140001] ; WEIRD CONTROL BITS
\r
11661 JFNS ; GET STRING
\r
11662 MOVEI B,1(E) ; POINT TO START OF STRING
\r
11663 SUBM P,E ; RELATIVIZE E
\r
11664 PUSHJ P,TNXSTR ; MAKE INTO A STRING
\r
11665 SUB P,E ; BACK TO NORMAL
\r
11668 PUSHJ P,RGPRS1 ; PARSE INTO FIELDS
\r
11669 MOVE B,T.CHAN+1(TB)
\r
11670 MOVEI C,RNAME1-1(B)
\r
11674 OPFLOS: MOVEI C,(A) ; SAVE ERROR CODE
\r
11675 MOVE B,T.CHAN+1(TB)
\r
11676 HRRZ A,CHANNO(B) ; JFN BACK TO A
\r
11677 RLJFN ; TRY TO RELEASE IT
\r
11679 MOVEI A,(C) ; ERROR CODE BACK TO A
\r
11681 GTJLOS: PUSHJ P,TGFALS ; GET A FALSE WITH REASON
\r
11684 STSTK: PUSH TP,$TCHAN
\r
11686 MOVEI A,4+5 ; COUNT CHARS NEEDED (NEED LAST 0 BYTE)
\r
11688 ADD A,RDEVIC-1(B)
\r
11689 ADD A,RNAME1-1(B)
\r
11690 ADD A,RNAME2-1(B)
\r
11691 ADD A,RSNAME-1(B)
\r
11692 ANDI A,-1 ; TO 18 BITS
\r
11693 IDIVI A,5 ; TO WORDS NEEDED
\r
11694 POP P,C ; SAVE RET ADDR
\r
11695 MOVE E,P ; SAVE POINTER
\r
11696 PUSH P,[0] ; ALOCATE SLOTS
\r
11698 PUSH P,C ; RET ADDR BACK
\r
11699 INTGO ; IN CASE OVERFLEW
\r
11700 MOVE B,(TP) ; IN CASE GC'D
\r
11701 MOVE D,[440700,,1(E)] ; BYTE POINTER TO IT
\r
11702 MOVEI A,RDEVIC-1(B)
\r
11703 PUSHJ P,MOVSTR ; FLUSH IT ON
\r
11706 HRRZ A,RSNAME-1(B) ; ANY SNAME AT ALL?
\r
11707 JUMPE A,ST.NM1 ; NOPE, CANT HACK WITH IT
\r
11710 MOVEI A,RSNAME-1(B)
\r
11711 PUSHJ P,MOVSTR ; SNAME UP
\r
11714 MOVEI A,RNAME1-1(B)
\r
11718 ST.NM1: MOVEI A,RNAME2-1(B)
\r
11723 MOVSTR: HRRZ 0,(A) ; CHAR COUNT
\r
11724 MOVE A,1(A) ; BYTE POINTER
\r
11726 ILDB C,A ; GET CHAR
\r
11727 IDPB C,D ; MUNG IT UP
\r
11730 ; MAKE A TENEX ERROR MESSAGE STRING
\r
11732 TGFALS: PUSH P,A ; SAVE ERROR CODE
\r
11733 PUSHJ P,TMTNXS ; STRING ON STACK
\r
11734 HRROI A,1(E) ; POINT TO SPACE
\r
11735 MOVE B,(E) ; ERROR CODE
\r
11736 HRLI B,400000 ; FOR ME
\r
11737 MOVSI C,-100. ; MAX CHARS
\r
11738 ERSTR ; GET TENEX STRING
\r
11742 MOVEI B,1(E) ; A AND B BOUND STRING
\r
11743 SUBM P,E ; RELATIVIZE E
\r
11744 PUSHJ P,TNXSTR ; BUILD STRING
\r
11745 SUB P,E ; P BACK TO NORMAL
\r
11746 TGFLS2: SUB P,[1,,1] ; FLUSH ERROR CODE SLOT
\r
11749 PUSHJ P,INCONS ; BUILD LIST
\r
11750 MOVSI A,TFALSE ; MAKE IT FALSE
\r
11753 TGFLS1: MOVE P,E ; RESET STACK
\r
11755 MOVE B,CHQUOTE UNKNOWN PROBLEM IN I/O
\r
11759 ; OTHER BUFFERED DEVICES JOIN HERE
\r
11763 PUSHJ P,FIXREA ; STORE THE "REAL" NAMES INTO THE CHANNEL
\r
11765 OPBASC: MOVE C,T.SPDL+1(TB) ; C WAS CLOBBERED, GET IT BACK
\r
11766 HRRZ A,S.DIR(C) ; FIND OUT IF OPEN IS ASCII OR WORD
\r
11767 TRZN A,2 ; SKIP IF BINARY
\r
11768 PUSHJ P,OPASCI ; DO IT FOR ASCII
\r
11770 ; NOW SET UP IO INSTRUCTION FOR CHANNEL
\r
11772 MAKION: MOVE B,T.CHAN+1(TB)
\r
11774 JUMPE A,MAKIO1 ; JUMP IF INPUT
\r
11775 MOVEI C,PUTCHR ; ELSE GET INPUT
\r
11776 MOVEI 0,80. ; DEFAULT LINE LNTH
\r
11779 MOVEM 0,LINLN-1(B)
\r
11781 HRLI C,(PUSHJ P,)
\r
11782 MOVEM C,IOINS(B) ; STORE IT
\r
11783 JUMPN A,OPNWIN ; GET AN EOF FORM FOR INPUT CHANNEL
\r
11785 ; HERE TO CONS UP <ERROR END-OF-FILE>
\r
11787 EOFMAK: MOVSI C,TATOM
\r
11788 MOVE D,EQUOTE END-OF-FILE
\r
11792 MOVE D,IMQUOTE ERROR
\r
11794 MOVE D,T.CHAN+1(TB) ; RESTORE CHANNEL
\r
11796 MOVEM 0,EOFCND-1(D)
\r
11797 MOVEM B,EOFCND(D)
\r
11799 OPNWIN: MOVEI 0,10. ; SET UP RADIX
\r
11800 MOVSI A,TCHAN ; OPEN SUCCEEDED, RET CHANNEL
\r
11801 MOVE B,T.CHAN+1(TB)
\r
11804 OPNRET: MOVE C,(P) ; RET ADDR
\r
11805 SUB P,[S.X3+2,,S.X3+2]
\r
11806 SUB TP,[T.CHAN+2,,T.CHAN+2]
\r
11810 ; HERE TO CREATE CHARACTER BUFFERS FOR ASCII I/O
\r
11812 OPASCI: PUSH P,A ; CONTAINS MODE, SAVE IT
\r
11813 MOVEI A,BUFLNT ; GET SIZE OF BUFFER
\r
11814 PUSHJ P,IBLOCK ; GET STORAGE
\r
11815 MOVSI 0,TWORD+.VECT. ; SET UTYPE
\r
11816 MOVEM 0,BUFLNT(B) ; AND STORE
\r
11818 SKIPE (P) ; SKIP IF INPUT
\r
11820 MOVEI D,BUFLNT(B) ; REST BYTE POINTER
\r
11821 OPASCA: HRLI D,440700
\r
11822 MOVE B,T.CHAN+1(TB) ; GET CHANNEL BACK
\r
11824 IORM 0,-4(B) ; TURN ON BUFFER BIT
\r
11825 MOVEM A,BUFSTR-1(B)
\r
11826 MOVEM D,BUFSTR(B) ; CLOBBER
\r
11830 OPASCO: HRROI C,777776
\r
11831 MOVEM C,(B) ; -1 THE BUFFER (LEAVE OFF LOW BIT)
\r
11833 HRRI C,1(B) ; BUILD BLT POINTER
\r
11834 BLT C,BUFLNT-1(B) ; ZAP
\r
11835 MOVEI D,(B) ; START MAKING STRING POINTER
\r
11836 HRRI A,BUFLNT*5 ; SET UP CHAR COUNT
\r
11840 ; OPEN NON FILE ORIENTED DEVICES (NUL, PTR, PTP ETC.)
\r
11844 OPTR: PUSHJ P,OPEN0 ; SET UP MODE AND OPEN
\r
11845 SETZM S.NM1(C) ; CLOBBER UNINTERESTING FIELDS
\r
11850 ; OPEN DEVICES THAT IGNORE SNAME
\r
11852 OUTN: PUSHJ P,OPEN0
\r
11856 ; OPEN THE DISPLAY DEVICE
\r
11858 ODIS: MOVEI B,T.DIR(TB) ; GET CHANNEL
\r
11859 PUSHJ P,CHRWRD ; TO ASCII
\r
11861 MOVE E,B ; DIR TO E
\r
11862 MOVE B,T.CHAN+1(TB) ; CHANNEL
\r
11863 MOVE 0,[PUSHJ P,DCHAR] ; IOINS
\r
11867 JRST DISLOS ; LOSER
\r
11869 MOVE D,T.CHAN+1(TB) ; GET CHANNEL
\r
11870 MOVEI 0,C.OPN+C.PRIN
\r
11872 MOVEM A,DISINF-1(D) ; AND STORE
\r
11873 MOVEM B,DISINF(D)
\r
11874 SETZM CHANNO(D) ; NO REAL CHANNEL
\r
11879 MOVEI 0,10. ; SET RADIX
\r
11881 JRST SAVCHN ; ADD TO CHANNEL LIST
\r
11884 ; INTERNAL CHANNEL OPENER
\r
11886 OINT: HRRZ A,S.DIR(C) ; CHECK DIR
\r
11887 CAIL A,2 ; READ/PRINT?
\r
11888 JRST WRONGD ; NO, LOSE
\r
11890 MOVE 0,INTINS(A) ; GET INS
\r
11891 MOVE D,T.CHAN+1(TB) ; AND CHANNEL
\r
11892 MOVEM 0,IOINS(D) ; AND CLOBBER
\r
11893 MOVEI 0,C.OPN+C.READ
\r
11895 MOVEI 0,C.OPN+C.PRIN
\r
11897 SETOM STATUS(D) ; MAKE SURE NOT AA TTY
\r
11898 PMOVEM T.XT(TB),INTFCN-1(D)
\r
11900 ; HERE TO SAVE PSEUDO CHANNELS
\r
11902 SAVCHN: HRRZ E,CHNL0+1(TVP) ; POINT TO CURRENT LIST
\r
11904 PUSHJ P,ICONS ; CONS IT ON
\r
11905 HRRZM B,CHNL0+1(TVP)
\r
11908 ; INT DEVICE I/O INS
\r
11910 INTINS: PUSHJ P,GTINTC
\r
11914 ; HERE TO OPEN THE NET DEVICE (I.E. THE ARPA NET)
\r
11917 ONET: HRRZ A,S.DIR(C) ; DIRECTION CODE
\r
11918 CAILE A,1 ; ASCII ?
\r
11919 IORI A,4 ; TURN ON IMAGE BIT
\r
11920 SKIPGE S.NM1(C) ; NAME1 I.E. LOCAL HOST GIVEN
\r
11921 IORI A,10 ; NO, WE WILL LET ITS GIVE US ONE
\r
11922 SKIPGE S.NM2(C) ; NORMAL OR "LISTEN"
\r
11923 IORI A,20 ; TURN ON LISTEN BIT
\r
11924 MOVEI 0,7 ; DEFAULT BYTE SIZE
\r
11925 TRNE A,2 ; UNLESS
\r
11926 MOVEI 0,36. ; IMAGE WHICH IS 36
\r
11927 SKIPN T.XT(TB) ; BYTE SIZE GIVEN?
\r
11928 MOVEM 0,S.X1(C) ; NO, STORE DEFAULT
\r
11929 SKIPG D,S.X1(C) ; BYTE SIZE REASONABLE?
\r
11930 JRST RBYTSZ ; NO <0, COMPLAIN
\r
11931 TRNE A,2 ; SKIP TO CHECK ASCII
\r
11932 JRST ONET2 ; CHECK IMAGE
\r
11933 CAIN D,7 ; 7-BIT WINS
\r
11935 CAIE D,44 ; 36-BIT INDICATES BLOCK ASCII MODE
\r
11937 IORI A,2 ; SET BLOCK FLAG
\r
11939 IORI A,40 ; USE 8-BIT MODE
\r
11940 CAIN D,10 ; IS IT RIGHT
\r
11944 RBYTSZ: PUSH TP,$TATOM ; CALL ERROR
\r
11945 PUSH TP,EQUOTE BYTE-SIZE-BAD
\r
11949 ONET2: CAILE D,36. ; IMAGE SIZE REASONABLE?
\r
11951 CAIN D,36. ; NORMAL
\r
11952 JRST ONET1 ; YES, DONT SET FIELD
\r
11954 ASH D,9. ; POSITION FOR FIELD
\r
11955 IORI A,40(D) ; SET IT AND ITS BIT
\r
11957 ONET1: HRLM A,S.DEV(C) ; CLOBBER OPEN BLOCK
\r
11958 MOVE E,A ; SAVE BLOCK MODE INFO
\r
11959 PUSHJ P,OPEN1 ; DO THE OPEN
\r
11962 ; CLOBBER REAL SLOTS FOR THE OPEN
\r
11964 MOVEI A,3 ; GET STATE VECTOR
\r
11967 MOVE D,T.CHAN+1(TB)
\r
11968 MOVEM A,BUFRIN-1(D)
\r
11969 MOVEM B,BUFRIN(D)
\r
11970 MOVSI A,TFIX+.VECT. ; SET U TYPE
\r
11972 MOVE C,T.SPDL+1(TB)
\r
11973 MOVE B,T.CHAN+1(TB)
\r
11975 PUSHJ P,INETST ; GET STATE
\r
11977 POP P,A ; IS THIS BLOCK MODE
\r
11978 MOVEI 0,80. ; POSSIBLE LINE LENGTH
\r
11979 TRNE A,1 ; SKIP IF INPUT
\r
11981 TRNN A,2 ; BLOCK MODE?
\r
11983 TRNN A,4 ; ASCII MODE?
\r
11984 JRST OPBASC ; GO SETUP BLOCK ASCII
\r
11985 MOVE 0,[PUSHJ P,DOIOT]
\r
11990 ; INTERNAL ROUTINE TO GET THE CURRENT STATE OF THE NETWROK CHANNEL
\r
11992 INETST: MOVE A,S.NM1(C)
\r
11993 MOVEM A,RNAME1(B)
\r
11995 MOVEM A,RNAME2(B)
\r
11996 LDB A,[1100,,S.SNM(C)]
\r
11997 MOVEM A,RSNAME(B)
\r
11999 MOVE E,BUFRIN(B) ; GET STATE BLOCK
\r
12000 INTST1: HRRE 0,S.X1(C)
\r
12008 ; ACCEPT A CONNECTION
\r
12010 MFUNCTION NETACC,SUBR
\r
12012 PUSHJ P,ARGNET ; CHECK THAT ARG IS AN OPEN NET CHANNEL
\r
12013 MOVE A,CHANNO(B) ; GET CHANNEL
\r
12014 LSH A,23. ; TO AC FIELD
\r
12017 JRST IFALSE ; RETURN FALSE
\r
12018 NETRET: MOVE A,(AB)
\r
12022 ; FORCE SYSTEM NETWORK BUFFERS TO BE SENT
\r
12024 MFUNCTION NETS,SUBR
\r
12029 SKIPA A,CHANNO(B) ; GET CHANNEL
\r
12036 ; SUBR TO RETURN UPDATED NET STATE
\r
12038 MFUNCTION NETSTATE,SUBR
\r
12040 PUSHJ P,ARGNET ; IS IT A NET CHANNEL
\r
12044 ; INTERNAL NETSTATE ROUTINE
\r
12046 INSTAT: MOVE C,P ; GET PDL BASE
\r
12047 MOVEI 0,S.X3 ; # OF SLOTS NEEDED
\r
12051 MOVEI D,S.DEV(C) ; SETUP FOR .RCHST
\r
12053 .RCHST D, ; GET THE GOODS
\r
12055 PUSHJ P,INETST ; INTO VECTOR
\r
12056 SUB P,[S.X3,,S.X3]
\r
12061 ; INTERNAL ROUTINE TO CHECK FOR CORRECT CHANNEL TYPE
\r
12067 MOVE B,1(AB) ; GET CHANNEL
\r
12068 SKIPN CHANNO(B) ; OPEN?
\r
12070 MOVE A,RDEVIC-1(B) ; GET DEV NAME
\r
12074 CAME A,[SIXBIT /NET /]
\r
12077 MOVE A,DIRECT-1(B) ; CHECK FOR A READ SOCKET
\r
12080 MOVE B,1(AB) ; RESTORE CHANNEL
\r
12086 ; TENEX NETWRK OPENING CODE
\r
12088 ONET: MOVE B,T.CHAN+1(TB) ; GET CHANNEL
\r
12092 PUSH P,[ASCII /NET:/] ; FOR STRINGS
\r
12093 GETYP 0,RNAME1-1(B) ; CHECK TYPE
\r
12094 CAIE 0,TFIX ; SKIP IF # SUPPLIED
\r
12096 MOVE 0,RNAME1(B) ; GET IT
\r
12100 ONET1: CAIE 0,TCHSTR
\r
12102 HRRZ 0,RNAME1-1(B)
\r
12108 ONET2: MOVEI A,".
\r
12110 MOVE B,T.CHAN+1(TB)
\r
12111 GETYP 0,RNAME2-1(B)
\r
12114 GETYP 0,RSNAME-1(B)
\r
12120 MOVE B,T.CHAN+1(TB)
\r
12127 ONET3: CAIE 0,TCHSTR
\r
12129 HRRZ 0,RNAME2-1(B)
\r
12137 ONET5: MOVE B,T.CHAN+1(TB)
\r
12138 GETYP 0,RNAME2-1(B)
\r
12146 HRROI B,1(E) ; STRING POINTER
\r
12147 GTJFN ; GET THE G.D JFN
\r
12148 TDZA 0,0 ; REMEMBER FAILURE
\r
12150 MOVE P,E ; RESTORE P
\r
12151 JUMPE 0,GTJLOS ; CONS UP ERROR STRING
\r
12153 MOVE B,T.CHAN+1(TB)
\r
12154 HRRZM A,CHANNO(B) ; SAVE THE JFN
\r
12156 MOVE C,T.SPDL+1(TB)
\r
12162 MOVE B,T.XT+1(TB)
\r
12169 TRNE D,1 ; SKIP FOR INPUT
\r
12171 ANDI A,-1 ; ISOLATE JFCN
\r
12173 JRST OPFLOS ; REPORT ERROR
\r
12174 MOVE B,T.CHAN+1(TB)
\r
12175 ASH A,1 ; POINT TO SLOT
\r
12176 ADDI A,CHNL0(TVP) ; TO REAL SLOT
\r
12177 MOVEM B,1(A) ; SAVE CHANNEL
\r
12179 CVSKT ; GET ABS SOCKET #
\r
12180 FATAL NETWORK BITES THE BAG!
\r
12182 MOVE B,T.CHAN+1(TB)
\r
12183 MOVEM D,RNAME1(B)
\r
12185 MOVEM 0,RNAME1-1(B)
\r
12188 MOVEM 0,RNAME2-1(B)
\r
12189 MOVEM 0,RSNAME-1(B)
\r
12190 MOVE C,T.SPDL+1(TB)
\r
12192 MOVE 0,[PUSHJ P,DONETO]
\r
12193 TRNN C,1 ; SKIP FOR OUTPUT
\r
12194 MOVE 0,[PUSHJ P,DONETI]
\r
12196 MOVEI 0,80. ; LINELENGTH
\r
12197 TRNE C,1 ; SKIP FOR INPUT
\r
12199 MOVEI A,3 ; GET STATE UVECTOR
\r
12201 MOVSI 0,TFIX+.VECT.
\r
12204 MOVE B,T.CHAN+1(TB)
\r
12205 MOVEM C,BUFRIN(B)
\r
12207 MOVEM 0,BUFRIN-1(B)
\r
12208 MOVE A,CHANNO(B) ; GET JFN
\r
12209 GDSTS ; GET STATE
\r
12210 MOVE E,T.CHAN+1(TB)
\r
12211 MOVEM D,RNAME2(E)
\r
12212 MOVEM C,RSNAME(E)
\r
12214 MOVEM B,(C) ; INITIAL STATE STORED
\r
12218 ; DOIOT FOR TENEX NETWRK
\r
12229 MOVEI 0,(A) ; POSSIBLE OUTPUT CHAR TO 0
\r
12235 MOVEI A,(B) ; RET CHAR IN A
\r
12242 NETPRS: MOVEI D,0
\r
12256 FIXSTK: CAMN 0,[-1]
\r
12258 JFFO 0,FIXS3 ; PUT OCTAL DIGITS INTO STIRNG
\r
12270 ROTC 0,3 ; NEXT DIGIT
\r
12279 TLNE C,760000 ; SKIP IF NEW WORD
\r
12288 MOVEM D,RNAME2(E) ; UPDATE FOREIGN SOCHKET
\r
12289 MOVEM C,RSNAME(E) ; AND HOST
\r
12291 XCT ITSTRN(B) ; XLATE TO LOOK MORE LIKE ITS
\r
12292 MOVEM B,(C) ; STORE STATE
\r
12296 ITSTRN: MOVEI B,0
\r
12312 NLOSS: FATAL ILLEGAL NETWORK STATE
\r
12314 NOPND: MOVE B,DIRECT(E) ; SEE IF READ OR PRINT
\r
12315 ILDB B,B ; GET 1ST CHAR
\r
12316 CAIE B,"R ; SKIP FOR READ
\r
12318 SIBE ; SEE IF INPUT EXISTS
\r
12322 MOVEM B,2(C) ; STORE BYTES IN STATE VECTOR
\r
12323 MOVEI B,11 ; RETURN DATA PRESENT STATE
\r
12326 NOPNDW: SOBE ; SEE IF OUTPUT PRESENT
\r
12334 NCLSD: MOVE B,DIRECT(E)
\r
12348 MFUNCTION NETSTATE,SUBR
\r
12356 MFUNCTION NETS,SUBR
\r
12359 CAME A,MODES+1 ; PRINT OR PRINTB?
\r
12361 SKIPA A,CHANNO(B)
\r
12365 NETRET: MOVE B,1(AB)
\r
12369 MFUNCTION NETACC,SUBR
\r
12379 ; HERE TO OPEN TELETYPE DEVICES
\r
12381 OTTY: HRRZ A,S.DIR(C) ; GET DIR CODE
\r
12382 TRNE A,2 ; SKIP IF NOT READB/PRINTB
\r
12383 JRST WRONGD ; CANT DO THAT
\r
12386 MOVE A,S.NM1(C) ; CHECK FOR A DIR
\r
12388 CAMN A,[SIXBIT /.FILE./]
\r
12389 CAME 0,[SIXBIT /(DIR)/]
\r
12390 SKIPA E,[-15.*2,,]
\r
12391 JRST OUTN ; DO IT THAT WAY
\r
12393 HRRZ A,S.DIR(C) ; CHECK DIR
\r
12396 HRRI E,CHNL1(TVP)
\r
12397 PUSH P,S.DEV(C) ; SAVE THE SIXBIT DEV NAME
\r
12398 HRLZS (P) ; POSTITION DEVICE NAME
\r
12400 TTYLP: SKIPN D,1(E) ; CHANNEL OPEN?
\r
12401 JRST TTYLP1 ; NO, GO TO NEXT
\r
12402 MOVE A,RDEVIC-1(D) ; GET DEV NAME
\r
12404 PUSHJ P,STRTO6 ; TO 6 BIT
\r
12405 POP P,A ; GET RESULT
\r
12406 CAMN A,(P) ; SAME?
\r
12407 JRST SAMTYQ ; COULD BE THE SAME
\r
12408 TTYLP1: ADD E,[2,,2]
\r
12410 SUB P,[1,,1] ; THIS ONE MUST BE UNIQUE
\r
12411 TTYLP2: MOVE C,T.SPDL+1(TB) ; POINT TO P BASE
\r
12412 HRRZ A,S.DIR(C) ; GET DIR OF OPEN
\r
12413 SKIPE A ; IF OUTPUT,
\r
12414 IORI A,20 ; THEN USE DISPLAY MODE
\r
12415 HRLM A,S.DEV(C) ; STORE IN OPEN BLOCK
\r
12416 PUSHJ P,OPEN2 ; OPEN THE TTY
\r
12417 HRLZ A,S.DEV(C) ; GET DEVICE NAME
\r
12418 PUSHJ P,6TOCHS ; TO A STRING
\r
12419 MOVE D,T.CHAN+1(TB) ; POINT TO CHANNEL
\r
12420 MOVEM A,RDEVIC-1(D)
\r
12421 MOVEM B,RDEVIC(D)
\r
12422 MOVE C,T.SPDL+1(TB) ; RESTORE PDL BASE
\r
12423 MOVE B,D ; CHANNEL TO B
\r
12424 HRRZ 0,S.DIR(C) ; AND DIR
\r
12426 TTY1: DOTCAL TTYGET,[CHANNO(B),[2000,,0],[2000,,A],[2000,,D]]
\r
12427 FATAL .CALL FAILURE
\r
12428 DOTCAL TTYSET,[CHANNO(B),MODE1,MODE2,D]
\r
12429 FATAL .CALL FAILURE
\r
12430 MOVE A,[PUSHJ P,GMTYO]
\r
12432 DOTCAL RSSIZE,[CHANNO(B),[2000,,A],[2000,,D]]
\r
12433 FATAL .CALL FAILURE
\r
12440 IOTMAK: HRLZ A,CHANNO(B) ; GET CHANNEL
\r
12442 IOR A,[.IOT A] ; BUILD IOT
\r
12443 MOVEM A,IOINS(B) ; AND STORE IT
\r
12447 ; HERE IF POSSIBLY OPENING AN ALREADY OPEN TTY
\r
12449 SAMTYQ: MOVE D,1(E) ; RESTORE CURRENT CHANNEL
\r
12450 MOVE A,DIRECT-1(D) ; GET DIR
\r
12453 POP P,A ; GET SIXBIT
\r
12454 MOVE C,T.SPDL+1(TB)
\r
12456 CAME A,MODES(C) ; SKIP IF DIFFERENT DIRECTION
\r
12459 ; HERE IF A RE-OPEN ON A TTY
\r
12461 HRRZ 0,FSAV(TB) ; IS IT FROM A FOPEN
\r
12463 JRST RETOLD ; RET OLD CHANNEL
\r
12466 PUSH TP,1(E) ; PUSH OLD CHANNEL
\r
12468 PUSH TP,T.CHAN+1(TB)
\r
12469 MOVE A,[PUSHJ P,CHNFIX]
\r
12473 RETOLD: MOVE B,1(E) ; GET CHANNEL
\r
12474 AOS CHANNO-1(B) ; AOS REF COUNT
\r
12476 SUB P,[1,,1] ; CLEAN UP STACK
\r
12477 JRST OPNRET ; AND LEAVE
\r
12480 ; ROUTINE TO PASS TO GCHACK TO FIX UP CHANNEL POINTER
\r
12482 CHNFIX: CAIN C,TCHAN
\r
12485 MOVE D,-2(TP) ; GET REPLACEMENT
\r
12487 MOVEM D,1(B) ; CLOBBER IT AWAY
\r
12492 MOVE C,T.SPDL+1(TB) ; POINT TO P BASE
\r
12493 HRRZ 0,S.DIR(C) ; 0/ 0 FOR READ 0/ 1 FOR PRINT
\r
12494 MOVE A,[PUSHJ P,MTYO]
\r
12495 MOVE B,T.CHAN+1(TB)
\r
12497 MOVEI A,100 ; PRIM INPUT JFN
\r
12499 MOVEI E,C.OPN+C.READ
\r
12501 MOVEM B,CHNL0+2*100+1(TVP)
\r
12503 TNXTY1: MOVEM B,CHNL0+2*101+1(TVP)
\r
12504 MOVEI A,101 ; PRIM OUTPUT JFN
\r
12505 MOVEI E,C.OPN+C.PRIN
\r
12507 TNXTY2: MOVEM A,CHANNO(B)
\r
12510 ; SETUP FUNNY BUFFER FOR TTY INPUT DEVICES
\r
12512 TTYSPC: MOVEI A,EXTBFR ; GET EXTRA BUFFER
\r
12513 PUSHJ P,IBLOCK ; GET BLOCK
\r
12514 MOVE D,T.CHAN+1(TB) ;RESTORE CHANNEL POINTER
\r
12526 MOVEM A,EXBUFR-1(D) ; FOR WAITING TTY BUFFERS
\r
12527 SETZM EXBUFR(D) ; NIL LIST
\r
12528 MOVEM B,BUFRIN(D) ;STORE IN CHANNEL
\r
12529 MOVSI A,TUVEC ;MAKE SURE TYPE IS UNIFORM VECTOR
\r
12530 MOVEM A,BUFRIN-1(D)
\r
12531 IFN ITS, MOVEI A,177 ;SET ERASER TO RUBOUT
\r
12532 IFE ITS, MOVEI A,1 ; TRY ^A FOR TENEX
\r
12533 MOVEM A,ERASCH(B)
\r
12534 SETZM KILLCH(B) ;NO KILL CHARACTER NEEDED
\r
12535 MOVEI A,33 ;BREAKCHR TO C.R.
\r
12537 MOVEI A,"\ ;ESCAPER TO \
\r
12539 MOVE A,[010700,,BYTPTR(E)] ;RELATIVE BYTE POINTER
\r
12540 MOVEM A,BYTPTR(B)
\r
12541 MOVEI A,14 ;BARF BACK CHARACTER FF
\r
12542 MOVEM A,BRFCHR(B)
\r
12544 MOVEM A,BRFCH2(B)
\r
12546 ; SETUP DEFAULT TTY INTERRUPT HANDLER
\r
12549 PUSH TP,MQUOTE CHAR,CHAR,INTRUP
\r
12551 PUSH TP,[10] ; PRIORITY OF CHAR INT
\r
12554 MCALL 3,EVENT ; 1ST MAKE AN EVENT EXIST
\r
12558 PUSH TP,[QUITTER] ; DEFAULT HANDLER IS QUITTER
\r
12561 ; BUILD A NULL STRING
\r
12564 PUSHJ P,IBLOCK ; USE A BLOCK
\r
12565 MOVE D,T.CHAN+1(TB)
\r
12570 MOVEM A,BUFSTR-1(D)
\r
12571 MOVEM B,BUFSTR(D)
\r
12573 MOVE B,D ; CHANNEL TO B
\r
12577 ; ROUTINE TO OPEN ITS CHANNEL WITHOUT .RCHST
\r
12579 OPEN2: MOVEI A,S.DEV(C) ; POINT TO OPEN BLOCK
\r
12580 PUSHJ P,MOPEN ; OPEN THE FILE
\r
12582 MOVE B,T.CHAN+1(TB) ; GET CHANNEL BACK
\r
12583 MOVEM A,CHANNO(B) ; SAVE THE CHANNEL
\r
12586 ; FIX UP MODE AND FALL INTO OPEN
\r
12588 OPEN0: HRRZ A,S.DIR(C) ; GET DIR
\r
12589 TRNE A,2 ; SKIP IF NOT BLOCK
\r
12590 IORI A,4 ; TURN ON IMAGE
\r
12591 IORI A,2 ; AND BLOCK
\r
12595 PUSH TP,C ; SAVE CRUFT TO CHECK FOR PRINTO, HA HA
\r
12596 MOVE B,T.CHAN+1(TB)
\r
12597 MOVE A,DIRECT-1(B)
\r
12598 MOVE B,DIRECT(B) ; THIS KLUDGE THE MESS OF NDR
\r
12601 POP P,D ; THE SIXBIT FOR KLUDGE
\r
12602 POP P,A ; GET BACK THE RANDOM BITS
\r
12604 CAME D,[SIXBIT /PRINTO/]
\r
12605 JRST OPEN9 ; WELL NOT THIS TIME
\r
12606 IORI A,100000 ; WRITEOVER BIT
\r
12610 IOR A,4 ; DON'T CHANGE REF DATE
\r
12611 OPEN9: HRLM A,S.DEV(C) ; AND STORE IT
\r
12613 ; ROUTINE TO ATTEMPT TO OPEN A REAL ITS CHANNEL
\r
12615 OPEN1: MOVEI A,S.DEV(C) ; POINT TO OPEN BLOCK
\r
12618 MOVE B,T.CHAN+1(TB) ; GET CHANNEL BACK
\r
12619 MOVEM A,CHANNO(B) ; CLOBBER INTO CHANNEL
\r
12620 MOVSI A,(A) ; SET UP READ CHAN STATUS
\r
12622 .RCHST A, ; GET THE GOODS
\r
12624 ; NOW CLOBBER THE TVP SLOT FOR THIS CHANNEL
\r
12626 OPEN3: MOVE A,S.DIR(C)
\r
12627 MOVEI 0,C.OPN+C.READ
\r
12629 MOVEI 0,C.OPN+C.PRIN
\r
12633 MOVE A,CHANNO(B) ; GET CHANNEL #
\r
12635 ADDI A,CHNL0(TVP) ; POINT TO SLOT
\r
12636 MOVEM B,1(A) ; NOT: TYPE ALREADY SETUP
\r
12638 ; NOW GET STATUS WORD
\r
12640 DOSTAT: HRLZ A,CHANNO(B) ; NOW GET STATUS WORD
\r
12642 IOR A,[.STATUS STATUS(B)] ; GET INS
\r
12643 XCT A ; AND DO IT
\r
12647 ; HERE IF OPEN FAILS (CHANNEL IS IN A)
\r
12649 OPNLOS: JUMPL A,NOCHAN ; ALL CHANNELS ARE IN USE
\r
12650 LSH A,23. ; DO A .STATUS
\r
12651 IOR A,[.STATUS A]
\r
12652 XCT A ; STATUS TO A
\r
12653 PUSHJ P,GFALS ; GET A FALSE WITH A MESSAGE
\r
12654 SUB P,[1,,1] ; EXTRA RET ADDR FLUSHED
\r
12655 JRST OPNRET ; AND RETURN
\r
12657 ; ROUTINE TO CONS UP FALSE WITH REASON
\r
12659 GFALS: PUSH P,[SIXBIT / ERR/] ; SET UP OPEN TO ERR DEV
\r
12660 PUSH P,[3] ; SAY ITS FOR CHANNEL
\r
12662 .OPEN 0,-2(P) ; USE CHANNEL 0 FOR THIS
\r
12663 FATAL CAN'T OPEN ERROR DEVICE
\r
12664 SUB P,[3,,3] ; DONT WANT OPEN BLOCK NOW
\r
12665 MOVEI A,0 ; PREPARE TO BUILD STRING ON STACK
\r
12666 EL1: PUSH P,[0] ; WHERE IT WILL GO
\r
12667 MOVSI B,(<440700,,(P)>) ; BYTE POINTER TO TOP OF STACK
\r
12668 EL2: .IOT 0,0 ; GET A CHAR
\r
12669 JUMPL 0,EL3 ; JUMP ON -1,,3
\r
12671 JRST EL3 ; YES, MAKE STRING
\r
12672 CAIN 0,14 ; IGNORE FORM FEEDS
\r
12673 JRST EL2 ; IGNORE FF
\r
12674 CAIE 0,15 ; IGNORE CR & LF
\r
12677 IDPB 0,B ; STUFF IT
\r
12678 TLNE B,760000 ; SIP IF WORD FULL
\r
12680 AOJA A,EL1 ; COUNT WORD AND GO
\r
12682 EL3: SKIPN (P) ; ANY CHARS AT END?
\r
12683 SUB P,[1,,1] ; FLUSH XTRA
\r
12684 PUSH P,A ; PUT UP COUNT
\r
12685 .CLOSE 0, ; CLOSE THE ERR DEVICE
\r
12686 PUSHJ P,CHMAK ; MAKE STRING
\r
12688 MOVE D,B ; COPY STRING
\r
12689 PUSHJ P,INCONS ; CONS TO NIL
\r
12690 MOVSI A,TFALSE ; MAKEIT A FALSE
\r
12694 ; ROUTINE TO FILL IN THE "REAL" SLOTS FOR THE CHANNEL
\r
12696 FIXREA: HRLZS S.DEV(C) ; KILL MODE BITS
\r
12697 MOVE D,[-4,,S.DEV]
\r
12699 FIXRE1: MOVEI A,(D) ; COPY REL POINTER
\r
12700 ADD A,T.SPDL+1(TB) ; POINT TO SLOT
\r
12701 SKIPN A,(A) ; SKIP IF GOODIE THERE
\r
12703 PUSHJ P,6TOCHS ; MAKE INOT A STRING
\r
12704 MOVE C,RDTBL-S.DEV(D); GET OFFSET
\r
12705 ADD C,T.CHAN+1(TB)
\r
12708 FIXRE2: AOBJN D,FIXRE1
\r
12712 HRLZ A,CHANNO(B) ; GET CHANNEL
\r
12714 HRR A,(P) ; POINT
\r
12722 ;THIS ROUTINE CONVERTS MUDDLE CHARACTER STRINGS TO SIXBIT FILE NAMES
\r
12723 STRTO6: PUSH TP,A
\r
12725 PUSH P,E ;SAVE USEFUL FROB
\r
12726 MOVEI E,(A) ; CHAR COUNT TO E
\r
12728 CAIE A,TCHSTR ; IS IT ONE WORD?
\r
12730 CHREAD: MOVEI A,0 ;INITIALIZE OUTPUT WORD
\r
12731 MOVE D,[440600,,A] ;AND BYTE POINTER TO IT
\r
12732 NEXCHR: SOJL E,SIXDON
\r
12733 ILDB 0,B ; GET NEXT CHAR
\r
12734 JUMPE 0,SIXDON ;IF NULL, WE ARE FINISHED
\r
12735 PUSHJ P,A0TO6 ; CONVERT TO SIXBIT
\r
12736 IDPB 0,D ;DEPOSIT INTO SIX BIT
\r
12737 TRNN A,77 ;IS OUTPUT FULL
\r
12738 JRST NEXCHR ; NO, GET NEXT
\r
12739 SIXDON: SUB TP,[2,,2] ;FIX UP TP
\r
12741 EXCH A,(P) ;LEAVE RESULT ON P-STACK
\r
12742 JRST (A) ;NOW RETURN
\r
12745 ;SUBROUTINE TO CONVERT SIXBIT TO ATOM
\r
12749 MOVEI B,0 ;MAX NUMBER OF CHARACTERS
\r
12750 PUSH P,[0] ;STRING WILL GO ON P SATCK
\r
12751 JUMPE A,GETATM ; EMPTY, LEAVE
\r
12752 MOVEI E,-1(P) ;WILL BE BYTE POINTER
\r
12753 HRLI E,10700 ;SET IT UP
\r
12754 PUSH P,[0] ;SECOND POSSIBLE WORD
\r
12755 MOVE D,[440600,,A] ;INPUT BYTE POINTER
\r
12756 6LOOP: ILDB 0,D ;START CHAR GOBBLING
\r
12757 ADDI 0,40 ;CHANGET TOASCII
\r
12758 IDPB 0,E ;AND STORE IT
\r
12759 TLNN D,770000 ; SKIP IF NOT DONE
\r
12761 TDNN A,MSKS(B) ; CHECK IF JUST SPACES LEFT
\r
12762 AOJA B,GETATM ; YES, DONE
\r
12763 AOJA B,6LOOP ;KEEP LOOKING
\r
12764 6LOOP1: PUSH P,[6] ;IF ARRIVE HERE, STRING IS 2 WORDS
\r
12766 GETATM: MOVEM B,(P) ;SET STRING LENGTH=1
\r
12767 PUSHJ P,CHMAK ;MAKE A MUDDLE STRING
\r
12779 ; CONVERT ONE CHAR
\r
12781 A0TO6: CAIL 0,141 ;IF IT IS GREATER OR EQUAL TO LOWER A
\r
12782 CAILE 0,172 ;BUT LESS THAN OR EQUAL TO LOWER Z
\r
12784 SUBI 0,40 ;CONVERT TO UPPER CASE
\r
12785 SUBI 0,40 ;NOW TO SIX BIT
\r
12786 JUMPL 0,BAD6 ;CHECK FOR A WINNER
\r
12791 ; SUBR TO DELETE AND RENAME FILES
\r
12793 MFUNCTION RENAME,SUBR
\r
12799 PUSH TP,P ; SAVE P-STACK BASE
\r
12800 GETYP 0,(AB) ; GET 1ST ARG TYPE
\r
12802 CAIN 0,TCHAN ; CHANNEL?
\r
12803 JRST CHNRNM ; MUST BE RENAME WHILE OPEN FOR WRITING
\r
12806 PUSH P,[100000,,0]
\r
12807 PUSH P,[377777,,377777]
\r
12809 MOVSI E,-4 ; 4 THINGS TO PUSH
\r
12810 RNMALP: MOVE B,@RNMTBL(E)
\r
12815 CAIE 0,TCHSTR ; SKIP IF WINS
\r
12818 IFN ITS, PUSHJ P,STRTO6 ; CONVERT TO SIXBIT
\r
12819 IFE ITS, PUSH P,B ; PUSH BYTE POINTER
\r
12822 RNMLP1: PUSH P,RNSTBL(E) ; USE DEFAULT
\r
12826 PUSHJ P,RGPRS ; PARSE THE ARGS
\r
12827 JRST RNM1 ; COULD BE A RENAME
\r
12829 ; HERE TO DELETE A FILE
\r
12831 DELFIL: MOVEI A,0 ; SETUP FDELE
\r
12832 EXCH A,(P) ; AND GET SNAME
\r
12833 .SUSET [.SSNAM,,A]
\r
12834 HLRZS -3(P) ; FIXUP DEVICE
\r
12835 .FDELE -3(P) ; DO IT TO IT
\r
12836 JRST FDLST ; ANALYSE ERROR
\r
12838 FDLWON: MOVSI A,TATOM
\r
12843 MOVE A,(TP) ; GET BASE OF PDL
\r
12844 MOVEI A,1(A) ; POINT TO CRAP
\r
12845 MOVE B,1(AB) ; STRING POINTER
\r
12849 GTJFN ; GET A JFN
\r
12850 JRST TDLLOS ; LOST
\r
12851 ADD AB,[2,,2] ; PAST ARG
\r
12852 JUMPL AB,RNM1 ; GO TRY FOR RENAME
\r
12853 MOVE P,(TP) ; RESTORE P STACK
\r
12854 MOVEI C,(A) ; FOR RELEASE
\r
12855 DELF ; ATTEMPT DELETE
\r
12856 JRST DELLOS ; LOSER
\r
12857 RLJFN ; MAKE SURE FLUSHED
\r
12860 FDLWON: MOVSI A,TATOM
\r
12868 DELLO1: MOVEI A,(C)
\r
12871 POP P,A ; ERR NUMBER BACK
\r
12872 TDLLOS: PUSHJ P,TGFALS ; GET FALSE WITH REASON
\r
12875 DELLOS: PUSH P,A ; SAVE ERROR
\r
12879 ;TABLE OF REANMAE DEFAULTS
\r
12881 RNMTBL: IMQUOTE DEV
\r
12886 RNSTBL: SIXBIT /DSK _MUDS_> /
\r
12889 RNMTBL: IMQUOTE DEV
\r
12894 RNSTBL: -1,,[ASCIZ /DSK/]
\r
12896 -1,,[ASCIZ /_MUDS_/]
\r
12897 -1,,[ASCIZ /MUD/]
\r
12899 ; HERE TO DO A RENAME
\r
12901 RNM1: JUMPGE AB,TMA ; IF ARGS EXHAUSTED, MUST BE TOO MUCH STRING
\r
12903 MOVE C,1(AB) ; GET ARG
\r
12904 CAIN 0,TATOM ; IS IT "TO"
\r
12906 JRST WRONGT ; NO, LOSE
\r
12907 ADD AB,[2,,2] ; BUMP PAST "TO"
\r
12910 MOVEM P,T.SPDL+1(TB) ; SAVE NEW P-BASE
\r
12912 MOVEI 0,4 ; FOUR DEFAULTS
\r
12913 PUSH P,-3(P) ; DEFAULT DEVICE IS CURRENT
\r
12916 PUSHJ P,RGPRS ; PARSE THE NEXT STRING
\r
12919 HLRZS A,-7(P) ; FIX AND GET DEV1
\r
12920 HLRZS B,-3(P) ; SAME FOR DEV2
\r
12921 CAIE A,(B) ; SAME?
\r
12924 POP P,A ; GET SNAME 2
\r
12925 CAME A,(P)-3 ; SNAME 1
\r
12927 .SUSET [.SSNAM,,A]
\r
12928 POP P,-2(P) ; MOVE NAMES DOWN
\r
12930 .FDELE -4(P) ; TRY THE RENAME
\r
12934 ; HERE FOR RENAME WHILE OPEN FOR WRITING
\r
12936 CHNRNM: ADD AB,[2,,2] ; NEXT ARG
\r
12938 MOVE B,-1(AB) ; GET CHANNEL
\r
12939 SKIPN CHANNO(B) ; SKIP IF OPEN
\r
12941 MOVE A,DIRECT-1(B) ; CHECK DIRECTION
\r
12943 PUSHJ P,STRTO6 ; TO 6 BIT
\r
12945 CAME A,[SIXBIT /PRINT/]
\r
12946 CAMN A,[SIXBIT /PRINTB/]
\r
12948 CAME A,[SIXBIT /PRINTO/]
\r
12951 ; SET UP .FDELE BLOCK
\r
12953 CHNRN1: PUSH P,[0]
\r
12955 MOVEM P,T.SPDL+1(TB)
\r
12957 PUSH P,[SIXBIT /_MUDL_/]
\r
12958 PUSH P,[SIXBIT />/]
\r
12961 PUSHJ P,RGPRS ; PARSE THESE
\r
12964 SUB P,[1,,1] ; SNAME/DEV IGNORED
\r
12965 MOVE AB,ABSAV(TB) ; GET ORIG ARG POINTER
\r
12967 MOVE A,CHANNO(B) ; ITS CHANNEL #
\r
12971 MOVEI A,-4(P) ; SET UP FOR RDCHST
\r
12974 MOVE A,-3(P) ; UPDATE CHANNEL
\r
12975 PUSHJ P,6TOCHS ; GET A STRING
\r
12977 MOVEM A,RNAME1-1(C)
\r
12978 MOVEM B,RNAME1(C)
\r
12982 MOVEM A,RNAME2-1(C)
\r
12983 MOVEM B,RNAME2(C)
\r
12990 MOVE A,(TP) ; PBASE BACK
\r
12991 PUSH A,[400000,,0]
\r
12998 MOVEI C,(A) ; FOR RELEASE ATTEMPT
\r
13002 RLJFN ; FLUSH JFN
\r
13004 MOVEI A,(C) ; MAKE SURR OTHER IS FLUSHED
\r
13009 ; HERE FOR LOSING .FDELE
\r
13011 FDLST: .STATUS 0,A ; GET STATUS
\r
13012 PUSHJ P,GFALS ; ANALYZE IT
\r
13015 ; SOME .FDELE ERRORS
\r
13017 DEVDIF: PUSH TP,$TATOM
\r
13018 PUSH TP,EQUOTE DEVICE-OR-SNAME-DIFFERS
\r
13021 \f; HERE TO RESET A READ CHANNEL
\r
13023 MFUNCTION FRESET,SUBR,RESET
\r
13029 MOVE B,1(AB) ;GET CHANNEL
\r
13030 SKIPN IOINS(B) ; OPEN?
\r
13031 JRST REOPE1 ; NO, IGNORE CHECKS
\r
13033 MOVE A,STATUS(B) ;GET STATUS
\r
13035 JUMPE A,REOPE1 ;IF IT CLOSED, JUST REOPEN IT, MAYBE?
\r
13036 CAILE A,2 ;SKIPS IF TTY FLAVOR
\r
13041 CAIE A,100 ; TTY-IN
\r
13042 CAIN A,101 ; TTY-OUT
\r
13046 CAME B,TTICHN+1(TVP)
\r
13047 CAMN B,TTOCHN+1(TVP)
\r
13049 REATT1: MOVEI B,DIRECT-1(B) ;POINT TO DIRECTION
\r
13050 PUSHJ P,CHRWRD ;CONVERT TO A WORD
\r
13052 CAME B,[ASCII /READ/]
\r
13054 MOVE B,1(AB) ;RESTORE CHANNEL
\r
13055 PUSHJ P,RRESET" ;DO REAL RESET
\r
13058 REOPEN: PUSH TP,(AB) ;FIRST CLOSE IT
\r
13061 MOVE B,1(AB) ;RESTORE CHANNEL
\r
13063 ; SET UP TEMPS FOR OPNCH
\r
13065 REOPE1: PUSH P,[0] ; WILL HOLD DIR CODE
\r
13068 IRP A,,[DIRECT,RNAME1,RNAME2,RDEVIC,RSNAME,ACCESS]
\r
13077 MOVE B,T.DIR+1(TB) ; GET DIRECTION
\r
13078 PUSHJ P,CHMOD ; CHECK THE MODE
\r
13079 MOVEM A,(P) ; AND STORE IT
\r
13081 ; NOW SET UP OPEN BLOCK IN SIXBIT
\r
13083 MOVSI E,-4 ; AOBN PNTR
\r
13084 FRESE2: MOVE B,T.CHAN+1(TB)
\r
13085 MOVEI A,@RDTBL(E) ; GET ITEM POINTER
\r
13086 GETYP 0,-1(A) ; GET ITS TYPE
\r
13089 MOVE B,(A) ; GET STRING
\r
13092 FRESE3: AOBJN E,FRESE2
\r
13093 HLRZS -3(P) ; FIX DEVICE SPEC
\r
13096 MOVE B,T.CHAN+1(TB)
\r
13097 MOVE A,RDEVIC-1(B)
\r
13099 PUSHJ P,STRTO6 ; RESULT ON STACK
\r
13103 PUSH P,[0] ; PUSH UP SOME DUMMIES
\r
13106 PUSHJ P,OPNCH ; ATTEMPT TO DO THEOPEN
\r
13109 JRST FINIS ; LEAVE IF FALSE OR WHATEVER
\r
13111 DRESET: MOVE A,(AB)
\r
13113 SETZM CHRPOS(B) ;INITIALIZE THESE PARAMETERS
\r
13118 TTYOPN: MOVE B,1(AB)
\r
13119 CAME B,TTOCHN+1(TVP)
\r
13120 CAMN B,TTICHN+1(TVP)
\r
13123 DOTCAL RSSIZE,[CHANNO(B),[2000,,C],[2000,,D]]
\r
13124 FATAL .CALL FAILURE
\r
13130 FRESE1: CAIE 0,TFIX
\r
13136 ; INTERFACE TO REOPEN CLOSED CHANNELS
\r
13138 OPNCHN: PUSH TP,$TCHAN
\r
13143 REATTY: PUSHJ P,TTYOP2
\r
13149 ; FUNCTION TO LIST ALL CHANNELS
\r
13151 MFUNCTION CHANLIST,SUBR
\r
13155 MOVEI A,N.CHNS-1 ;MAX # OF REAL CHANNELS
\r
13157 MOVEI B,CHNL1(TVP) ;POINT TO FIRST REAL CHANNEL
\r
13159 CHNLP: SKIPN 1(B) ;OPEN?
\r
13160 JRST NXTCHN ;NO, SKIP
\r
13161 HRRZ E,(B) ; ABOUT TO FLUSH?
\r
13162 JUMPN E,NXTCHN ; YES, FORGET IT
\r
13163 MOVE D,1(B) ; GET CHANNEL
\r
13164 HRRZ E,CHANNO-1(D) ; GET REF COUNT
\r
13167 ADDI C,1 ;COUNT WINNERS
\r
13168 SOJGE E,.-3 ; COUNT THEM
\r
13172 SKIPN B,CHNL0(TVP)+1 ;NOW HACK LIST OF PSUEDO CHANNELS
\r
13174 CHNLS: PUSH TP,(B)
\r
13180 MAKLST: ACALL C,LIST
\r
13183 \f; ROUTINE TO RESTORE A CLOSED CHANNEL TO ITS PREVIOUS STATE
\r
13186 REOPN: PUSH TP,$TCHAN
\r
13188 SKIPN CHANNO(B) ; ONLY REAL CHANNELS
\r
13192 MOVSI E,-4 ; SET UP POINTER FOR NAMES
\r
13194 GETOPB: MOVE B,(TP) ; GET CHANNEL
\r
13195 MOVEI A,@RDTBL(E) ; GET POINTER
\r
13196 MOVE B,(A) ; NOW STRING
\r
13198 PUSHJ P,STRTO6 ; LEAVES SIXBIT ON STACK
\r
13202 MOVE A,RDEVIC-1(B)
\r
13204 PUSHJ P,STRTO6 ; GET DEV NAME IN SIXBIT
\r
13206 MOVE B,(TP) ; RESTORE CHANNEL
\r
13207 MOVE A,DIRECT-1(B)
\r
13209 PUSHJ P,CHMOD ; CHECK FOR A VALID MODE
\r
13211 IFN ITS, HLRZS E,-3(P) ; GET DEVICE IN PROPER PLACE
\r
13212 IFE ITS, HLRZS E,(P)
\r
13213 MOVE B,(TP) ; RESTORE CHANNEL
\r
13214 CAIN E,(SIXBIT /DSK/)
\r
13215 JRST DISKH ; DISK WINS IMMEIDATELY
\r
13216 CAIN E,(SIXBIT /TTY/) ; NO NEED TO RE-OPEN THE TTY
\r
13219 ANDI E,777700 ; COULD BE "UTn"
\r
13220 MOVE D,CHANNO(B) ; GET CHANNEL
\r
13222 ADDI D,CHNL0(TVP) ; DON'T SEEM TO BE OPEN
\r
13225 CAIN E,(SIXBIT /UT /)
\r
13226 JRST REOPD ; CURRENTLY, CANT RESTORE UTAPE CHANNLES
\r
13227 CAIN E,(SIXBIT /AI /)
\r
13228 JRST REOPD ; CURRENTLY CANT RESTORE AI CHANNELS
\r
13229 CAIN E,(SIXBIT /ML /)
\r
13230 JRST REOPD ; CURRENTLY CANT RESTORE ML CHANNELS
\r
13231 CAIN E,(SIXBIT /DM /)
\r
13232 JRST REOPD ; CURRENTLY CANT RESTORE DM CHANNELS
\r
13234 PUSH TP,$TCHAN ; TRY TO RESET IT
\r
13239 REOPD1: AOS -4(P)
\r
13240 REOPD: SUB P,[4,,4]
\r
13243 REOPD1: AOS -1(P)
\r
13244 REOPD: SUB P,[1,,1]
\r
13246 REOPD0: SUB TP,[2,,2]
\r
13250 DISKH: MOVE C,(P) ; SNAME
\r
13251 .SUSET [.SSNAM,,C]
\r
13254 DISKH: MOVEM A,(P) ; SAVE MODE WORD
\r
13255 PUSHJ P,STSTK ; STRING TO STACK
\r
13256 MOVE A,(E) ; RESTORE MODE WORD
\r
13258 PUSH TP,E ; SAVE PDL BASE
\r
13259 MOVE B,-2(TP) ; CHANNEL BACK TO B
\r
13261 MOVE C,ACCESS(B) ; GET CHANNELS ACCESS
\r
13262 TRNN A,2 ; SKIP IF NOT ASCII CHANNEL
\r
13264 HRRZ D,ACCESS-1(B) ; IF PARTIAL WORD OUT
\r
13265 IMULI C,5 ; TO CHAR ACCESS
\r
13266 JUMPE D,DISKH1 ; NO SWEAT
\r
13269 DISKH1: HRRZ D,BUFSTR-1(B) ; ANY CHARS IN MUDDLE BUFFER
\r
13273 MOVEI C,BUFSTR-1(B)
\r
13274 PUSHJ P,BYTDOP ; FIND LENGTH OF WHOLE BUFFER
\r
13275 HLRZ D,(A) ; LENGTH + 2 TO D
\r
13277 IMULI D,5 ; TO CHARS
\r
13280 DISKH2: SUBI C,(D) ; UPDATE CHAR ACCESS
\r
13281 IDIVI C,5 ; BACK TO WORD ACCESS
\r
13282 IORI A,6 ; BLOCK IMAGE
\r
13285 IORI A,100000 ; WRITE OVER BIT
\r
13290 MOVE A,C ; ACCESS TO A
\r
13291 PUSHJ P,GETFLN ; CHECK LENGTH
\r
13292 CAIGE 0,(A) ; CHECK BOUNDS
\r
13293 JRST .+3 ; COMPLAIN
\r
13294 PUSHJ P,DOACCS ; AND ACESS
\r
13295 JRST REOPD1 ; SUCCESS
\r
13297 MOVE A,CHANNO(B) ; CLOSE THE G.D. CHANNEL
\r
13304 IOR A,[.ACCESS (P)]
\r
13314 MOVEM 0,BSTO(PVP) ; IN CASE OF INTERRUPT
\r
13325 GETFLN: MOVE 0,CHANNO(B) ; GET CHANNEL
\r
13326 .CALL FILBLK ; READ LNTH
\r
13333 402000,,0 ; STUFF RESULT IN 0
\r
13337 HRROI B,1(E) ; TENEX STRING POINTER
\r
13338 MOVEI A,1(P) ; A POINT TO BLOCK OF INFO
\r
13339 PUSH P,[100400,,0] ; FORCE JFN REUSE AND ONLY ACCEPT EXISTING FILE
\r
13340 PUSH P,[377777,,377777] ; NO I/O FOR CORRECTIONS ETC.
\r
13341 REPEAT 6,PUSH P,[0] ; OTHER SLOTS
\r
13342 MOVE D,-2(TP) ; CHANNEL BACK
\r
13343 PUSH P,CHANNO(D) ; AND DESIRED JFN
\r
13344 GTJFN ; GO GET IT
\r
13345 JRST RGTJL ; COMPLAIN
\r
13346 MOVE P,(TP) ; RESTORE P
\r
13347 MOVE A,(P) ; MODE WORD BACK
\r
13348 MOVE B,[440000,,200000] ; FLAG BITS
\r
13349 TRNE A,1 ; SKIP FOR INPUT
\r
13350 TRC B,300000 ; CHANGE TO WRITE
\r
13351 MOVE A,CHANNO(D) ; GET JFN
\r
13354 MOVE E,C ; LENGTH TO E
\r
13355 SIZEF ; GET CURRENT LENGTH
\r
13357 CAMGE B,E ; STILL A WINNER
\r
13359 MOVE A,-2(TP) ; CHANNEL
\r
13360 MOVE A,CHANNO(A) ; JFN
\r
13364 SUB TP,[2,,2] ; FLUSH PDL POINTER
\r
13367 ROPFLS: MOVE A,-2(TP)
\r
13369 CLOSF ; ATTEMPT TO CLOSE
\r
13370 JFCL ; IGNORE FAILURE
\r
13373 RGTJL: MOVE P,(TP)
\r
13385 PSUEDO: AOS (P) ; ASSUME SUCCESS FOR NOW
\r
13386 MOVEI B,RDEVIC-1(B) ; SEE WHAT DEVICE IS
\r
13389 CAME B,[ASCII /E&S/] ; DISPLAY ?
\r
13390 CAMN B,[ASCII /DIS/]
\r
13391 SKIPA B,(TP) ; YES, REGOBBLE CHANNEL AND CONTINUE
\r
13392 JRST REOPD0 ; NO, RETURN HAPPY
\r
13394 SOS (P) ; DISPLAY DID NOT REOPEN, UNDO ASSUMPTION OF SUCCESS
\r
13397 \f;THIS PROGRAM CLOSES THE SPECIFIED CHANNEL
\r
13399 MFUNCTION FCLOSE,SUBR,[CLOSE]
\r
13401 ENTRY 1 ;ONLY ONE ARG
\r
13402 GETYP A,(AB) ;CHECK ARGS
\r
13403 CAIE A,TCHAN ;IS IT A CHANNEL
\r
13405 MOVE B,1(AB) ;PICK UP THE CHANNEL
\r
13406 HRRZ A,CHANNO-1(B) ; GET REF COUNT
\r
13407 SOJGE A,CFIN5 ; NOT READY TO REALLY CLOSE
\r
13408 CAME B,TTICHN+1(TVP) ; CHECK FOR TTY
\r
13409 CAMN B,TTOCHN+1(TVP)
\r
13411 MOVE A,[JRST CHNCLS]
\r
13412 MOVEM A,IOINS(B) ;CLOBBER THE IO INS
\r
13413 MOVE A,RDEVIC-1(B) ;GET THE NAME OF THE DEVICE
\r
13417 MOVE B,1(AB) ; RESTORE CHANNEL
\r
13418 CAIE A,(SIXBIT /E&S/)
\r
13419 CAIN A,(SIXBIT /DIS/)
\r
13421 MOVE B,1(AB) ; IN CASE CLOBBERED BY DISCLS
\r
13422 SKIPN A,CHANNO(B) ;ANY REAL CHANNEL?
\r
13423 JRST REMOV ; NO, EITHER CLOSED OR PSEUDO CHANNEL
\r
13425 MOVE A,DIRECT-1(B) ; POINT TO DIRECTION
\r
13427 PUSHJ P,STRTO6 ; CONVERT TO WORD
\r
13429 LDB E,[140600,,(P)] ; FIRST CHAR OD DEV NAME
\r
13430 CAIE E,'T ; SKIP IF TTY
\r
13432 CAME A,[SIXBIT /READ/] ; SKIP IF WINNER
\r
13435 MOVE B,1(AB) ; IN ITS CHECK STATUS
\r
13436 LDB A,[600,,STATUS(B)]
\r
13441 PUSH TP,CHQUOTE CHAR
\r
13444 MCALL 2,OFF ; TURN OFF INTERRUPT
\r
13445 CFIN1: MOVE B,1(AB)
\r
13451 TLZ A,400000 ; FOR JFN RELEASE
\r
13452 CLOSF ; CLOSE THE FILE AND RELEASE THE JFN
\r
13457 ADDI A,CHNL0+1(TVP) ;POINT TO THIS CHANNELS LSOT
\r
13459 SETZM (A) ;AND CLOBBER IT
\r
13460 HLLZS BUFSTR-1(B)
\r
13462 HLLZS ACCESS-1(B)
\r
13463 CFIN2: HLLZS -4(B)
\r
13464 MOVSI A,TCHAN ;RETURN THE CHANNEL
\r
13467 CLSTTY: PUSH TP,$TATOM
\r
13468 PUSH TP,EQUOTE ATTEMPT-TO-CLOSE-TTY-CHANNEL
\r
13472 REMOV: MOVEI D,CHNL0(TVP)+1 ;ATTEMPT TO REMOVE FROM PSUEDO CHANNEL LIST
\r
13473 REMOV0: SKIPN C,D ;FOUND ON LIST ?
\r
13474 JRST CFIN2 ;NO, JUST IGNORE THIS CLOSED CHANNEL
\r
13475 HRRZ D,(C) ;GET POINTER TO NEXT
\r
13476 CAME B,(D)+1 ;FOUND ?
\r
13478 HRRZ D,(D) ;YES, SPLICE IT OUT
\r
13483 ; CLOSE UP ANY LEFTOVER BUFFERS
\r
13485 CFIN4: CAME A,[SIXBIT /PRINTO/]
\r
13486 CAMN A,[SIXBIT /PRINTB/]
\r
13488 CAME A,[SIXBIT /PRINT/]
\r
13490 MOVE B,1(AB) ; GET CHANNEL
\r
13491 GETYP 0,BUFSTR-1(B) ; IS THERE AN OUTPUT BUFFER
\r
13496 IFE ITS, PUSH P,A ; SAVE MODE
\r
13499 POP P,A ; RESTORE MODE
\r
13503 CAME A,[SIXBIT /PRINT/]
\r
13505 MOVE A,CHANNO(B) ; GET JFN
\r
13506 TLO A,400000 ; BIT MEANS DONT RELEASE JFN
\r
13507 CLOSF ; CLOSE THE FILE
\r
13508 FATAL CLOSF LOST?
\r
13509 MOVE E,B ; SAVE CHANNEL
\r
13512 MOVSI B,7700 ; MASK
\r
13513 MOVSI C,700 ; MAKE NEW SIZE 7
\r
13517 MOVE C,ACCESS(E) ; LENGTH IN CHARS
\r
13520 HLLZS BUFSTR-1(B)
\r
13522 CFINX1: HLLZS ACCESS-1(B)
\r
13525 CFIN5: HRRM A,CHANNO-1(B)
\r
13527 \f;SUBR TO DO .ACCESS ON A READ CHANNEL
\r
13528 ;FORM: <ACCESS CHANNEL FIX-NUMBER>
\r
13529 ;POSITIONS CHANNEL AT CHARACTER POSN FIX-NUMBER
\r
13530 ;H. BRODIE 7/26/72
\r
13532 MFUNCTION MACCESS,SUBR,[ACCESS]
\r
13533 ENTRY 2 ;ARGS: CHANNEL AND FIX-NUMBER
\r
13535 ;CHECK ARGUMENT TYPES
\r
13537 CAIE A,TCHAN ;FIRST ARG SHOULD BE CHANNEL
\r
13539 GETYP A,2(AB) ;TYPE OF SECOND
\r
13540 CAIE A,TFIX ;SHOULD BE FIX
\r
13543 ;CHECK DIRECTION OF CHANNEL
\r
13544 MOVE B,1(AB) ;B GETS PNTR TO CHANNEL
\r
13545 MOVEI B,DIRECT-1(B) ;GET DIRECTION OF CHANNEL
\r
13546 PUSHJ P,CHRWRD ;GRAB THE CHAR STRNG
\r
13548 CAME B,[<ASCII /PRINT/>+1]
\r
13550 PUSH P,[2] ;ACCESS ON PRINTB CHANNEL
\r
13552 SKIPE BUFSTR(B) ;SEE IF WE MUST FLUSH PART BUFFER
\r
13555 MACCA: PUSH P,[0] ; READ RATHER THAN READB INDICATOR
\r
13556 CAMN B,[ASCIZ /READ/]
\r
13558 CAME B,[ASCIZ /READB/] ; READB CHANNEL?
\r
13560 AOS (P) ; SET INDICATOR FOR BINARY MODE
\r
13562 ;CHECK THAT THE CHANNEL IS OPEN
\r
13563 MACC: MOVE B,1(AB) ;GET BACK PTR TO CHANNEL
\r
13564 SKIPN CHANNO(B) ;CLOSED CHANNELS HAVE CHANNO ZEROED OUT
\r
13565 JRST CHNCLS ;IF CHNL CLOSED => ERROR
\r
13567 ;COMPUTE ACCESS PNTR TO ACCESS WORD CHAR IS IN
\r
13568 ;REMAINDER IS NUMBER OF TIMES TO INCR BYTE POINTER
\r
13569 ADEVOK: SKIPGE C,3(AB) ;GET CHAR POSN...ALL NEGS = -5
\r
13571 ;BUT .ACCESS -1 ISN'T IMPLEMENTED ON ITS YET, SO TELL HIM
\r
13574 PUSH TP,EQUOTE NEGATIVE-ACCESS-NOT-ON-ITS
\r
13579 ;SETUP THE .ACCESS
\r
13580 MOVE B,1(AB) ;GET BACK PTR TO CHANNEL
\r
13581 MOVE A,CHANNO(B) ;A GETS REAL CHANNEL NUMBER
\r
13583 ROT A,23. ;SET UP IN AC FIELD
\r
13584 IOR A,[.ACCESS 0,C] ;C CONTAINS PLACE TO ACCESS TO
\r
13591 SFPTR ; DO IT IN TENEX
\r
13593 MOVE B,1(AB) ; RESTORE CHANNEL
\r
13595 POP P,E ; CHECK FOR READB MODE
\r
13597 JRST DONADV ; PRINTB CHANNEL
\r
13598 SKIPE BUFSTR(B) ; IS THERE A READ BUFFER TO FLUSH
\r
13600 SETZM LSTCH(B) ; CLEAR OUT POSSIBLE EOF INDICATOR
\r
13603 ;NOW FORCE GETCHR TO DO A .IOT FIRST THING
\r
13604 MOVEI C,BUFSTR-1(B) ; FIND END OF STRING
\r
13606 SUBI A,2 ; LAST REAL WORD
\r
13608 MOVEM A,BUFSTR(B)
\r
13609 HLLZS BUFSTR-1(B) ; CLOBBER CHAR COUNT
\r
13610 MOVEM A,BUFSTR(B)
\r
13611 SETZM LSTCH(B) ;CLOBBER READ'S HIDDEN CHARACTER
\r
13613 ;NOW DO THE APPROPRIATE NUM OF BYTE ADVANCEMENTS
\r
13615 ADVPTR: PUSHJ P,GETCHR
\r
13616 MOVE B,1(AB) ;RESTORE IN CASE CLOBBERED
\r
13619 DONADV: MOVE C,3(AB) ;FIXUP ACCESS SLOT IN CHNL
\r
13620 MOVEM C,ACCESS(B)
\r
13621 MOVE A,$TCHAN ;TYPE OF RESULT = "CHANNEL"
\r
13622 JRST FINIS ;DONE...B CONTAINS CHANNEL
\r
13625 ACCFAI: PUSH TP,$TATOM
\r
13626 PUSH TP,EQUOTE ACCESS-FAILURE
\r
13631 ;WRONG TYPE OF DEVICE ERROR
\r
13632 WRDEV: PUSH TP,$TATOM
\r
13633 PUSH TP,EQUOTE NON-DSK-DEVICE
\r
13636 ; BINARY READ AND PRINT ROUTINES
\r
13638 MFUNCTION PRINTB,SUBR
\r
13642 PBFL: PUSH P,. ; PUSH NON-ZERONESS
\r
13645 MFUNCTION READB,SUBR
\r
13655 BINI1: GETYP 0,(AB) ; SHOULD BE UVEC OR STORE
\r
13659 JRST WTYP1 ; ELSE LOSE
\r
13660 BINI2: MOVE B,1(AB) ; GET IT
\r
13662 SUBI B,(C) ; POINT TO DOPE
\r
13664 PUSHJ P,SAT" ; GET ITS ST.ALOC.TYPE
\r
13668 CAIE 0,TCHAN ; BETTER BE A CHANNEL
\r
13670 MOVE B,3(AB) ; GET IT
\r
13671 MOVEI B,DIRECT-1(B) ; GET DIRECTION OF
\r
13672 PUSHJ P,CHRWRD ; INTO 1 WORD
\r
13675 CAMN B,[ASCII /READB/]
\r
13677 CAMN B,[<ASCII /PRINT/>+1]
\r
13679 JUMPL E,WRONGD ; LOSER
\r
13680 CAME E,(P) ; CHECK WINNGE
\r
13682 MOVE B,3(AB) ; GET CHANNEL BACK
\r
13683 SKIPN A,IOINS(B) ; OPEN?
\r
13684 PUSHJ P,OPENIT ; LOSE
\r
13685 CAMN A,[JRST CHNCLS]
\r
13686 JRST CHNCLS ; LOSE, CLOSED
\r
13687 JUMPN E,BUFOU1 ; JUMP FOR OUTPUT
\r
13688 CAML AB,[-5,,] ; SKIP IF EOF GIVEN
\r
13691 MOVEM 0,EOFCND-1(B)
\r
13693 MOVEM 0,EOFCND(B)
\r
13694 BINI5: SKIPE LSTCH(B) ; INDICATES IF EOF HIT
\r
13696 MOVE A,1(AB) ; GET VECTOR
\r
13697 PUSHJ P,PGBIOI ; READ IT
\r
13698 HLRE C,A ; GET COUNT DONE
\r
13699 HLRE D,1(AB) ; AND FULL COUNT
\r
13700 SUB C,D ; C=> TOTAL READ
\r
13702 JUMPGE A,BINIOK ; NOT EOF YET
\r
13705 MOVSI A,TFIX ; RETURN AMOUNT ACTUALLY READ
\r
13708 BUFOU1: SKIPE BUFSTR(B) ; ANY BUFFERS AROUND?
\r
13709 PUSHJ P,BFCLS1 ; GET RID OF SAME
\r
13715 MOVE A,(AB) ; RET VECTOR ETC.
\r
13720 BINEOF: PUSH TP,EOFCND-1(B)
\r
13721 PUSH TP,EOFCND(B)
\r
13724 MCALL 1,FCLOSE ; CLOSE THE LOSER
\r
13729 PUSHJ P,OPNCHN ;TRY TO OPEN THE LOSER
\r
13730 JUMPE B,CHNCLS ;FAIL
\r
13733 \f; THESE SUBROUTINES BY NDR 9/16/73 TO FACILITATE THE
\r
13734 ; TYPES OF IO NECESSARY TO MAKE MORE EFFICIENT USE OF
\r
13735 ; THE NETWORK AND DO RELATED FILE TRANSFER TYPE OF JOBS.
\r
13737 R1CHAR: SKIPN A,LSTCH(B) ; CHAR READING ROUTINE FOR FCOPY
\r
13740 JUMPL A,.+2 ; IN CASE OF -1 ON STY
\r
13741 TRZN A,400000 ; EXCL HACKER
\r
13743 MOVEM A,LSTCH(B) ; SAVE DE-EXCLED CHAR
\r
13748 HRRZ C,DIRECT-1(B)
\r
13749 CAIE C,5 ; IF DIRECTION IS 5 LONG THEN READB
\r
13751 AOS C,ACCESS-1(B)
\r
13753 AOS ACCESS(B) ; EVERY FIFTY INCREMENT
\r
13755 HLLZS ACCESS-1(B)
\r
13757 R1CH1: AOS ACCESS(B)
\r
13761 W1CHAR: CAIE A,15 ; CHAR WRITING ROUTINE, TEST FOR CR
\r
13765 CAIE A,12 ; TEST FOR LF
\r
13766 AOS CHRPOS(B) ; IF NOT LF AOS CHARACTE5R POSITION
\r
13767 CAIE A,14 ; TEST FOR FORM FEED
\r
13769 SETZM CHRPOS(B) ; IF FORM FEED ZERO CHARACTER POSITION
\r
13770 SETZM LINPOS(B) ; AND LINE POSITION
\r
13771 CAIE A,11 ; IS THIS A TAB?
\r
13776 IMULI C,8. ; FIX UP CHAR POS FOR TAB
\r
13777 MOVEM C,CHRPOS(B) ; AND SAVE
\r
13779 HRRZ C,DIRECT-1(B)
\r
13780 CAIE C,6 ; SIX LONG MUST BE PRINTB
\r
13782 AOS C,ACCESS-1(B)
\r
13786 HLLZS ACCESS-1(B)
\r
13788 W1CH1: AOS ACCESS(B)
\r
13793 R1C: SUBM M,(P) ;LITTLE ENTRY FOR COMPILED STUFF
\r
13794 PUSH TP,$TCHAN ;SAVE THE CHANNEL TO BLESS IT
\r
13796 MOVEI B,DIRECT-1(B)
\r
13799 CAME B,[ASCIZ /READ/]
\r
13800 CAMN B,[ASCII /READB/]
\r
13805 SKIPN IOINS(B) ; IS THE CHANNEL OPEN
\r
13806 PUSHJ P,OPENIT ; NO, GO DO IT
\r
13807 PUSHJ P,GRB ; MAKE SURE WE HAVE A READ BUFFER
\r
13808 PUSHJ P,R1CHAR ; AND GET HIM A CHARACTER
\r
13809 JRST MPOPJ ; THATS ALL FOLKS
\r
13815 W1CI: PUSH TP,$TCHAN
\r
13817 PUSH P,A ; ASSEMBLER ENTRY TO OUTPUT 1 CHAR
\r
13818 MOVEI B,DIRECT-1(B)
\r
13819 PUSHJ P,CHRWRD ; INTERNAL CALL TO W1CHAR
\r
13821 CAME B,[ASCII /PRINT/]
\r
13822 CAMN B,[<ASCII /PRINT/>+1]
\r
13827 SKIPN IOINS(B) ; MAKE SURE THAT IT IS OPEN
\r
13830 POP P,A ; GET THE CHAR TO DO
\r
13833 ; ROUTINES TO REPLACE XCT IOINS(B) FOR INPUT AND OUTPUT
\r
13834 ; THEY DO THE XCT THEN CHECK OUT POSSIBLE SCRIPTAGE--BLECH.
\r
13837 WXCT: PUSH P,A ; SAVE THE CHAR TO WRITE
\r
13838 PUSH TP,$TCHAN ; AND SAVE THE CHANNEL TOO
\r
13840 XCT IOINS(B) ; DO THE REAL ONE
\r
13841 JRST DOSCPT ; AND CHECK OUT SCRIPTAGE
\r
13843 RXCT: PUSH TP,$TCHAN
\r
13844 PUSH TP,B ; DO IT FOR READS, SAVE THE CHAN
\r
13845 XCT IOINS(B) ; READ IT
\r
13846 PUSH P,A ; AND SAVE THE CHAR AROUND
\r
13847 JRST DOSCPT ; AND CHECK OUT SCRIPTAGE
\r
13849 DOSCPT: MOVE B,(TP) ;CHECK FOR SCRIPTAGE
\r
13850 SKIPN SCRPTO(B) ; IF ZERO FORGET IT
\r
13851 JRST SCPTDN ; THATS ALL THERE IS TO IT
\r
13852 PUSH P,C ; SAVE AN ACCUMULATOR FOR CLEANLINESS
\r
13853 GETYP C,SCRPTO-1(B) ; IS IT A LIST
\r
13857 PUSH TP,[0] ; SAVE A SLOT FOR THE LIST
\r
13858 MOVE C,SCRPTO(B) ; GET THE LIST OF SCRIPT CHANNELS
\r
13859 SCPT1: GETYP B,(C) ; GET THE TYPE OF THIS SCRIPT CHAN
\r
13861 JRST BADCHN ; IF IT ISN'T A CHANNEL, COMPLAIN
\r
13862 HRRZ B,(C) ; GET THE REST OF THE LIST IN B
\r
13863 MOVEM B,(TP) ; AND STORE ON STACK
\r
13864 MOVE B,1(C) ; GET THE CHANNEL IN B
\r
13865 MOVE A,-1(P) ; AND THE CHARACTER IN A
\r
13866 PUSHJ P,W1CI ; GO TO INTERNAL W1C, IT BLESSES GOODIES
\r
13867 SKIPE C,(TP) ; GET THE REST OF LIST OF CHANS
\r
13868 JRST SCPT1 ; AND CYCLE THROUGH
\r
13869 SUB TP,[2,,2] ; CLEAN OFF THE LIST OF CHANS
\r
13870 POP P,C ; AND RESTORE ACCUMULATOR C
\r
13871 SCPTDN: POP P,A ; RESTORE THE CHARACTER
\r
13872 POP TP,B ; AND THE ORIGINAL CHANNEL
\r
13874 POPJ P, ; AND THATS ALL
\r
13877 ; SUBROUTINE TO COPY FROM INCHAN TO OUTCHAN UNTIL EOF HIT
\r
13878 ; ON THE INPUT CHANNEL
\r
13879 ; CALL IS <FILECOPY IN OUT> WHERE DEFAULTS ARE INCHAN AND OUTCHAN
\r
13881 MFUNCTION FCOPY,SUBR,[FILECOPY]
\r
13886 JRST WNA ; TAKES FROM 0 TO 2 ARGS
\r
13888 JUMPE 0,.+4 ; NO FIRST ARG?
\r
13890 PUSH TP,1(AB) ; SAVE IN CHAN
\r
13893 MOVE B,IMQUOTE INCHAN
\r
13897 HLRE 0,AB ; CHECK FOR SECOND ARG
\r
13898 CAML 0,[-2] ; WAS THERE MORE THAN ONE ARG?
\r
13900 PUSH TP,2(AB) ; SAVE SECOND ARG
\r
13903 MOVE A,$TATOM ; LOOK UP OUTCHAN AS DEFAULT
\r
13904 MOVE B,IMQUOTE OUTCHAN
\r
13907 PUSH TP,B ; AND SAVE IT
\r
13910 MOVE B,-2(TP) ; INPUT CHANNEL
\r
13911 MOVEI 0,0 ; INDICATE INPUT
\r
13912 PUSHJ P,CHKCHN ; CHECK FOR GOOD CHANNEL
\r
13914 MOVE B,(TP) ; GET OUT CHAN
\r
13915 MOVEI 0,1 ; INDICATE OUT CHAN
\r
13916 PUSHJ P,CHKCHN ; CHECK FOR GOOD OUT CHAN
\r
13918 PUSH P,[0] ; COUNT OF CHARS OUTPUT
\r
13921 PUSHJ P,GRB ; MAKE SURE WE HAVE READ BUFF
\r
13923 PUSHJ P,GWB ; MAKE SURE WE HAVE WRITE BUFF
\r
13925 FCLOOP: MOVE B,-2(TP)
\r
13926 PUSHJ P,R1CHAR ; GET A CHAR
\r
13927 JUMPL A,FCDON ; IF A NEG NUMBER WE GOT EOF
\r
13928 MOVE B,(TP) ; GET OUT CHAN
\r
13929 PUSHJ P,W1CHAR ; SPIT IT OUT
\r
13930 AOS (P) ; INCREMENT COUNT
\r
13933 FCDON: SUB TP,[2,,2] ; POP OFF OUTCHAN
\r
13934 MCALL 1,FCLOSE ; CLOSE INCHAN
\r
13936 POP P,B ; GET CHAR COUNT TO RETURN
\r
13939 CHKCHN: PUSH P,0 ; CHECK FOR GOOD TASTING CHANNEL
\r
13944 JRST CHKBDC ; GO COMPLAIN IN RIGHT WAY
\r
13945 MOVEI B,DIRECT-1(B)
\r
13948 MOVE C,(P) ; GET CHAN DIRECT
\r
13951 ADDI C,2 ; TEST FOR READB OR PRINTB ALSO
\r
13952 CAME B,CHKT(C) ; TEST FOR CORRECT DIRECT
\r
13955 SKIPN IOINS(B) ; MAKE SURE IT IS OPEN
\r
13956 PUSHJ P,OPENIT ; IF ZERO IOINS GO OPEN IT
\r
13958 POP P, ; CLEAN UP STACKS
\r
13961 CHKT: ASCIZ /READ/
\r
13964 <ASCII /PRINT/>+1
\r
13970 CAMLE 0,D ; SEE IF THIS WAS HIS ARG OF DEFAULT
\r
13975 \f; FUNCTIONS READSTRING AND PRINTSTRING WORK LIKE READB AND PRINTB,
\r
13976 ; THAT IS THEY READ INTO AND OUT OF STRINGS. IN ADDITION BOTH ACCEPT
\r
13977 ; AN ADDITIONAL ARGUMENT WHICH IS THE NUMBER OF CHARS TO READ OR PRINT, IF
\r
13978 ; IT IS DESIRED FOR THIS TO BE DIFFERENT THAN THE LENGTH OF THE STRING.
\r
13980 ; FORMAT IS <READSTRING .STRING .INCHANNEL .EOFCOND .MAXCHARS>
\r
13981 ; AND BOTH SUBRS RETURN THE NUMBER OF CHARS READ OR WRITTEN
\r
13983 ; FORMAT FOR PRINTSTRING IS <PRINTSTRING .STRING .OUTCHANNEL .MAXCHARS>
\r
13985 ; THESE WERE CODED 9/16/73 BY NEAL D. RYAN
\r
13987 MFUNCTION RSTRNG,SUBR,READSTRING
\r
13990 PUSH P,[0] ; FLAG TO INDICATE READING
\r
13994 JRST WNA ; CHECK THAT IT HAS FROM 1 TO 4 ARGS
\r
13997 MFUNCTION PSTRNG,SUBR,PRINTSTRING
\r
14000 PUSH P,[1] ; FLAG TO INDICATE WRITING
\r
14004 JRST WNA ; CHECK THAT IT HAS FROM 1 TO 3 ARGS
\r
14006 STRIO1: PUSH TP,[0] ; SAVE SLOT ON STACK
\r
14009 CAIE 0,TCHSTR ; MAKE SURE WE GOT STRING
\r
14011 HRRZ 0,(AB) ; CHECK FOR EMPTY STRING
\r
14015 CAML 0,[-2] ; WAS A CHANNEL GIVEN
\r
14019 JRST WTYP2 ; SECOND ARG NOT CHANNEL
\r
14021 MOVEI B,DIRECT-1(B)
\r
14024 MOVNI E,1 ; CHECKING FOR GOOD DIRECTION
\r
14025 CAMN B,[ASCII /READ/]
\r
14027 CAMN B,[ASCII /PRINT/]
\r
14029 CAMN B,[<ASCII /PRINT/>+1]
\r
14031 CAMN B,[ASCII /READB/]
\r
14034 JRST WRONGD ; MAKE SURE CHANNEL IS OPEN IN RIGHT MODE
\r
14036 PUSH TP,3(AB) ; PUSH ON CHANNEL
\r
14038 STRIO2: MOVE B,IMQUOTE INCHAN
\r
14041 MOVE B,IMQUOTE OUTCHAN
\r
14043 TLZ A,TYPMSK#777777
\r
14045 JRST BADCHN ; MAKE SURE WE GOT A GOOD DEFAULT CHANNEL
\r
14048 STRIO3: MOVE B,(TP) ; GET CHANNEL
\r
14049 SKIPN E,IOINS(B) ; MAKE SURE HE IS OPEN
\r
14050 PUSHJ P,OPENIT ; IF NOT GO OPEN
\r
14051 CAMN E,[JRST CHNCLS]
\r
14052 JRST CHNCLS ; CHECK TO SEE THAT CHANNEL ISNT ALREADY CLOSED
\r
14053 STRIO4: HLRE 0,AB
\r
14055 JRST STRIO5 ; NO COUNT TO WORRY ABOUT
\r
14060 CAIN 0,TFIX ; BETTER BE A FIXED NUMBER
\r
14063 HRRZ D,(AB) ; GET ACTUAL STRING LENGTH
\r
14066 SKIPE (P) ; TEST FOR WRITING
\r
14067 JRST .-7 ; IF WRITING WE GOT TROUBLE
\r
14068 PUSH P,D ; ACTUAL STRING LENGTH
\r
14069 MOVEM E,(TB) ; STUFF HIS FUNNY DELIM STRING
\r
14072 CAML D,C ; MAKE SURE THE STRING IS LONG ENOUGH
\r
14074 PUSH TP,$TATOM ; LOSAGE, COUNT TOO GREAT
\r
14075 PUSH TP,EQUOTE COUNT-GREATER-THAN-STRING-SIZE
\r
14077 PUSH P,C ; PUSH ON MAX COUNT
\r
14080 STRIO6: HRRZ C,(AB) ; GET CHAR COUNT
\r
14081 PUSH P,C ; AND PUSH IT ON STACK AS NO MAX COUNT GIVEN
\r
14082 STRIO7: HLRE 0,AB
\r
14085 MOVE B,(TP) ; GET THE CHANNEL
\r
14087 MOVEM 0,EOFCND-1(B) ; STUFF IN SLOT IN CHAN
\r
14089 MOVEM 0,EOFCND(B)
\r
14090 PUSH TP,(AB) ; PUSH ON STRING
\r
14092 PUSH P,[0] ; PUSH ON CURRENT COUNT OF CHARS DONE
\r
14093 MOVE 0,-2(P) ; GET READ OR WRITE FLAG
\r
14094 JUMPN 0,OUTLOP ; GO WRITE STUFF
\r
14096 MOVE B,-2(TP) ; GET CHANNEL
\r
14097 PUSHJ P,GRB ; MAKE SURE WE HAVE BUFF
\r
14098 SKIPGE A,LSTCH(B) ; CHECK FOR EOF ALREADY READ PREVIOUSLY
\r
14099 JRST SRDOEF ; GO DOES HIS EOF HACKING
\r
14101 MOVE B,-2(TP) ; GET CHANNEL
\r
14102 MOVE C,-1(P) ; MAX COUNT
\r
14103 CAMG C,(P) ; COMPARE WITH COUNT DONE
\r
14104 JRST STREOF ; WE HAVE FINISHED
\r
14105 PUSHJ P,R1CHAR ; GET A CHAR
\r
14106 JUMPL A,INEOF ; EOF HIT
\r
14108 HRRZ E,(TB) ; DO WE HAVE A STRING TO WORRY US?
\r
14109 SOJL E,INLNT ; GO FINISH STUFFING
\r
14114 INLNT: IDPB A,(TP) ; STUFF IN STRING
\r
14115 SOS -1(TP) ; DECREMENT STRING COUNT
\r
14116 AOS (P) ; INCREMENT CHAR COUNT
\r
14119 INEOF: SKIPE C,LSTCH(B) ; IS THIS AN ! AND IS THERE A CHAR THERE
\r
14121 MOVEM A,LSTCH(B) ; NO SAVE THE CHAR
\r
14125 HRRZ C,DIRECT-1(B) ; GET THE TYPE OF CHAN
\r
14126 CAIN C,5 ; IS IT READB?
\r
14128 SOS ACCESS(B) ; FIX UP ACCESS FOR READ CHANNEL
\r
14129 JRST STREOF ; AND THATS IT
\r
14130 HRRZ C,ACCESS-1(B) ; FOR A READB ITS WORSE
\r
14133 HRRM D,ACCESS-1(B) ; CHANGE A 0 TO A FIVE
\r
14134 SOS C,ACCESS-1(B)
\r
14136 SOS ACCESS(B) ; AND SOS THE WORD COUNT MAYBE
\r
14139 SRDOEF: SETZM LSTCH(B) ; IN CASE OF -1, FLUSH IT
\r
14140 AOJE A,INLOP ; SKIP OVER -1 ON PTY'S
\r
14142 SUB P,[3,,3] ; POP JUNK OFF STACKS
\r
14143 PUSH TP,EOFCND-1(B)
\r
14144 PUSH TP,EOFCND(B) ; WHAT WE NEED TO EVAL
\r
14147 MCALL 1,FCLOSE ; CLOSE THE LOOSING CHANNEL
\r
14148 MCALL 1,EVAL ; EVAL HIS EOF JUNK
\r
14151 OUTLOP: MOVE B,-2(TP)
\r
14152 PUSHJ P,GWB ; MAKE SURE WE HAVE BUFF
\r
14155 MOVE C,-1(P) ; MAX COUNT TO DO
\r
14156 CAMG C,(P) ; HAVE WE DONE ENOUGH
\r
14158 ILDB A,(TP) ; GET THE CHAR
\r
14159 SOS -1(TP) ; SUBTRACT FROM STRING LENGTH
\r
14160 AOS (P) ; INC COUNT OF CHARS DONE
\r
14161 PUSHJ P,W1CHAR ; GO STUFF CHAR
\r
14164 STREOF: MOVE A,$TFIX
\r
14165 POP P,B ; RETURN THE LOOSER A COUNT OF WHAT WAS DONE
\r
14171 GWB: SKIPE BUFSTR(B)
\r
14174 PUSH TP,B ; GET US A WRITE BUFFER ON PRINTB CHAN
\r
14177 MOVSI A,TWORD+.VECT.
\r
14178 MOVEM A,BUFLNT(B)
\r
14182 BLT C,BUFLNT-1(B)
\r
14188 MOVEM C,BUFSTR(B)
\r
14189 MOVE C,[TCHSTR,,BUFLNT*5]
\r
14190 MOVEM C,BUFSTR-1(B)
\r
14195 GRB: SKIPE BUFSTR(B)
\r
14198 PUSH TP,B ; GET US A READ BUFFER
\r
14201 MOVEI C,BUFLNT(B)
\r
14206 MOVEM C,BUFSTR(B)
\r
14208 MOVEM C,BUFSTR-1(B)
\r
14212 MTSTRN: PUSH TP,$TATOM
\r
14213 PUSH TP,EQUOTE EMPTY-STRING
\r
14216 \f; INPUT UNBUFFERING ROUTINE. THIS DOES THE CHARACTER UNBUFFERING
\r
14217 ; FOR INPUT. THE OPEN ROUTINE SETUPS A PUSHJ P, TO
\r
14218 ; THIS ROUTINE AS THE IOINS FOR A CHANNEL OPEN TO A NON-TTY DEVICE.
\r
14220 ; H. BRODIE 7/19/72
\r
14224 ; B/ AOBJN PNTR TO CHANNEL VECTOR
\r
14225 ; RETURNS NEXT CHARACTER IN AC A.
\r
14226 ; ON ENCOUNTERING EITHER ^C OR NUL(^@) IT ASSUMES EOF AND
\r
14227 ; TRANSMITS ONLY ^C ON SUCCESSIVE CALLS
\r
14231 ; FIRST GRAB THE BUFFER
\r
14232 GETYP A,BUFSTR-1(B) ; GET TYPE WORD
\r
14233 CAIN A,TCHSTR ; SKIPS IF NOT CHSTR (I.E. IF BAD BUFFER)
\r
14234 JRST GTGBUF ; IS GOOD BUFFER...SKIP ERROR RETURN
\r
14235 BDCHAN: PUSH TP,$TATOM ; ERROR RETURN
\r
14236 PUSH TP,EQUOTE BAD-INPUT-BUFFER
\r
14239 ; BUFFER WAS GOOD
\r
14240 GTGBUF: HRRZ A,BUFSTR-1(B) ; GET LENGTH OF STRING
\r
14241 SOJGE A,GTGCHR ; JUMP IF STILL MORE
\r
14243 ; HERE IF THE BUFFER WAS EXHAUSTED (BYTE PNTR POINTS INTO DOPE WDS)
\r
14244 ; GENERATE AN .IOT POINTER
\r
14245 ;FIRST SAVE C AND D AS I WILL CLOBBER THEM
\r
14249 LDB C,[600,,STATUS(B)] ; GET TYPE
\r
14250 CAIG C,2 ; SKIP IF NOT TTY
\r
14255 JRST GETTTY ; GET A TTY BUFFER
\r
14257 PUSHJ P,PGBUFI ; RE-FILL BUFFER
\r
14259 JUMPGE A,BUFGOO ;SKIPS IF IOT COMPLETED...FIX UP CHANNEL
\r
14260 MOVEI C,1 ; MAKE SURE LAST EOF REALLY ENDS IT
\r
14262 MOVSI C,014000 ; GET A ^C
\r
14263 MOVEM C,(A) ;FAKE AN EOF
\r
14265 ; RESET THE BYTE POINTER IN THE CHANNEL.
\r
14266 ; BUILD ONE USING THE PTR TO BEG OF BUFFER SAVED IN D
\r
14267 BUFGOO: HRLI D,440700 ; GENERATE VIRGIN LH
\r
14269 MOVEM D,BUFSTR(B) ; STASH IN THE BUFFER BYTE PNTR SLOT
\r
14270 MOVEI A,BUFLNT*5-1
\r
14271 BUFROK: POP P,D ;RESTORE D
\r
14272 POP P,C ;RESTORE C
\r
14275 ; HERE IF THERE ARE CHARS IN BUFFER
\r
14276 GTGCHR: HRRM A,BUFSTR-1(B)
\r
14277 ILDB A,BUFSTR(B) ; GET A CHAR FROM BUFFER
\r
14279 CAIN A,32 ; TENEX EOF?
\r
14283 POPJ P, ; AND RETURN
\r
14285 LDB A,[600,,STATUS(B)] ; CHECK FOR TTY
\r
14286 CAILE A,2 ; SKIP IF TTY
\r
14288 IFE ITS, SKIPN BUFRIN(B)
\r
14294 HRRZ A,@BUFSTR(B) ; SEE IF RSUBR START BIT IS ON
\r
14304 PGBUFO: SKIPA D,[SOUT]
\r
14305 PGBUFI: MOVE D,[SIN]
\r
14307 SKIPGE A,BUFSTR(B) ; POINT TO CURRENT BUFFER POSIT
\r
14308 SUBI A,1 ; FOR 440700 AND 010700 START
\r
14309 SUBI A,BUFLNT-1 ; CALCULATE PNTR TO BEG OF BUFFER
\r
14310 HRLI A,-BUFLNT ; IOT (AOBJN) PNTR IN A
\r
14313 PGBIOI: MOVE D,A ; COPY FOR LATER
\r
14314 MOVSI C,TUVEC ; PREPARE TO HANDDLE INTS
\r
14315 MOVEM C,DSTO(PVP)
\r
14316 MOVEM C,ASTO(PVP)
\r
14318 MOVEM C,BSTO(PVP)
\r
14320 ; BUILD .IOT INSTR
\r
14321 MOVE C,CHANNO(B) ; CHANNEL NUMBER IN C
\r
14322 ROT C,23. ; MOVE INTO AC FIELD
\r
14323 IOR C,[.IOT 0,A] ; IOR IN SKELETON .IOT
\r
14326 ENABLE ; ALLOW INTS
\r
14327 XCT C ; EXECUTE THE .IOT INSTR
\r
14339 MOVEI C,(A) ; POINT TO BUFFER
\r
14341 MOVE D,A ; XTRA POINTER
\r
14342 MOVE A,CHANNO(B) ; FILE JFN
\r
14344 HLRE C,D ; - COUNT TO C
\r
14345 XCT (P) ; DO IT TO IT
\r
14350 JUMPGE C,CPOPJ ; NO EOF YET
\r
14351 HRLI A,(C) ; LOOK LIKE AN AOBJN PNTR
\r
14354 PGBIOO: SKIPA D,[SOUT]
\r
14355 PGBIOI: MOVE D,[SIN]
\r
14369 ; OUTPUT BUFFERING ROUTINES SIMILAR TO INPUT BUFFERING ROUTINES OF PREV PAGE
\r
14372 GETYP A,BUFSTR-1(B) ; CHECK TYPE OF ARG
\r
14373 CAIE A,TCHSTR ; MUST BE STRING
\r
14376 HRRZ A,BUFSTR-1(B) ; GET CHAR COUNT
\r
14377 JUMPE A,REBUFF ; PREV RESET BUFF, UNDO SAME
\r
14379 PUTCH1: POP P,A ; RESTORE CHAR
\r
14380 CAMN A,[-1] ; SPECIAL HACK?
\r
14381 JRST PUTCH2 ; YES GO HANDLE
\r
14382 IDPB A,BUFSTR(B) ; STUFF IT
\r
14383 PUTCH3: SOS A,BUFSTR-1(B) ; COUNT DOWN STRING
\r
14384 TRNE A,-1 ; SKIP IF FULL
\r
14387 ; HERE TO FLUSH OUT A BUFFER
\r
14391 PUSHJ P,PGBUFO ; SETUP AND DO IOT
\r
14392 HRLI D,440700 ; POINT INTO BUFFER
\r
14393 MOVEM D,BUFSTR(B) ; STORE IT
\r
14394 MOVEI A,BUFLNT*5 ; RESET COUNT
\r
14395 HRRM A,BUFSTR-1(B)
\r
14400 ;HERE TO DA ^C AND TURN ON MAGIC BIT
\r
14402 PUTCH2: MOVEI A,3
\r
14403 IDPB A,BUFSTR(B) ; ZAP OUT THE ^C
\r
14404 MOVEI A,1 ; GET BIT
\r
14405 IORM A,@BUFSTR(B) ; ON GOES THE BIT
\r
14408 ; RESET A FUNNY BUF
\r
14410 REBUFF: MOVEI A,BUFLNT*5 ; 1ST COUNT
\r
14411 HRRM A,BUFSTR-1(B)
\r
14412 HRRZ A,BUFSTR(B) ; NOW POINTER
\r
14415 MOVEM A,BUFSTR(B) ; STORE BACK
\r
14419 ; HERE TO FLUSH FINAL BUFFER
\r
14421 BFCLOS: HLLZS ACCESS-1(B) ; CLEAR OUT KLUDGE PRINTB PART ACCESS COUNT
\r
14422 MOVE C,B ; THIS BUFFER FLUSHER THE WORK OF NDR
\r
14423 MOVEI B,RDEVIC-1(B) ; FIND OUT IF THIS IS NET
\r
14426 TRZ B,77777 ; LEAVE ONLY HIGH 3 CHARS
\r
14427 MOVEI A,0 ; FLAG 0=NET 1=DSK
\r
14428 CAME B,[ASCIZ /NET/] ; IS THIS NET?
\r
14430 PUSH P,A ; SAVE THE RESULT OF OUR TEST
\r
14431 MOVE B,C ; RESTORE CHANNEL IN B
\r
14432 JUMPN A,BFCLNN ; DONT HAVE TO CHECK NET STATE
\r
14434 PUSH TP,B ; SAVE CHANNEL
\r
14435 PUSHJ P,INSTAT ; GET CURRENT NETWORK STATE
\r
14436 MOVE A,(B) ; GET FIRST ELEMENT OF STATE UVECTOR WHICH IS CUR STATE
\r
14437 POP TP,B ; RESTORE B
\r
14439 CAIE A,5 ; IS NET IN OPEN STATE?
\r
14440 CAIN A,6 ; OR ELSE IS IT IN RFNM WAIT STATE
\r
14441 JRST BFCLNN ; IF SO TO THE IOT
\r
14442 POP P, ; ELSE FLUSH CRUFT AND DONT IOT
\r
14443 POPJ P, ; RETURN DOING NO IOT
\r
14444 BFCLNN: MOVEI C,BUFLNT*5 ; NEW BUFFER FLUSHER BY NDR
\r
14445 HRRZ D,BUFSTR-1(B) ; SO THAT NET ALSO WORKS RIGHT
\r
14446 SUBI C,(D) ; GET NUMBER OF CHARS
\r
14447 IDIVI C,5 ; NUMBER OF FULL WORDS AND REST
\r
14448 PUSH P,D ; SAVE NUMBER OF ODD CHARS
\r
14449 SKIPGE A,BUFSTR(B) ; GET CURRENT BUF POSITION
\r
14450 SUBI A,1 ; FIX FOR 440700 BYTE POINTER
\r
14451 PUSH P,(A) ; SAVE THE ODD WORD OF BUFFER
\r
14456 ADDI D,1(A) ; FIX UP FOR POSSIBLE ODD CHARS
\r
14458 PUSH TP,D ; PUSH THE DOPE VECTOR ONTO THE STACK
\r
14459 JUMPE C,BFCLSR ; IN CASE THERE ARE NO FULL WORDS TO DO
\r
14461 MOVE E,[A,,BUFLNT]
\r
14462 SUBI E,(C) ; FIX UP FOR BACKWARDS BLT
\r
14463 POP A,@E ; AMAZING GRACE
\r
14466 HRRO A,D ; SET UP AOBJN POINTER
\r
14469 PUSHJ P,PGBIOO ; DO THE IOT OF ALL THE FULL WORDS
\r
14470 BFCLSR: HRRO A,(TP) ; GET IOT PTR FOR REST OF JUNK
\r
14471 SUBI A,1 ; POINT TO WORD BEFORE DOPE WORDS
\r
14472 POP P,0 ; GET BACK ODD WORD
\r
14473 POP P,C ; GET BACK ODD CHAR COUNT
\r
14474 POP P,D ; FLAG FOR NET OR DSK
\r
14475 JUMPE C,BFCLSD ; IF NO ODD CHARS FINISH UP
\r
14476 JUMPN D,BFCDSK ; GO FINISH OFF DSK
\r
14478 IMULI D,(C) ; FIND NO OF BITS TO SHIFT
\r
14479 LSH 0,-43(D) ; SHIFT BITS TO RIGHT PLACE
\r
14480 MOVEM 0,(A) ; STORE IN STRING
\r
14481 SUBI C,5 ; HOW MANY CHAR POSITIONS TO SKIP
\r
14482 MOVNI C,(C) ; MAKE C POSITIVE
\r
14484 TLC A,(C) ; MUNG THE AOBJN POINTER TO KLUDGE
\r
14485 PUSHJ P,PGBIOO ; DO IOT OF ODD CHARS
\r
14486 BFCLSD: HRRZ A,(TP) ; GET PTR TO DOPE WORD
\r
14488 HRLI A,440700 ; AOBJN POINTER TO FIRST OF BUFFER
\r
14489 MOVEM A,BUFSTR(B)
\r
14491 HRRM A,BUFSTR-1(B)
\r
14495 BFCDSK: MOVE C,A ; FOR FUNNY AOBJN PTR
\r
14496 HLL C,BUFSTR(B) ; POINT INTO WORD AFTER LAST CHAR
\r
14499 IFN ITS, MOVEI 0,3 ; CONTROL C
\r
14500 IFE ITS, MOVEI 0,32 ; CNTL Z
\r
14505 BFCLS1: HRRZ C,DIRECT-1(B)
\r
14508 MOVE 0,[AOS ACCESS(B)]
\r
14510 HRRZ C,BUFSTR-1(B)
\r
14513 MOVEI A,40 ; PAD WITH SPACES
\r
14515 XCT (P) ; AOS ACCESS IF NECESSARY
\r
14516 SOJG D,.-3 ; TO END OF WORD
\r
14518 HLLZS ACCESS-1(B)
\r
14519 HRRZ C,BUFSTR-1(B)
\r
14525 ; HERE TO GET A TTY BUFFER
\r
14527 GETTTY: SKIPN C,EXBUFR(B) ; SKIP IF BUFFERS BACKED UP
\r
14529 HRRZ D,(C) ; CDR THE LIST
\r
14530 GETYP A,(C) ; CHECK TYPE
\r
14531 CAIE A,TDEFER ; MUST BE DEFERRED
\r
14533 MOVE C,1(C) ; GET DEFERRED GOODIE
\r
14534 GETYP A,(C) ; BETTER BE CHSTR
\r
14537 MOVE A,(C) ; GET FULL TYPE WORD
\r
14539 MOVEM D,EXBUFR(B) ; STORE CDR'D LIST
\r
14540 MOVEM A,BUFSTR-1(B) ; MAKE CURRENT BUFFER
\r
14541 MOVEM C,BUFSTR(B)
\r
14544 TTYWAI: PUSHJ P,TTYBLK ; BLOCKED FOR TTY I/O
\r
14545 JRST GETTTY ; SHOULD ONLY RETURN HAPPILY
\r
14547 \f;INTERNAL DEVICE READ ROUTINE.
\r
14549 ;FOR INTERNAL DEVICES THIS ROUTINE APPLIES THE GIVEN OBJECT,
\r
14550 ;CHECKS THAT THE RETURNED VALUE IS OF TYPE CHARACTER,
\r
14551 ;AND RETURNS THAT AS THE NEXT CHARACTER IN THE "FILE"
\r
14553 ;H. BRODIE 8/31/72
\r
14555 GTINTC: PUSH TP,$TCHAN ;SAVE THE CHANNEL...WE'LL CLOBBER B
\r
14557 PUSH P,C ;AND SAVE THE OTHER ACS
\r
14561 PUSH TP,INTFCN-1(B)
\r
14562 PUSH TP,INTFCN(B)
\r
14568 INTRET: POP P,0 ;RESTORE THE ACS
\r
14572 POP TP,B ;RESTORE THE CHANNEL
\r
14573 SUB TP,[1,,1] ;FLUSH $TCHAN...WE DON'T NEED IT
\r
14577 BADRET: PUSH TP,$TATOM
\r
14578 PUSH TP,EQUOTE INT-DEVICE-WRONG-TYPE-EVALUATION-RESULT
\r
14581 ;INTERNAL DEVICE PRINT ROUTINE.
\r
14583 ;FOR INTERNAL DEVICES THIS ROUTINE APPLIES THE GIVEN OBJECT,(FUNCTION, SUBR, OR RSUBR)
\r
14584 ;TO THE CURRENT CHARACTER BEING "PRINTED".
\r
14586 PTINTC: PUSH TP,$TCHAN ;SAVE THE CHANNEL...WE'LL CLOBBER B
\r
14588 PUSH P,C ;AND SAVE THE OTHER ACS
\r
14592 PUSH TP,INTFCN-1(B) ;PUSH TYPE OF GIVEN OBJ
\r
14593 PUSH TP,INTFCN(B) ;PUSH THE SUPPLIED FUNCTION (OR SUBR ETC.)
\r
14594 PUSH TP,$TCHRS ;PUSH THE TYPE "CHARACTER"
\r
14595 PUSH TP,A ;PUSH THE CHAR
\r
14596 MCALL 2,APPLY ;APPLY THE FUNCTION TO THE CHAR
\r
14601 ; ROUTINE TO FLUSH OUT A PRINT BUFFER
\r
14603 MFUNCTION BUFOUT,SUBR
\r
14612 MOVEI B,DIRECT-1(B)
\r
14613 PUSHJ P,CHRWRD ; GET DIR NAME
\r
14615 CAMN B,[ASCII /PRINT/]
\r
14617 CAME B,[<ASCII /PRINT/>+1]
\r
14619 TRNE B,1 ; SKIP IF PRINT
\r
14621 TRNN B,1 ; SKIP IF PRINTB
\r
14622 PUSH P,[AOS ACCESS(B)]
\r
14624 GETYP 0,BUFSTR-1(B)
\r
14626 SKIPN C,BUFSTR(B) ; BYTE POINTER?
\r
14628 HRRZ C,BUFSTR-1(B) ; CHARS LEFT
\r
14629 IDIVI C,5 ; MULTIPLE OF 5?
\r
14630 JUMPE D,BFIN2 ; YUP NO EXTRAS
\r
14632 MOVEI A,40 ; PAD WITH SPACES
\r
14633 PUSHJ P,PUTCHR ; OUT IT GOES
\r
14634 XCT (P) ; MAYBE BUMP ACCESS
\r
14635 SOJG D,.-3 ; FILL
\r
14637 BFIN2: PUSHJ P,BFCLOS ; WRITE OUT BUFFER
\r
14638 BFIN1: MOVSI A,TCHAN
\r
14643 ; FUNCTION TO GET THE FILE LENGTH OF A READ CHANNEL
\r
14645 MFUNCTION FILLNT,SUBR,[FILE-LENGTH]
\r
14652 MOVEI B,DIRECT-1(B) ; GET CHANNEL TYPE
\r
14655 CAME B,[ASCIZ /READ/]
\r
14657 PUSH P,[5] ; MULTIPLICATIVE FACTOR FOR READ
\r
14659 CAME B,[ASCII /READB/]
\r
14661 PUSH P,[1] ; MULTIPLICATIVE FACTOR FOR READ
\r
14665 JRST FILLOS ; GIVE HIM A NICE FALSE
\r
14678 FILL1: SETZ ; BLOCK FOR .CALL TO FILLEN
\r
14683 FILLOS: MOVE A,CHANNO(C)
\r
14688 FILLOS: PUSHJ P,TGFALS
\r
14693 \f;THREE GENERALLY USEFUL ERROR ROUTINES FOR I/O
\r
14696 BADCHN: PUSH TP,$TATOM
\r
14697 PUSH TP,EQUOTE BAD-CHANNEL
\r
14700 WRONGD: PUSH TP,$TATOM
\r
14701 PUSH TP,EQUOTE WRONG-DIRECTION-CHANNEL
\r
14704 CHNCLS: PUSH TP,$TATOM
\r
14705 PUSH TP,EQUOTE CHANNEL-CLOSED
\r
14708 BAD6: PUSH TP,$TATOM
\r
14709 PUSH TP,EQUOTE NON-6-BIT-CHARACTER-IN-FILE-NAME
\r
14712 DISLOS: MOVE C,$TCHSTR
\r
14713 MOVE D,CHQUOTE [DISPLAY NOT AVAILABLE]
\r
14718 NOCHAN: PUSH TP,$TATOM
\r
14719 PUSH TP,EQUOTE ITS-CHANNELS-EXHAUSTED
\r
14722 MODE1: 232020,,202020
\r
14723 MODE2: 232023,,332320
\r
14734 .GLOBAL FRMUNG,PARBOT,TYPVEC,GCHACK,REHASH,IMPURI,NWORDT
\r
14735 .GLOBAL TD.LNT,TD.GET,TD.PUT
\r
14737 ; THIS IS AN INTERNAL MUDDLE SUBROUTINE TO RUN AROUND GC SPACE DOING
\r
14738 ; SOMETHING ARBITRARY TO EVERY ENTITY THEREIN
\r
14741 ; A/ INSTRUCTION TO BE EXECUTED
\r
14744 GCHACK: HRRZ E,TYPVEC+1(TVP) ; SET UP TYPE POINTER
\r
14745 HRLI E,C ; WILL HAVE TYPE CODE IN C
\r
14746 MOVE B,PARBOT ; START AT PARBOT
\r
14747 SETOM 1(TP) ; FENCE POST PDL
\r
14750 PUSHJ P,FRMUNG ; MUNG CURRENT FRAME
\r
14753 ; FIRST HACK PAIR SPACE
\r
14755 PHACK: CAML B,PARTOP ; SKIP IF MORE PAIRS
\r
14756 JRST VHACK ; DONE, NOW HACK VECTORS
\r
14757 GETYP C,(B) ; TYPE OF CURRENT PAIR
\r
14758 MOVE D,1(B) ; AND ITS DATUM
\r
14759 XCT A ; APPLY INS
\r
14763 ; NOW DO THE SAME THING TO VECTOR SPACE
\r
14765 VHACK: MOVE B,VECTOP ; START AT TOP, MOVE DOWN
\r
14766 SUBI B,1 ; POINT TO TOPMOST VECTOR
\r
14767 VHACK2: CAMG B,VECBOT ; SKIP IF MORE TO DO
\r
14768 JRST REHASQ ; SEE IF MUST REHASH
\r
14770 HLRE D,-1(B) ; GET TYPE FROM D.W.
\r
14771 HLRZ C,(B) ; AND TOTAL LENGTH
\r
14772 SUBI B,(C)-1 ; POINT TO START OF VECTOR
\r
14774 SUBI C,2 ; CHECK WINNAGE
\r
14775 JUMPL C,BADV ; FATAL LOSSAGE
\r
14776 PUSH P,C ; SAVE COUNT
\r
14777 JUMPE C,VHACK1 ; EMPTY VECTOR, FINISHED
\r
14779 ; DECIDE BASED ON TYPE WHETHER GENERAL,UNIFORM OR SPECIAL
\r
14781 JUMPGE D,UHACK ; UNIFORM
\r
14782 TRNE D,377777 ; SKIP IF GENERAL
\r
14783 JRST SHACK ; SPECIAL
\r
14785 ; FALL THROUGH TO GENERAL
\r
14787 GHACK1: GETYP C,(B) ; LOOK A T 1ST ELEMENT
\r
14789 CAIN C,TENTRY ; FRAME ON STACK
\r
14792 CAIN C,TBIND ; BINDING BLOCK
\r
14794 CAIN C,TGATOM ; ATOM WITH GDECL?
\r
14796 MOVE D,1(B) ; GET DATUM
\r
14798 ADDI B,2 ; NEXT ELEMENT
\r
14800 SOSLE (P) ; COUNT ELEMENTS
\r
14801 SKIPGE (B) ; OR FENCE POST HIT
\r
14805 ; HERE TO GO OVER UVECTORS
\r
14807 UHACK: CAMN A,[PUSHJ P,SBSTIS]
\r
14808 JRST VHACK1 ; IF THIS SUBSTITUTE, DONT DO UVEC
\r
14809 MOVEI C,(D) ; COPY UNIFORM TYPE
\r
14810 SUBI B,1 ; BACK OFF
\r
14812 UHACK1: MOVE D,1(B) ; DATUM
\r
14814 SOSLE (P) ; COUNT DOEN
\r
14818 ; HERE TO HACK VARIOUS FLAVORS OF SPECIAL GOODIES
\r
14820 SHACK: ANDI D,377777 ; KILL EXTRA CRUFT
\r
14823 CAIE D,STPSTK ; STACK OR
\r
14824 CAIN D,SPVP ; PROCESS
\r
14825 JRST GHACK1 ; TREAT LIKE GENERAL
\r
14826 CAIN D,SASOC ; ASSOCATION
\r
14828 CAIG D,NUMSAT ; TEMPLATE MAYBE?
\r
14829 JRST BADV ; NO CHANCE
\r
14830 ADDI C,(B) ; POINT TO DOPE WORDS
\r
14833 ADD D,TD.LNT+1(TVP)
\r
14834 JUMPGE D,BADV ; JUMP IF INVALID TEMPLATE HACKER
\r
14836 CAMN A,[PUSHJ P,SBSTIS]
\r
14839 TD.UPD: PUSH P,A ; INS TO EXECUTE
\r
14841 HLRZ E,B ; POSSIBLE BASIC LENGTH
\r
14844 MOVEI B,(B) ; ISOLATE LENGTH
\r
14845 PUSH P,C ; SAVE POINTER TO OBJECT
\r
14847 PUSH P,[0] ; HOME FOR VALUES
\r
14848 PUSH P,[0] ; SLOT FOR TEMP
\r
14850 SUB D,TD.LNT+1(TVP)
\r
14851 PUSH P,D ; SAVE FOR FINDING OTHER TABLES
\r
14852 JUMPE E,TD.UP2 ; NO REPEATING SEQ
\r
14853 ADD D,TD.GET+1(TVP) ; COMP LNTH OF REPEATING SEQ
\r
14854 HLRE D,(D) ; D ==> - LNTH OF TEMPLATE
\r
14855 ADDI D,(E) ; D ==> -LENGTH OF REP SEQ
\r
14857 HRLM D,-5(P) ; SAVE IT AND BASIC
\r
14859 TD.UP2: SKIPG D,-1(P) ; ANY LEFT?
\r
14862 MOVE E,TD.GET+1(TVP)
\r
14864 MOVE E,(E) ; POINTER TO VECTOR IN E
\r
14865 MOVEM D,-6(P) ; SAVE ELMENT #
\r
14866 SKIPN B,-5(P) ; SKIP IF "RESTS" EXIST
\r
14869 MOVEI 0,(B) ; BASIC LNT TO 0
\r
14870 SUBI 0,(D) ; SEE IF PAST BASIC
\r
14871 JUMPGE 0,.-3 ; JUMP IF O.K.
\r
14872 MOVSS B ; REP LNT TO RH, BASIC TO LH
\r
14873 IDIVI 0,(B) ; A==> -WHICH REPEATER
\r
14875 ADD A,-5(P) ; PLUS BASIC
\r
14876 ADDI A,1 ; AND FUDGE
\r
14877 MOVEM A,-6(P) ; SAVE FOR PUTTER
\r
14878 ADDI E,-1(A) ; POINT
\r
14881 TD.UP3: ADDI E,(D) ; POINT TO SLOT
\r
14882 XCT (E) ; GET THIS ELEMENT INTO A AND B
\r
14883 MOVEM A,-3(P) ; SAVE TYPE FOR LATER PUT
\r
14885 GETYP C,A ; TYPE TO C
\r
14886 MOVE D,B ; DATUME
\r
14887 MOVEI B,-3(P) ; POINTER TO HOME
\r
14888 MOVE A,-7(P) ; GET INS
\r
14889 XCT A ; AND DO IT
\r
14890 MOVE C,-4(P) ; GET POINTER FOR UPDATE OF ELEMENT
\r
14891 MOVE E,TD.PUT+1(TVP)
\r
14892 SOS D,-1(P) ; RESTORE COUNT
\r
14894 MOVE E,(E) ; POINTER TO VECTOR IN E
\r
14895 MOVE B,-6(P) ; SAVED OFFSET
\r
14896 ADDI E,(B)-1 ; POINT TO SLOT
\r
14897 MOVE A,-3(P) ; RESTORE TYPE WORD
\r
14899 XCT (E) ; SMASH IT BACK
\r
14900 FATAL TEMPLATE LOSSAGE
\r
14904 TD.UP1: MOVE A,-7(P) ; RESTORE INS
\r
14906 MOVSI D,400000 ; RESTORE MARK/UNMARK BIT
\r
14909 ; FATAL LOSSAGE ARRIVES HERE
\r
14911 BADV: FATAL GC SPACE IN A BAD STATE
\r
14913 ; HERE TO HACK SPECIAL CRUFT IN GENERAL VECTORS (STACKS)
\r
14915 EHACK: MOVSI D,-FRAMLN ; SET UP AOBJN PNTR
\r
14917 EHACK1: HRRZ C,ETB(D) ; GET 1ST TYPE
\r
14918 PUSH P,D ; SAVE AOBJN
\r
14919 MOVE D,1(B) ; GET ITEM
\r
14920 CAME A,[PUSHJ P,SBSTIS] ; DONT IF SUBSTITUTE DIFFERENT
\r
14921 XCT A ; USER GOODIE
\r
14922 POP P,D ; RESTORE AOBJN
\r
14923 ADDI B,1 ; MOVE ON
\r
14924 SOSLE (P) ; ALSO COUNT IN TOTAL VECTOR
\r
14926 AOJA B,GHACK1 ; AND GO ON
\r
14928 ; TABLE OF ENTRY BLOCK TYPES
\r
14938 ; HERE TO GROVEL OVER BINDING BLOCKS
\r
14940 BHACK: MOVEI C,TATOM ; ALSO TREEAT AS ATOM
\r
14942 CAME A,[PUSHJ P,SBSTIS] ; DONT IF SUBSTITUTE DIFFERENT
\r
14944 PUSHJ P,NXTGDY ; NEXT GOODIE
\r
14945 PUSHJ P,NXTGDY ; AND NEXT
\r
14946 MOVEI C,TSP ; TYPE THE BACK LOCATIVE
\r
14947 PUSHJ P,NXTGD1 ; AND NEXT
\r
14949 HLRZ D,-2(B) ; DECL POINTER
\r
14950 MOVEI B,0 ; MAKE SURE NO CLOBBER
\r
14952 XCT A ; DO THE THING BEING DONE
\r
14954 HRLM D,-2(B) ; FIX UP IN CASE CHANGED
\r
14957 ; HERE TO HACK ATOMS WITH GDECLS
\r
14959 GDHACK: CAMN A,[PUSHJ P,SBSTIS]
\r
14962 MOVEI C,TATOM ; TREAT LIKE ATOM
\r
14965 HRRZ D,(B) ; GET DECL
\r
14967 CAIN D,-1 ; WATCH OUT FOR MAINFEST
\r
14969 PUSH P,B ; SAVE POINTER
\r
14974 HRRM D,(B) ; RESET
\r
14977 ; HERE TO HACK ATOMS
\r
14979 ATHACK: ADDI B,1 ; POINT PRIOR TO OBL SLOT
\r
14980 MOVEI C,TOBLS ; GET TYPE
\r
14981 MOVE D,1(B) ; AND DATUM
\r
14982 CAME A,[PUSHJ P,SBSTIS] ; DONT IF SUBSTITUTE DIFFERENT
\r
14986 ; HERE TO HACK ASSOCIATION BLOCKS
\r
14988 ASHACK: MOVEI D,3 ; COUNT GOODIES TO MARK
\r
14993 PUSH P,D ; SAVE POINTER
\r
14995 POP P,D ; GET OLD BACK
\r
14996 CAME D,1(B) ; CHANGED?
\r
14997 TLO E,400000 ; SET NON-VIRGIN FLAG
\r
14999 PUSHJ P,BMP ; TO NEXT
\r
15002 ; HERE TO GOT TO NEXT VECTOR
\r
15004 VHACK1: MOVE B,-1(P) ; GET POINTER
\r
15005 SUB P,[2,,2] ; FLUSH CRUFT
\r
15006 SOJA B,VHACK2 ; FIXUP POINTER AND GO ON
\r
15008 ; ROUTINE TO GET A GOODIE
\r
15010 NXTGDY: GETYP C,(B)
\r
15011 NXTGD1: MOVE D,1(B)
\r
15012 XCT A ; DO IT TO IT
\r
15018 BMP1: SUB P,[1,,1]
\r
15021 REHASQ: JUMPL E,REHASH ; HASH TABLE RAPED, FIX IT
\r
15025 MFUNCTION SUBSTI,SUBR,[SUBSTITUTE]
\r
15027 ;THIS FUNCTION CODED BY NDR IS AN INCREDIBLE WAY TO
\r
15028 ;KILL YOURSELF, EVEN IF YOU THINK YOU REALLY KNOW WHAT
\r
15030 ;IT DOES A MINI-GC CHANGING EACH REFERENCE OF THE
\r
15031 ;SECOND ITEM TO A REFERENCE OF THE FIRST ITEM, HA HA HA.
\r
15032 ;BOTH ITEMS MUST BE OF THE SAME TYPE OR
\r
15033 ;IF NOT, NEITHER CAN BE A TYPE REQUIRING TWO WORDS
\r
15034 ; OF STORAGE, AND SUBSTITUTION CANT BE DONE IN
\r
15035 ; UVECTORS WHEN THEY ARE DIFFERENT, AS WELL AS IN
\r
15036 ; A FEW OTHER YUCKY PLACES.
\r
15037 ;RETURNS ITEM TWO--THE ONLY WAY TO GET YOUR HANDS BACK ON IT
\r
15042 SBSTI1: GETYP A,2(AB)
\r
15045 MOVE B,3(AB) ; IMPURIFY HASH BUCKET MAYBE?
\r
15048 SBSTI2: GETYP A,2(AB) ; GET TYPE OF SECOND ARG
\r
15050 PUSHJ P,NWORDT ; AND STORAGE ALLOCATION
\r
15052 GETYP A,(AB) ; GET TYPE OF FIRST ARG
\r
15055 CAMN B,D ; IF TYPES SAME, DONT CHECK FOR ALLOCATION
\r
15059 JRST SBSTIL ; LOOSE, NOT BOTH ONE WORD GOODIES
\r
15061 SBSTI3: MOVEI C,0
\r
15062 CAIN D,0 ; IF GOODIE IS OF TYPE ZERO
\r
15063 MOVEI C,1 ; USE TYPE 1 TO KEEP INFO FROM CLOBBERAGE
\r
15066 PUSH TP,E ; 1=DEFERRED TYPE ITEM, 0=ELSE
\r
15068 PUSH TP,D ; TYPE OF GOODIE
\r
15072 AOS (TP) ; 1=TYPE LIST, 0=ELSE
\r
15074 PUSH TP,2(AB) ; TYPE-WORD
\r
15076 PUSH TP,3(AB) ; VALUE-WORD
\r
15078 PUSH TP,1(AB) ; TYPE-VALUE OF THINGS TO CHANGE INTO
\r
15079 MOVE A,[PUSHJ P,SBSTIR]
\r
15080 CAME B,D ; IF NOT SAME TYPE, USE DIFF MUNGER
\r
15081 MOVE A,[PUSHJ P,SBSTIS]
\r
15082 PUSHJ P,GCHACK ; DO-IT
\r
15085 JRST FINIS ; GIVE THE LOOSER A HANDLE ON HIS GOODIE
\r
15087 SBSTIR: CAME D,-2(TP)
\r
15088 JRST LSUB ; THIS IS IT
\r
15090 JRST LSUB ; IF ITEM CANT BE SAME CHECK FOR LISTAGE
\r
15091 JUMPE B,LSUB+1 ; WE GOT HOLD OF A FUNNY GOODIE, JUST IGNORE IT
\r
15093 MOVEM 0,1(B) ; SMASH IT
\r
15094 MOVE 0,-1(TP) ; GET TYPE WORD
\r
15095 SKIPE -12(TP) ; IF THIS IS A DEFFERABLE ITEM THEN WE MUST
\r
15096 MOVEM 0,(B) ; ALSO SMASH THE TYPE WORD SLOT
\r
15098 LSUB: SKIPN -6(TP) ; IF WE ARE LOOKING FOR LISTS, LOOK ON
\r
15099 POPJ P, ; ELSE THATS ALL
\r
15101 CAMGE B,PARBOT ; IS IT IN LIST SPACE?
\r
15102 POPJ P, ; WELL NO LIST SMASHING THIS TIME
\r
15103 HRRZ 0,(B) ; GET ITS LIST POINTER
\r
15105 POPJ P, ; THIS ONE DIDNT MATCH
\r
15106 MOVE 0,(TP) ; GET THE NEW REST OF THE LIST
\r
15107 HRRM 0,(B) ; AND SMASH INTO THE REST OF THE LIST
\r
15110 SBSTIS: CAMN D,-2(TP)
\r
15113 SKIPN B ; SEE IF THIS IS A FUNNY GOODIE WE NO TOUCHIE
\r
15116 MOVEM 0,1(B) ; KLOBBER VALUE CELL
\r
15118 HLLM 0,(B) ; KLOBBER TYPE CELL, WHICH WE KNOW IS THERE
\r
15121 SBSTIL: PUSH TP,$TATOM ; LOSSAGE ON DIFFERENT TYPES, ONE DOUBLE WORD
\r
15122 PUSH TP,EQUOTE CANT-SUBSTITUTE-WITH-STRING-OR-TUPLE-AND-OTHER
\r
15127 \fTITLE INITIALIZATION FOR MUDDLE
\r
15131 LAST==1 ;POSSIBLE CHECKS DONE LATER
\r
15139 SEVEC==104000,,204
\r
15144 OBSIZE==151. ;DEFAULT OBLIST SIZE
\r
15146 .LIFG <TVBASE+TVLNT-TVLOC>
\r
15151 .GLOBAL SETUP,TPBAS,GCPDL,GCPVP,PVBASE,PVLNT,PARNEW,AAGC,ICR,SWAP,OBLNT,MSGTYP
\r
15152 .GLOBAL ICLOS,OCLOS,GLOBASE,GLOBSP,PARBOT,PARTOP,CODTOP,START,BEGIN,VECBOT,VECTOP,TPBASE
\r
15153 .GLOBAL LISTEN,ROOT,INITIAL,TBINIT,TOPLEV,INTOBL,ERROBL,MUDOBL,TTYOPE,RESFUN,QUITTER
\r
15154 .GLOBAL IOINS,BUFRIN,IOIN2,ECHO,MTYI,MTYO,MUDSTR,P.TOP,TTICHN,TTOCHN,TYPVEC
\r
15155 .GLOBAL PDLBUF,PHIBOT,%UNAM,PURVEC,STOSTR,ISTOST,TD.LNT,TD.PUT,TD.GET,CAFRE1
\r
15156 ; INIITAL AMOUNT OF AFREE SPACE
\r
15158 STOSTR: BLOCK 400 ; A RANDOM AMOUNT
\r
15162 IFN ITS, .SUSET [.RUNAM,,%UNAM] ; FOR AGC'S BENFIT
\r
15163 MOVE P,GCPDL ;GET A PUSH DOWN STACK
\r
15164 IFN ITS, .SUSET [.SMASK,,[200000]] ; ENABLE PDL OVFL
\r
15165 MOVE TVP,[-TVLNT,,TVBASE] ;GET INITIAL TRANSFER VECTOR
\r
15166 PUSHJ P,TTYOPE ;OPEN THE TTY
\r
15167 AOS A,20 ; TOP OF LOW SEGG
\r
15169 SOSN A ; IF NOTHING YET
\r
15170 IFN ITS, .SUSET [.RMEMT,,P.TOP]
\r
15172 HRRE A,P.TOP ; CHECK TOP
\r
15173 TRNE A,377777 ; SKIP IF ALL LOW SEG
\r
15174 JUMPL A,PAGLOS ; COMPLAIN
\r
15175 MOVE A,HITOP ; FIND HI SEG TOP
\r
15178 MOVEM A,RHITOP ; SAVE IT
\r
15188 HIBOK: MOVEI B,[ASCIZ /MUDDLE INITIALIZATION.
\r
15190 PUSHJ P,MSGTYP ;PRINT IT
\r
15191 MOVE A,CODTOP ;CHECK FOR A WINNING LOAD
\r
15192 CAML A,VECBOT ;IT BETTER BE LESS
\r
15193 JRST DEATH1 ;LOSE COMPLETELY
\r
15194 MOVE B,PARBOT ;CHECK FOR ANY PAIRS
\r
15195 CAME B,PARTOP ;ANY LOAD/ASSEMBLE TIME PAIRS?
\r
15196 JRST PAIRCH ;YES CHECK THEM
\r
15197 ADDI A,2000 ;BUMP UP
\r
15199 MOVEM A,PARBOT ;UPDATE PARBOT AND TOP
\r
15201 SETTV: MOVE PVP,[-PVLNT*2,,GCPVP] ;AND A PROCESS VECTOR
\r
15202 MOVEI A,(PVP) ;SET UP A BLT
\r
15203 HRLI A,PVBASE ;FROM PROTOTYPE
\r
15204 BLT A,PVLNT*2-1(PVP) ;INITIALIZE
\r
15205 MOVE TP,[-ITPLNT,,TPBAS] ;GET A STACK FOR THIS PROCCESS
\r
15206 MOVEI TB,(TP) ;AND A BASE
\r
15208 SUB TP,[1,,1] ;POP ONCE
\r
15210 ; ALLOCATE SOME OBLISTS FOR INITIAL ATOMS
\r
15212 PUSH P,[5] ;COUNT INITIAL OBLISTS
\r
15214 PUSH P,OBLNT ;SAVE CURRENT OBLIST DEFAULT SIZE
\r
15216 MAKEOB: SOS A,-1(P)
\r
15219 MCALL 0,MOBLIST ;GOBBLE AN OBLIST
\r
15220 PUSH TP,$TOBLS ;AND SAVE THEM
\r
15222 MOVE A,(P)-1 ;COUNT DOWN
\r
15223 MOVEM B,@OBTBL(A) ;STORE
\r
15226 POP P,OBLNT ;RESTORE DEFAULT OBLIST SIZE
\r
15228 MOVE C,TVP ;MAKE 2 COPIES OF XFER VECTOR POINTER
\r
15231 ;MAIN INITIALIZE LOOP - SCAN XFER VECTOR FOR ATOMS, UPDATE
\r
15232 ;OFFSETS IN CODE, UNIQUIFY ATOMS AND COMPACT XFER VECTOR
\r
15234 ILOOP: HLRZ A,(C) ;FIRST TYPE
\r
15235 JUMPE A,TVEXAU ;USEFUL STUFF EXHAUSTED
\r
15236 CAIN A,TCHSTR ;CHARACTER STRING?
\r
15237 JRST CHACK ;YES, GO HACK IT
\r
15238 CAIN A,TATOM ;ATOM?
\r
15239 JRST ATOMHK ;YES, CHECK IT OUT
\r
15240 MOVE A,(C) ;MOVE TO NEW HOME (MAY BE SAME)
\r
15244 SETLP: AOS (P) ;COUNT NUMBER OF PAIRS IN XFER VECTOR
\r
15245 ADD D,[2,,2] ;OUT COUNTER
\r
15246 SETLP1: ADD C,[2,,2] ;AND IN COUNTER
\r
15247 JUMPL C,ILOOP ;JUMP IF MORE TO DO
\r
15248 \f;NEW XFER VECTOR FINISHED, NOW GIVE AWAY THE REST
\r
15250 TVEXAU: HLRE B,C ;GET -LENGTH
\r
15251 SUBI C,(B) ;POIT TO DOPE WORD
\r
15253 HLRZ A,1(C) ;INTIAL LENGTH TO A
\r
15254 MOVEI E,(C) ;COPY OF POINTER TO DOPW WD
\r
15255 SUBI E,(D) ;AMOUNT LEFT OVER TO E
\r
15256 HRLZM E,1(C) ;CLOBBER INTO DOPE WORD FOR GARBAGE
\r
15257 MOVSI E,(E) ;PREPARE TO UPDATE TVP
\r
15258 ADD TVP,E ;NOW POINTS TO THE RIGHT AMOUNT
\r
15259 HLRE B,D ;-AMOUNT LEFT TO B
\r
15260 ADD B,A ;AMOUNT OF GOOD STUFF
\r
15261 HRLZM B,1(D) ;STORE IT IN GODD DOPE WORD
\r
15262 MOVSI E,400000 ;CLOBBER TO GENERAL IN BOTH CASES
\r
15267 ; FIX UP TYPE VECTOR
\r
15269 MOVE A,TYPVEC+1(TVP) ;GET POINTER
\r
15270 MOVEI 0,0 ;FOR POSSIBLE NULL SLOTS
\r
15271 MOVSI B,TATOM ;SET TYPE TO ATOM
\r
15273 TYPLP: HLLM B,(A) ;CHANGE TYPE TO ATOM
\r
15274 MOVE C,@1(A) ;GET ATOM
\r
15276 ADD A,[2,,2] ;BUMP
\r
15278 \f; CLOSE TTY CHANNELS
\r
15285 ;GENERAT THE LOGICAL TTY IN AND OUT CHANNELS
\r
15287 ;SETUP CALL TO OPEN OUTPUT TTY CHANNNEL
\r
15289 IRP A,,[[PRINT,TCHSTR],[TTY:,TCHSTR]]
\r
15292 PUSH TP,CHQUOTE B
\r
15297 MCALL 2,FOPEN ;OPEN THE OUT PUT CHANNEL
\r
15298 MOVEM B,TTOCHN+1(TVP) ;SAVE IT
\r
15300 ;ASSIGN AS GLOBAL VALUE
\r
15303 PUSH TP,IMQUOTE OUTCHAN
\r
15306 MOVE A,[PUSHJ P,MTYO] ;MORE WINNING INS
\r
15307 MOVEM A,IOINS(B) ;CLOBBER
\r
15310 ;SETUP A CALL TO OPEN THE TTY CHANNEL
\r
15312 IRP A,,[[READ,TCHSTR],[TTY:,TCHSTR]]
\r
15315 PUSH TP,CHQUOTE B
\r
15320 MCALL 2,FOPEN ;OPEN INPUTCHANNEL
\r
15321 MOVEM B,TTICHN+1(TVP) ;SAVE IT
\r
15322 PUSH TP,$TATOM ;ASSIGN AS A GLOBAL VALUE
\r
15323 PUSH TP,IMQUOTE INCHAN
\r
15326 MOVE C,BUFRIN(B) ;GET AUX BUFFER PTR
\r
15327 MOVE A,[PUSHJ P,MTYI]
\r
15328 MOVEM A,IOIN2(C) ;MORE OF A WINNER
\r
15329 MOVE A,[PUSHJ P,MTYO]
\r
15330 MOVEM A,ECHO(C) ;ECHO INS
\r
15333 ;GENERATE AN INITIAL PROCESS AND SWAP IT IN
\r
15335 PUSHJ P,ICR ;CREATE IT
\r
15337 MOVEM 0,PSTAT"+1(B)
\r
15338 MOVE D,B ;SET UP TO CALL SWAP
\r
15339 JSP C,SWAP ;AND SWAP IN
\r
15340 MOVEM PVP,MAINPR" ;SAVE AS THE MAIN PROCESS
\r
15341 PUSH TP,[TENTRY,,TOPLEV] ;BUILD DUMMY FRAME
\r
15347 MOVE C,TP ;COPY TP
\r
15348 ADD C,[3,,3] ;FUDGE
\r
15349 PUSH TP,C ;TPSAV PUSHED
\r
15351 HRRI TB,(TP) ;SETUP TB
\r
15354 MOVEM TB,TBINIT+1(PVP)
\r
15356 MOVEM A,RESFUN(PVP)
\r
15358 MOVEM A,RESFUN+1(PVP)
\r
15360 PUSH TP,IMQUOTE THIS-PROCESS
\r
15365 ; FIND TVP OFFSET FOR THE ATOM 'T' FOR TEMPLATE
\r
15375 PUSH TP,IMQUOTE TVTOFF,,MUDDLE
\r
15380 ; HERE TO SETUP SQUOZE TABLE IN PURE CORE
\r
15382 PUSHJ P,SQSETU ; GO TO ROUTINE
\r
15384 MOVEI A,400000 ; FENCE POST PURE SR VECTOR
\r
15385 HRRM A,PURVEC(TVP)
\r
15388 SUBI A,-PDLBUF(B) ;POINT TO DOPE WORDS
\r
15389 MOVEI B,12 ;GROWTH SPEC
\r
15393 PUSHJ P,AAGC ;DO IT
\r
15395 MOVE A,TPBASE+1(PVP)
\r
15396 SUB A,[640.,,640.]
\r
15397 MOVEM A,TPBASE+1(PVP)
\r
15399 ; CREATE LIST OF ROOT AND NEW OBLIST
\r
15404 NAMOBL: PUSH TP,$TATOM
\r
15405 PUSH TP,@OBNAM-1(A) ; NAME
\r
15407 PUSH TP,IMQUOTE OBLIST
\r
15409 PUSH TP,@OBTBL-1(A)
\r
15410 MCALL 3,PUT ; NAME IT
\r
15413 PUSH TP,@OBTBL(A)
\r
15415 PUSH TP,IMQUOTE OBLIST
\r
15417 PUSH TP,@OBNAM(A)
\r
15423 ;Define MUDDLE version number
\r
15425 MOVEI B,0 ;Initialize result
\r
15426 MOVE C,[440700,,MUDSTR+2]
\r
15427 VERLP: ILDB D,C ;Get next charcter digit
\r
15428 CAIG D,"9 ;Non-digit ?
\r
15431 SUBI D,"0 ;Convert to number
\r
15433 ADD B,D ;Include number into result
\r
15434 SOJG A,VERLP ;Finished ?
\r
15437 PUSH TP,MQUOTE MUDDLE
\r
15440 MCALL 2,SETG ;Make definition
\r
15444 PUSH TP,CHQUOTE IPC
\r
15446 PUSH TP,MQUOTE IPC-HANDLER
\r
15456 ; Allocate inital template tables
\r
15460 ADD B,[10,,10] ; REST IT OFF
\r
15461 MOVEM B,TD.LNT+1(TVP)
\r
15464 MOVEI 0,TUVEC ; SETUP UTYPE
\r
15466 MOVEM B,TD.GET+1(TVP)
\r
15469 MOVEI 0,TUVEC ; SETUP UTYPE
\r
15471 MOVEM B,TD.PUT+1(TVP)
\r
15473 PTSTRT: MOVEI A,SETUP
\r
15475 SUB A,PARBOT ;FIND WHERE PAIRS SHOULD GO
\r
15479 MOVE B,[1,,START]
\r
15482 PUSH P,[14.,,14.] ;PUSH A SMALL PRGRM ONTO P
\r
15483 MOVEI A,1(P) ;POINT TO ITS START
\r
15484 PUSH P,[JRST AAGC] ;GO TO AGC
\r
15485 PUSH P,[MOVE B,PSTO+1(PVP)] ;GET SAVED P
\r
15486 PUSH P,[SUB B,-13.(P)] ;FUDGE TO POP OFF PROGRAM
\r
15487 PUSH P,[MOVEM B,PSAV(TB)] ;INTO FRAME
\r
15488 PUSH P,[MOVE B,TPSTO+1(PVP)] ;GET TP
\r
15489 PUSH P,[MOVEM B,TPSAV(TB)] ;STORE IT
\r
15490 PUSH P,[MOVE B,SPSTO+1(PVP)] ;SP
\r
15491 PUSH P,[MOVEM B,SPSAV(TB)]
\r
15492 PUSH P,[MOVEI B,TOPLEV] ;WHERE TO GO
\r
15493 PUSH P,[MOVEM B,PCSAV(TB)]
\r
15494 IFN ITS, PUSH P,[MOVSI B,(.VALUE )]
\r
15495 IFE ITS, PUSH P,[MOVSI B,(JRST 4,)]
\r
15496 PUSH P,[HRRI B,C]
\r
15497 PUSH P,[JRST B] ;GO DO VALRET
\r
15499 PUSH P,A ; PUSH START ADDR
\r
15500 MOVE B,[JRST -11.(P)]
\r
15501 MOVE 0,[JUMPA START]
\r
15502 MOVE C,[ASCII \
\170/
\e9\]
\r
15503 MOVE D,[ASCII \B/
\e1Q\]
\r
15509 ; CHECK PAIR SPACE
\r
15514 DEATH1: MOVEI B,[ASCIZ /LOSSAGE--CODE AND DATA OVERLAP
\r
15519 ;CHARACTER STRING HACKER
\r
15521 CHACK: MOVE A,(C) ;GET TYPE
\r
15522 HLLZM A,(D) ;STORE IN NEW HOME
\r
15523 MOVE B,1(C) ;GET POINTER
\r
15524 HLRZ E,B ;-LENGHT
\r
15526 PUSH P,E+1 ; IDIVI WILL CLOBBER
\r
15527 ADDI E,4+5*2 ; ROUND AND ACCOUNT FOR DOPE WORDS
\r
15528 IDIVI E,5 ; E/ WORDS LONG
\r
15529 PUSHJ P,EBPUR ; MAKE A PURIFIED COPY
\r
15531 HRLI B,440700 ;MAKE POINT BYTER
\r
15532 MOVEM B,1(D) ;AND STORE IT
\r
15533 ANDI A,-1 ;CLEAR LH OF A
\r
15534 JUMPE A,SETLP ;JUMP IF NO REF
\r
15535 MOVE E,(P) ;GET OFFSET
\r
15537 HRRZ B,-1(A) ;SEE IF PREVIOUS INSTRUCTION REFERS TO $TCHSTR
\r
15538 CAIE B,$TCHSTR ;SKIP IF IT DOES
\r
15539 JRST CHACK1 ;NO, JUST DO CHQUOTE PART
\r
15540 HRRM E,-1(A) ;CLOBBER
\r
15542 DPB B,[220400,,-1(A)] ;CLOBBER INDEX FIELD
\r
15544 HRRM E,(A) ;STORE INTO REFERENCE
\r
15547 ; SUBROUTINE TO COPY A HUNK OF STRUCTURE TO THE HIGH SEGMENT
\r
15551 ADD E,HITOP ; GET NEW TOP
\r
15552 CAMG E,RHITOP ; SKIP IF TOO BIG
\r
15555 ; CODE TO GROW HI SEG
\r
15558 ADDB A,RHITOP ; NEW TOP
\r
15560 ASH A,-10. ; NUM OF BLOCKS
\r
15561 SUBI A,1 ; BLOCK TO GET
\r
15566 EBPUR1: MOVEI A,-1(E) ; NEEDED TO TERMINATE BLT
\r
15589 ; PROCESS AN ATOM AND ADD IT TO AN APPROPRIATE OBLIST IF IT ISN'T
\r
15592 ATOMHK: PUSH TP,$TOBLS ; SAVE OBLIST
\r
15593 PUSH TP,[0] ; FILLED IN LATER
\r
15594 PUSH TP,$TVEC ;SAVE TV POINTERS
\r
15598 MOVE B,1(C) ;GET THE ATOM
\r
15599 PUSH TP,$TATOM ;AND SAVE
\r
15601 HRRZ A,(B) ;GET OBLIST SPEC FROM ATOM
\r
15603 ADDI A,1(TB) ;POINT TO ITS HOME
\r
15605 PUSH TP,(A) ;AND SAV IT
\r
15607 MOVEM A,-10(TP) ; CLOBBER
\r
15611 ADD B,[3,,3] ;POINT TO ATOM'S PNAME
\r
15612 MOVEI A,0 ;FOR HASHING
\r
15615 TLZ A,400000 ;FORCE POSITIVE RESULT
\r
15617 HRLS B ;REMAINDER IN B IS BUCKET
\r
15618 ADDB B,(TP) ;UPDATE POINTER
\r
15620 SKIPN C,(B) ;GOBBLE BUCKET CONTENTS
\r
15621 JRST USEATM ;NONE, LEAVE AND USE THIS ATOM
\r
15622 OBLOO3: MOVE E,-2(TP) ;RE-GOBBLE ATOM
\r
15623 ADD E,[3,,3] ;POINT TO PNAME
\r
15624 SKIPN D,1(C) ;CHECK LIST ELEMNT
\r
15625 JRST NXTBCK ;0, CHECK NEXT IN THIS BUCKET
\r
15626 ADD D,[3,,3] ;POINT TO PNAME
\r
15627 OBLOO2: MOVE A,(D) ;GET A WORD
\r
15628 CAME A,(E) ;COMPARE
\r
15629 JRST NXTBCK ;THEY DIFFER, TRY NEX
\r
15630 OBLOOP: AOBJP E,CHCKD ;COULD BE A MATCH, GO CHECK
\r
15631 AOBJN D,OBLOO2 ;HAVEN'T LOST YET
\r
15633 NXTBCK: HRRZ C,(C) ;CDR THE LIST
\r
15634 JUMPN C,OBLOO3 ;IF NOT NIL, KEEP TRYING
\r
15636 ;HERE IF THIS ATOM MUST BE PUT ON OBLIST
\r
15638 USEATM: MOVE B,-2(TP) ; GET ATOM
\r
15639 HLRZ 0,(B) ; SEE IF PURE OR NOT
\r
15640 TRNN 0,400000 ; SKIP IF IMPURE
\r
15642 MOVE B,(TP) ;POINTER TO BUCKET
\r
15643 HRRZ C,(B) ;POINTER TO LIST IN THIS BUCKET
\r
15644 PUSH TP,$TATOM ;GENERATE CALL TO CONS
\r
15648 MCALL 2,CONS ;CONS IT UP
\r
15649 MOVE C,(TP) ;REGOBBLE BUCKET POINTER
\r
15650 HRRZM B,(C) ;CLOBBER
\r
15651 MOVE B,-2(TP) ;POINT TO ATOM
\r
15652 MOVE C,-10(TP) ; GET OBLIST
\r
15653 MOVEM C,2(B) ; INTO ATOM
\r
15654 PUSHJ P,VALMAK ;MAKE A GLOBAL VALUE FOR THIS LOSER
\r
15655 PURAT2: MOVE C,-6(TP) ;RESET POINTERS
\r
15658 MOVE B,(C) ;MOVE THE ENTRY
\r
15659 HLLZM B,(D) ;DON'T WANT REF POINTER STORED
\r
15660 MOVE A,1(C) ;AND MOVE ATOM
\r
15662 MOVE A,(P) ;GET CURRENT OFFSET
\r
15665 ANDI B,-1 ;CHECK FOR REAL REF
\r
15666 JUMPE B,SETLP1 ;DON'T SAVE THIS ATOM ON TVP
\r
15667 HRRM A,(B) ;CLOBBER CODE
\r
15671 ; HERE TO MAKE A PURE ATOM
\r
15673 PURATM: HRRZ B,-2(TP) ; POINT TO IT
\r
15674 HLRE E,-2(TP) ; - LNTH
\r
15677 PUSHJ P,EBPUR ; PURE COPY
\r
15678 HRRM B,-2(TP) ; AND STORE BACK
\r
15679 HRRO B,(TP) ; GET BUCKET BACK
\r
15680 PURAT1: HRRZ C,(B) ; GET CONTENTS
\r
15681 JUMPE C,HICONS ; AT END, OK
\r
15682 CAIL C,HIBOT ; SKIP IF IMPURE
\r
15683 JRST HICONS ; CONS IT ON
\r
15687 HICONS: HRLI C,TATOM
\r
15693 PUSHJ P,EBPUR ; MAKE PURE LIST CELL
\r
15697 HRRM B,(C) ; STORE IT
\r
15698 MOVE B,1(B) ; ATOM BACK
\r
15699 MOVE C,-6(TP) ; GET TVP SLOT
\r
15700 HRRM B,1(C) ; AND STORE
\r
15701 HLRZ 0,(B) ; TYPE OF VAL
\r
15703 CAIN 0,TUNBOU ; NOT UNBOUND?
\r
15704 JRST PURAT3 ; UNBOUND, NO VAL
\r
15705 MOVEI E,2 ; COUNT AGAIN
\r
15706 PUSHJ P,EBPUR ; VALUE CELL
\r
15707 MOVE C,-2(TP) ; ATOM BACK
\r
15708 HLLZS (B) ; CLEAR LH
\r
15712 PURAT3: HRRZ A,(C) ; GET OBLIST CODE
\r
15714 MOVEM A,2(C) ; STORE OBLIST SLOT
\r
15718 ; A POSSIBLE MATCH ARRIVES HERE
\r
15720 CHCKD: AOBJN D,NXTBCK ;SIZES DIFFER, JUMP
\r
15721 MOVE D,1(C) ;THEY MATCH!, GET EXISTING ATOM
\r
15722 MOVEI A,(D) ;GET TYPE OF IT
\r
15723 MOVE B,-2(TP) ;GET NEW ATOM
\r
15725 TRZ A,377777 ; SAVE ONLY 400000 BIT
\r
15727 CAIN 0,(A) ; SKIP IF WIN
\r
15733 CAIE A,TUNBOU ;UNBOUND?
\r
15734 JRST A1VAL ;YES, CONTINUE
\r
15735 MOVE A,(B) ;MOVE VALUE
\r
15739 MOVE B,D ;EXISTING ATOM TO B
\r
15743 PUSHJ P,VALMAK ;MAKE A VALUE
\r
15747 ;NOW FIND ATOMS OCCURENCE IN XFER VECTOR
\r
15749 OFFIND: MOVE D,-4(TP) ;GET CURRENT POINTER INTO TP
\r
15750 MOVE C,TVP ;AND A COPY OF TVP
\r
15751 MOVEI A,0 ;INITIALIZE COUNTER
\r
15752 ALOOP: CAMN B,1(C) ;IS THIS IT?
\r
15754 ADD C,[2,,2] ;BUMP COUNTER
\r
15755 CAMGE C,D ;HAVE WE HIT END
\r
15756 AOJA A,ALOOP ;NO, KEEP LOOKING
\r
15758 MOVEI B,[ASCIZ /LOSSAGE--ATOM DISAPPEARED
\r
15760 TYPIT: PUSHJ P,MSGTYP
\r
15763 AFOUND: LSH A,1 ;FOUND ATOM, GET REAL OFFSET
\r
15765 MOVE C,-6(TP) ;GET TV POINTER TO NEW ATOM
\r
15766 HRRZ B,(C) ;POINT TO REFERENCE
\r
15767 SKIPE B ;ANY THERE?
\r
15768 HRRM A,(B) ;YES, CLOBBER AWAY
\r
15770 JRST SETLP1 ;AND GO ON
\r
15772 A1VAL: HLRZ C,(B) ;GET VALUE'S TYPE
\r
15773 MOVE B,D ;NOW PUT EXISTING ATOM IN B
\r
15774 CAIN C,TUNBOU ;UNBOUND?
\r
15775 JRST OFFIND ;YES, WINNER
\r
15777 MOVEI B,[ASCIZ /LOSSAGE--ATOM TRIES TO HAVE 2 VALUES
\r
15782 IM.PUR: MOVEI B,[ASCIZ /LOSSAG--ATOM TRIES TO BE BOTH PURE AND IMPURE
\r
15786 PAGLOS: MOVEI B,[ASCIZ /LOSSAGE--IMPURE CORE EXTENDS INTO HIGH SEGMENT
\r
15790 ;MAKE A VALUE IN SLOT ON GLOBAL SP
\r
15792 VALMAK: HLRZ A,(B) ;TYPE OF VALUE
\r
15793 CAIE A,400000+TUNBOU
\r
15794 CAIN A,TUNBOU ;VALUE?
\r
15795 POPJ P, ;NO, ALL DONE
\r
15796 MOVE A,GLOBSP+1(TVP) ;GET POINTER TO GLOBAL SP
\r
15797 SUB A,[4,,4] ;ALLOCATE SPACE
\r
15798 CAMG A,GLOBAS+1(TVP) ;CHECK FOR OVERFLOW
\r
15800 MOVEM A,GLOBSP+1(TVP) ;STORE IT BACK
\r
15801 MOVE C,(B) ;GET TYPE CELL
\r
15803 HLLZM C,2(A) ;INTO TYPE CELL
\r
15804 MOVE C,1(B) ;GET VALUE
\r
15805 MOVEM C,3(A) ;INTO VALUE SLOT
\r
15806 MOVSI C,TGATOM ;GET TATOM,,0
\r
15808 MOVEM B,1(A) ;AND POINTER TO ATOM
\r
15809 MOVSI C,TLOCI ;NOW CLOBBER THE ATOM
\r
15810 MOVEM C,(B) ;INTO TYPE CELL
\r
15811 ADD A,[2,,2] ;POINT TO VALUE
\r
15815 SPOVFL: MOVEI B,[ASCIZ /LOSSAGE--GLOBAL SP OVERFLOW
\r
15820 PVALM: HLRZ 0,(B)
\r
15821 CAIE 0,400000+TUNBOU
\r
15833 \f;SET UP LIST OF INTERNAL NAMES AND ADDRESS NEEDED BY COMPILER
\r
15837 IRP A,,[FINIS,SPECBIND,MESTBL,WNA,WRONGT,$TLOSE,CALER1
\r
15838 ILOC,IGLOC,IDVAL,ILVAL,IGVAL,INTFLG,LCKINT,TYPLOO,TDEFER
\r
15839 IFALSE,UNAS,UNBOU,RCALL,SEGMNT,SEGLST,NUMPRI,DISXTR,SSPEC1,COMPERR
\r
15840 MAKACT,MAKENV,BFRAME,TTP,TTB,$TTP,$TTB,MAKTUP,TPALOC,IBIND,SSPECS
\r
15841 CILVAL,CISET,CIGVAL,CSETG,IBLOK1,IBLOCK,CLLOC,CGLOC,CASSQ,CGASSQ
\r
15842 CILNT,CILNQ,CILEGQ,CEMPTY,CIEQUA,CIREST,CINTH,CIAT,CSETLO,CIN
\r
15843 CIPUT,CIGET,CIGETL,CIMON,CISTRU,CIMEMQ,CIMEMB,CITOP,CIBACK,TYPSEG
\r
15844 CICONS,CIUVEC,CIVEC,IIFORM,IILIST,CISTNG,HITOP,INCR1,TYPG,VALG,TESTR
\r
15845 OTBSAV,CITYPE,CFRAME,CARGS,CFUNCT,CUTYPE,CPTYPE,CTYPEP,CTYPEQ,CCHUTY
\r
15846 CIREMA,RTFALS,CIGETP,CIGTPR,MPOPJ,TAB,$TAB,ICONS,CSTO,DSTO,NTPALO
\r
15847 CPLUS,CTIMES,CTIME,CDIVID,CMINUS,CLQ,CLEQ,CGQ,CGEQ,CLOG,CSIN,CCOS,CATAN,CSQRT
\r
15848 CFIX,CFLOAT,CEXP,CRAND,CINEQU,SPECBND,PGGIVE,PGFIND,MTYO,CMIN,CMAX,RCL,R1C,W1C
\r
15849 CALLTY,CTYPEC,CTYPEW,NOTTY,CHKAB,CTMPLT,IUNWIN,UNWIN2,NOSHUF,ROOT,ERROBL,INTOBL
\r
15850 CINSER,CIRMV,CLOOKU,CATOM,CIPNAM,ISTRCM,CITERP,CIPRIN,CIPRN1,CIPRNC
\r
15851 CPATM,CP1ATM,CPCATM,CPSTR,CP1STR,CPCSTR,CPCH,CREADC,CNXTCH,CREDC1,CNXTC1
\r
15852 CGBOUN,IIGLOC,MAKTU2,CIFLTZ,CIUPRS]
\r
15855 MAKAT [A]TFIX,A,MUDDLE,0
\r
15860 ; ROUTINE TO SORT AND PURIFY SQUOZE TABLE
\r
15862 SQSETU: MOVE A,[SQUTBL-SQULOC+2,,SQUTBL]
\r
15873 SQ1: ADD A,[2,,2]
\r
15876 MOVEI E,SQULOC-SQUTBL
\r
15878 PUSHJ P,EBPUR ; TO THE PURE WORLD
\r
15879 HRLI B,SQUTBL-SQULOC
\r
15897 OBTBL: INITIAL+1(TVP)
\r
15902 OBNAM: MQUOTE INITIAL
\r
15904 MQUOTE INTERRUPTS
\r
15912 TITLE INTERRUPT HANDLER FOR MUDDLE
\r
15916 ;C. REEVE APRIL 1971
\r
15923 IFE ITS,.INSRT MUDSYS;STENEX >
\r
15926 PDLGRO==10000 ;AMOUNT TO GROW A PDL THAT LOSES
\r
15927 NINT==72. ;MAXIMUM NUMBER OF INTERRUPTS POSSIBLE
\r
15930 ;SET UP LOCATION 42 TO POINT TO TSINT
\r
15934 ZZZ==$. ;SAVE CURRENT LOCATION
\r
15938 JSR MTSINT ;GO TO HANDLER
\r
15944 ; GLOBALS NEEDED BY INTERRUPT HANDLER
\r
15946 .GLOBAL ONINT ; FUDGE INS EXECUTED IF NON ZERO AT START OF INTERRUPT
\r
15947 .GLOBA GCFLG ;TELLS WHETHER OR NOT GARBAGE COLLECTOR IS RUNNING
\r
15948 .GLOBAL GCFLCH ; FLUSH CHARS IMMEDIATE SO GC CAN SEE THEM
\r
15949 .GLOBAL CORTOP ; TOP OF CORE
\r
15950 .GLOBA GCINT ;TELLS GARBAGE COLLECTOR TO SIMULATE AN INTERRUPT
\r
15951 .GLOBAL INTNUM,INTVEC ;TV ENTRIES CONCERNING INTERRUPTS
\r
15952 .GLOBAL AGC ;CALL THE GARBAGE COLLECTOR
\r
15953 .GLOBAL VECNEW,PARNEW,GETNUM ;GC PSEUDO ARGS
\r
15954 .GLOBAL GCPDL ;GARBAGE COLLECTORS PDL
\r
15955 .GLOBAL VECTOP,VECBOT ;DELIMIT VECTOR SPACE
\r
15957 .GLOBAL PDLBUF ;AMOUNT OF PDL GROWTH
\r
15958 .GLOBAL PGROW ;POINTS TO DOPE WORD OF NEXT PDL TO GROW
\r
15959 .GLOBAL TPGROW ;POINTS TO NEXT MUDDLE PDL TO GROW
\r
15960 .GLOBAL TOPLEV,ERROR%,N.CHNS,CHNL1
\r
15961 .GLOBAL BUFRIN,CHNL0,SYSCHR ;CHANNEL GLOBALS
\r
15962 .GLOBAL IFALSE,TPOVFL,1STEPR,INTOBL,INCHAR,CURPRI,RDEVIC,RDIREC,GFALS,STATUS
\r
15963 .GLOBAL PSTAT,NOTRES,IOIN2,INAME,INTFCN,CHNCNT,CHANNO,GIBLOK,ICONS,INCONS
\r
15964 .GLOBAL IEVECT,INSRTX,ILOOKC,IPUT,IREMAS,IGET,CSTAK,EMERGE
\r
15965 .GLOBAL MTSINT ;BEGINNING OF INTERRUPT HANDLER
\r
15966 .GLOBAL INTINT ;CALLED BY INITIALIZER TO TAKE CARE OF INT PCS
\r
15967 .GLOBAL FRMSTK,APPLY,CHUNW
\r
15968 .GLOBAL IPCGOT,DIRQ ;HANDLE BRANCHING OFF TO IPC KLUDGERY
\r
15971 .GLOBAL GCTIM,GCCAUS,GCCALL
\r
15973 ; GLOBALS FOR MONITOR ROUTINES
\r
15975 .GLOBAL MONCH,MONCH0,RMONCH,RMONC0,LOCQ,SMON,BAPT,APLQ,MAKACT,NAPT
\r
15976 .GLOBAL PURERR,BUFRIN,INSTAT
\r
15980 .GLOBAL MSGTYP,MTYI,UPLO,IFLUSH,OCLOS,ERRET,MASK1,MASK2 ;SUBROUTINES USED
\r
15981 .GLOBAL ERROR,LISTEN,ECHO,RRESET,MTYO,GCHAPN,P.CORE,P.TOP,QUEUES,NOTTY,TTYOP2,TTICHN
\r
15982 .GLOBAL INTHLD,BNDV,SPECBE
\r
15983 ;BEGINNING OF ACTUAL INTERRUPT HANDLER (MUST BE IMPURE)
\r
15986 ;***** TEMP FUDGE *******
\r
15991 ; DECLARATIONS ASSOCIATED WITH INTERRUPT HANDERS AND HEADERS
\r
15995 SPECIN: IRP A,,[CHAR,CLOCK,MPV,ILOPR,WRITE,READ,IOC,PURE,SYSDOWN,INFERIOR,RUNT,REALT
\r
15997 MQUOTE A,[A]INTRUP
\r
16001 ; TABLE OF SPECIAL FINDING ROUTINES
\r
16003 FNDTBL: IRP A,,[GETCHN,0,0,0,LOCGET,LOCGET,0,0,0,0,0,0,0]
\r
16007 ; TABLE OF SPECIAL SETUP ROUTINES
\r
16009 INTBL: IRP A,,[S.CHAR,S.CLOK,S.MPV,S.ILOP,S.WMON,S.RMON,S.IOC,S.PURE,S.DOWN,S.INF
\r
16010 S.RUNT,S.REAL,S.PAR]
\r
16017 ; EXTERNAL INTERRUPT TABLE
\r
16019 EXTINT: REPEAT NINT-36.,0
\r
16024 REPEAT NINT-62.,0
\r
16027 IRP A,,[[HCLOCK,13.],[HMPV,14.],[HILOPR,6],[HIOC,9],[HPURE,26.],[HDOWN,7],[HREAL,35.]
\r
16028 [HRUNT,34.],[HPAR,28.]]
\r
16042 ; TABLES FOR TENEX INTERRUPT SYSTEM
\r
16044 LEVTAB: P1 ; POINTS TO INT PC HOLDERS FOR LEVS 1,2 AND 3
\r
16048 CHNMSK==0 ; WILL BE MASK WORD FOR INT SET UP
\r
16050 NNETS==10. ; ALLOW 10 NETWRK INTERRUPTS
\r
16051 NETCHN==36.-NNETS
\r
16053 CHNTAB: ; LOCATION OF INT ROUTINES FOR VARIOUS "CHANNELS"
\r
16054 BLOCK 36.-NNETS ; THERE AR 36. TENEX INT CHANNELS
\r
16056 REPEAT NNETS, 1,,INTNET+3*.RPCNT
\r
16058 IRP A,,[[0,CNTLG],[1,CNTLS],[9.,TNXPDL]]
\r
16062 CHNMSK==CHNMSK+<1_<35.-B>>
\r
16068 EXTINT: BLOCK NINT-NNETS
\r
16070 REPEAT NNETS,HNET
\r
16072 IRP A,,[[HCNTLG,36.],[HCNTLS,37.]]
\r
16083 ; HANDLER/HEADER PARAMETERS
\r
16087 IHDRLN==4 ; LENGTH OF HEADER BLOCK
\r
16089 INAME==0 ; NAME OF INTERRUPT
\r
16090 ISTATE==2 ; CURRENT STATE
\r
16091 IHNDLR==4 ; POINTS TO LIST OF HANDLERS
\r
16092 INTPRI==6 ; CONTAINS PRIORITY OF INTERRUPT
\r
16094 IHANDL==4 ; LENGTH OF A HANDLER BLOCK
\r
16096 INXT==0 ; POINTS TO NEXTIN CHAIN
\r
16097 IPREV==2 ; POINTS TO PREV IN CHAIN
\r
16098 INTFCN==4 ; FUNCTION ASSOCIATED WITH THIS HANDLER
\r
16099 INTPRO==6 ; PROCESS TO RUN INT IN
\r
16105 MTSINT: 0 ;INTERRUPT BITS GET STORED HERE
\r
16106 TSINTR: 0 ;INTERRUPT PC WORD STORED HERE
\r
16107 JRST TSINTP ;GO TO PURE CODE
\r
16109 ; SOFTWARE INTERNAL INTERRUPTS JSR TO HERE
\r
16119 ; JSR HERE FOR SOFTWARE INTERNAL INTERRUPTS
\r
16129 ;THE REST OF THIS CODE IS PURE
\r
16131 TSINTP: SOSGE INTFLG ; SKIP IF ENABLED
\r
16132 SETOM INTFLG ;DONT GET LESS THAN -1
\r
16134 MOVEM A,TSAVA ;SAVE TWO ACS
\r
16136 MOVE A,TSINT ;PICK UP INT BIT PATTERN
\r
16137 JUMPL A,2NDWORD ;DONT CHECK FOR PDL OVERFLOW ETC. IF SIGN BIT ON
\r
16139 TRZE A,200000 ;IS THIS A PDL OVERFLOW?
\r
16140 JRST IPDLOV ;YES, GO HANDLE IT FIRST
\r
16143 TRNE A,20000 ;IS IT A MEMORY PROTECTION VIOLATION?
\r
16144 MOVEI B,1 ; FLAG SAME
\r
16146 TRNE A,40 ;ILLEGAL OP CODE?
\r
16147 MOVEI B,2 ; ALSO FLAG
\r
16148 TRNN A,400 ; IOC?
\r
16152 TLNE A,200 ; PURE?
\r
16154 SOJGE B,DO.NOW ; CANT WAIT AROUND
\r
16156 ;DECODE THE REST OF THE INTERRUPTS USING A TABLE
\r
16159 JUMPL A,GC2 ;2ND WORD?
\r
16160 IORM A,PIRQ ;NO, INTO WORD 1
\r
16161 JRST GCQUIT ;AND DISMISS INT
\r
16163 GC2: TLZ A,400000 ;TURN OFF SIGN BIT
\r
16165 TRNE A,177777 ;CHECK FOR CHANNELS
\r
16166 JRST CHNACT ;GO IF CHANNEL ACTIVITY
\r
16168 GCQUIT: SKIPGE INTFLG ;SKIP IF INTERRUPTS ENABLED
\r
16169 JRST INTDON ;NO, DEFER REAL HANDLING UNTIL LATER
\r
16171 MOVE A,TSINTR ;PICKUP RETURN WORD
\r
16173 TLON A,10000 ; EXEC PC?
\r
16174 SUBI A,1 ; YES FIXUP PC
\r
16176 MOVEM A,LCKINT ;STORE ELSEWHERE
\r
16177 MOVEI A,DOINTE ;CAUSE DISMISS TO HANDLER
\r
16178 HRRM A,TSINTR ;STORE IN INT RETURN
\r
16179 PUSH P,INTFLG ;SAVE INT FLAG
\r
16180 SETOM INTFLG ;AND DISABLE
\r
16183 INTDON: MOVE A,TSAVA ;RESTORE ACS
\r
16185 IFN ITS, .DISMISS TSINTR ;AND DISMISS THE INTERRUPT
\r
16189 DO.NOW: SKIPE GCFLG
\r
16190 JRST DLOSER ; HANDLE FATAL GC ERRORS
\r
16192 SKIPGE INTFLG ; IF NOT ENABLED
\r
16193 MOVEM B,INTFLG ; PRETEND IT IS
\r
16198 ; HERE FOR TENEX PDL OVER FLOW INTERRUPT
\r
16200 TNXPDL: SOSGE INTFLG
\r
16204 JRST IPDLOV ; GO TO COMMON HANDLER
\r
16206 ; HERE FOR TENEX ^G AND ^S INTERRUPTS
\r
16208 CNTLG: MOVEM A,TSAVA
\r
16212 CNTLS: MOVEM A,TSAVA
\r
16215 CNTSG: MOVEM B,TSAVB
\r
16216 IORM A,PIRQ2 ; SAY FOR MUDDLE LEVEL
\r
16223 MOVE A,[1_<.RPCNT+NETCHN>]
\r
16228 ; HERE TO PROCESS INTERRUPTS
\r
16230 DOINT: SKIPE INTHLD ; GLOBAL LOCK ON INTS
\r
16232 SETOM INTHLD ; DONT LET IT HAPPEN AGAIN
\r
16234 DOINTE: SKIPE ONINT ; ANY FUDGE?
\r
16235 XCT ONINT ; YEAH, TRY ONE
\r
16236 EXCH 0,LCKINT ; RELATIVIZE PC IF FROM RSUBR
\r
16237 PUSH P,0 ; AND SAVE
\r
16242 SUBI 0,(M) ; M IS BASE REG
\r
16243 HLL 0,(P) ; GET FLAGS
\r
16244 TLO 0,M ; INDEX IT OFF M
\r
16245 EXCH 0,(P) ; AND RESTORE TO STACK
\r
16246 DONREL: EXCH 0,LCKINT ; GET BACK SAVED 0
\r
16247 SETZM INTFLG ;DISABLE
\r
16248 AOS -1(P) ;INCR SAVED FLAG
\r
16250 ;NOW SAVE WORKING ACS
\r
16253 HLRZ A,-1(P) ; HACK FUNNYNESS FOR MPV/ILOPR
\r
16255 SETZM -1(P) ; REALLY DISABLED
\r
16257 DIRQ: MOVE A,PIRQ ;NOW SATRT PROCESSING
\r
16258 JFFO A,FIRQ ;COUNT BITS AND GO
\r
16259 MOVE A,PIRQ2 ;1ST DONE, LOOK AT 2ND
\r
16262 INTDN1: SKIPN GCHAPN ; SKIP IF MUST DO GC INT
\r
16265 PUSHJ P,INTOGC ; AND INTERRUPT
\r
16270 .SUSET [.SPICLR,,[0]] ; DISABLE INTS
\r
16274 SETZM INTHLD ; RE-ENABLE THE WORLD
\r
16277 HRRI 0,@0 ; EFFECTIVIZE THE ADDRESS
\r
16278 TLZ 0,37 ; KILL IND AND INDEX
\r
16282 IFE ITS, JRST @LCKINT
\r
16283 FIRQ: PUSHJ P,GETBIT ;SET UP THE BIT TO CLOBBER IN PIRQ
\r
16284 ANDCAM A,PIRQ ;CLOBBER IT
\r
16285 ADDI B,36. ;OFSET INTO TABLE
\r
16286 JRST XIRQ ;GO EXECUTE
\r
16288 FIRQ2: PUSHJ P,GETBIT ;PREPARE TO CLOBBER BIT
\r
16289 ANDCAM A,PIRQ2 ;CLOBBER IT
\r
16290 ADDI B,71. ;AGAIN OFFSET INTO TABLE
\r
16292 CAIE B,21 ;PDL OVERFLOW?
\r
16293 JRST FHAND ;YES, HACK APPROPRIATELY
\r
16295 PDL2: SKIPN A,PGROW
\r
16298 JRST DIRQ ; NOTHING GROWING, FALSE ALARM
\r
16299 MOVEI B,PDLGRO_-6 ;GET GROWTH SPEC
\r
16300 DPB B,[111100,,-1(A)] ;STORE GROWTH SPEC
\r
16301 REAGC: MOVE C,[10.,,1] ; INDICATOR FOR AGC
\r
16302 SKIPE PGROW ; P IS GROWING
\r
16304 SKIPE TPGROW ; TP IS GROWING
\r
16306 PUSHJ P,AGC ;COLLECT GARBAGE
\r
16309 AOJL A,REAGC ; IF NO CORE, RETRY
\r
16313 IRP A,,[0,A,B,C,D,E]
\r
16314 PUSH TP,A!STO(PVP)
\r
16315 SETZM A!STO(PVP) ;NOW ZERO TYPE
\r
16321 IRP A,,[E,D,C,B,A,0]
\r
16323 POP TP,A!STO(PVP)
\r
16327 ; HERE TO DO GC INTERRUPT AND CLOSE ANY DEAD CHANNELS
\r
16329 INTOGC: PUSH P,[N.CHNS-1]
\r
16331 ADD A,[CHNL1,,CHNL1]
\r
16335 INTGC1: MOVE A,(TP) ; GET POINTER
\r
16336 SKIPN B,1(A) ; ANY CHANNEL?
\r
16338 HRRE 0,(A) ; INDICATOR
\r
16346 INTGC2: HLLZS (A)
\r
16355 PUSH TP,CHQUOTE GC
\r
16356 PUSH TP,$TFLOAT ; PUSH ON TIME ARGUMENT
\r
16358 PUSH TP,$TFIX ; PUSH ON THE CAUSE ARGUMENT
\r
16360 PUSH TP,$TATOM ; PUSH ON THE CALL ARGUMENT
\r
16362 PUSH TP,@GCALLR(A)
\r
16375 MQUOTE PURE-PAGE-LOADER
\r
16377 MQUOTE INTERRUPT-HANDLER
\r
16380 \f; OLD "ON" SETS UP EVENT AND HANDLER
\r
16382 MFUNCTION ON,SUBR
\r
16386 HLRE 0,AB ; 0=> -2*NUM OF ARGS
\r
16387 ASH 0,-1 ; TO -NUM
\r
16390 MOVEI B,10(AB) ; LAST MUST BE CHAN OR LOC
\r
16393 JUMPG 0,TFA ; AT LEAST 3
\r
16394 MOVEI A,0 ; SET UP IN CASE NO PROC
\r
16395 AOJG 0,ONPROC ; JUMP IF NONE
\r
16396 GETYP C,6(AB) ; CHECK IT
\r
16399 MOVE A,7(AB) ; GET IT
\r
16400 ONPROC: PUSH P,A ; SAVE AS A FLAG
\r
16401 GETYP A,(AB) ; CHECK PREV EXISTANCE
\r
16407 MOVEI B,(AB) ; FIND IT
\r
16409 POP P,0 ; REST NUM OF ARGS
\r
16410 JUMPN B,ON3 ; ALREADY THERE
\r
16411 SKIPE C ; SKIP IF NOTHING TO FLUSH
\r
16413 PUSH TP,(AB) ; GET NAME
\r
16417 MOVEI A,2 ; # OF ARGS TO EVENT
\r
16418 AOJG 0,ON1 ; JUMP IF NO LAST ARG
\r
16422 ON1: ACALL A,EVENT
\r
16426 PUSH TP,2(AB) ; NOW FCN
\r
16428 MOVEI A,3 ; NUM OF ARGS
\r
16430 SOJA A,ON2 ; NO PROC
\r
16433 ON2: ACALL A,HANDLER
\r
16437 TRYFIX: SKIPN A,7(AB)
\r
16442 ; ROUTINE TO BUILD AN EVENT
\r
16444 MFUNCTION EVENT,SUBR
\r
16449 CAIN 0,-2 ; IF JUST 1
\r
16450 JRST RE.EVN ; COULD BE EVENT
\r
16451 CAIL 0,-3 ; MUST BE AT LEAST 2 ARGS
\r
16453 GETYP A,2(AB) ; 2ND ARG MUST BE FIXED POINT PRIORITY
\r
16456 GETYP A,(AB) ; FIRST ARG SHOULD BE CHSTR
\r
16457 CAIN A,TATOM ; ALLOW ACTUAL ATOM
\r
16466 PUSHJ P,CHNORL ; CHANNEL OR LOCATIVE (PUT ON STACK)
\r
16468 GOTRGS: MOVEI B,(AB) ; NOW TRY TO FIND HEADER FOR THIS INTERRUPT
\r
16469 PUSHJ P,FNDINT ; CALL INTERNAL HACKER
\r
16470 JUMPN B,FINIS ; ALREADY ONE OF THIS NAME
\r
16472 JUMPE C,.+3 ; GET IT OFF STACK
\r
16475 PUSHJ P,MAKINT ; MAKE ONE FOR ME
\r
16477 MOVEM 0,INTPRI(B) ; SET UP PRIORITY
\r
16479 MOVEM 0,INTPRI+1(B)
\r
16480 CH.SPC: POP P,C ; GET CODE BACK
\r
16482 PUSHJ P,DO.SPC ; DO ANY SPECIAL HACKS
\r
16485 RE.EVN: GETYP 0,(AB)
\r
16487 JRST TFA ; ELSE SAY NOT ENOUGH
\r
16488 MOVE B,1(AB) ; GET IT
\r
16489 SETZM ISTATE+1(B) ; MAKE SURE ENABLED
\r
16491 GETYP A,INAME(B) ; CHECK FOR CHANNEL
\r
16492 CAIN A,TCHAN ; SKIP IF NOT
\r
16493 HRROI C,SS.CHA ; SET UP CHANNEL HACK
\r
16494 HRLZ E,INTPRI(B) ; GET POSSIBLE READ/WRITE BITS
\r
16495 TLNE E,.WRMON+.RDMON ; SKIP IF NOT MONITORS
\r
16498 MOVE B,INAME+1(B) ; CHECK FOR SPEC
\r
16500 MOVE B,1(AB) ; RESTORE IHEADER
\r
16501 RE.EV1: PUSH TP,INAME(B)
\r
16502 PUSH TP,INAME+1(B)
\r
16507 MOVE D,MQUOTE INTERRUPT
\r
16510 MOVE B,INAME+1(B) ; GET IT
\r
16511 PUSHJ P,IGET ; LOOK FOR IT
\r
16512 JUMPN B,FINIS ; RETURN IT
\r
16519 PUSHJ P,IPUT ; REESTABLISH IT
\r
16525 ; FUNCTION TO GENERATE A HANDLER FOR A GIVEN INTERRUPT
\r
16527 MFUNCTION HANDLER,SUBR
\r
16532 CAIL 0,-2 ; MUST BE 2 OR MORE ARGS
\r
16535 CAIE A,TINTH ; EVENT?
\r
16538 CAIN 0,-4 ; IF EXACTLY 2
\r
16539 CAIE A,THAND ; COULD BE HANDLER
\r
16542 MOVE B,3(AB) ; GET IT
\r
16543 SKIPN IPREV+1(B) ; SKIP IF ALREADY IN USE
\r
16545 MOVE D,1(AB) ; GET EVENT
\r
16546 SKIPN D,IHNDLR+1(D) ; GET FIRST HANDLER
\r
16548 CAMN D,B ; IS THIS IT?
\r
16549 JRST HFINIS ; YES, ALREADY "HANDLED"
\r
16550 MOVE D,INXT+1(D) ; GO TO NEXT HANDLER
\r
16552 BADHND: PUSH TP,$TATOM
\r
16553 PUSH TP,EQUOTE HANDLER-ALREADY-IN-USE
\r
16556 CHEVNT: CAIG 0,-7 ; SKIP IF LESS THAN 4
\r
16558 PUSH TP,$TPVP ; SLOT FOR PROCESS
\r
16560 CAIE 0,-6 ; IF 3, LOOK FOR PROC
\r
16568 NOPROC: PUSHJ P,APLQ
\r
16570 PUSHJ P,MHAND ; MAKE THE HANDLER
\r
16571 MOVE 0,1(TB) ; GET PROCESS
\r
16572 MOVEM 0,INTPRO+1(B) ; AND PUT IT INTO HANDLER
\r
16573 MOVSI 0,TPVP ; SET UP TYPE
\r
16574 MOVEM 0,INTPRO(B)
\r
16575 MOVE 0,2(AB) ; SET UP FUNCTION
\r
16576 MOVEM 0,INTFCN(B)
\r
16578 MOVEM 0,INTFCN+1(B)
\r
16580 HNDOK: MOVE D,1(AB) ; PICK UP EVEENT
\r
16581 MOVE E,IHNDLR+1(D) ; GET POINTER TO HANDLERS
\r
16582 MOVEM B,IHNDLR+1(D) ; PUT NEW ONE IN
\r
16583 MOVSI 0,TINTH ; GET INT HDR TYPE
\r
16584 MOVEM 0,IPREV(B) ; INTO BACK POINTER
\r
16585 MOVEM D,IPREV+1(B) ; AND POINTER ITSELF
\r
16586 MOVEM E,INXT+1(B) ; NOW NEXT POINTER
\r
16587 MOVSI 0,THAND ; NOW HANDLER TYPE
\r
16588 MOVEM 0,IHNDLR(D) ; SET TYPE IN HEADER
\r
16590 JUMPE E,HFINIS ; JUMP IF HEADER WAS EMPTY
\r
16591 MOVEM 0,IPREV(E) ; FIX UP ITS PREV
\r
16592 MOVEM B,IPREV+1(E)
\r
16593 HFINIS: MOVSI A,THAND
\r
16598 ; FUNCTIONS TO SET TIME LIMITS FOR REALTIME AND RUNTIME INTS
\r
16600 MFUNCTION RUNTIMER,SUBR
\r
16612 RUNT1: CAIE 0,TFLOAT
\r
16614 FMPR A,[245760.62]
\r
16615 MULI A,400 ; FIX IT
\r
16619 RUNT2: JUMPL A,OUTRNG ; NOT FOR NEG #
\r
16621 .SUSET [.SRTMR,,A]
\r
16626 MFUNCTION REALTIMER,SUBR
\r
16635 IMULI A,60. ; TO 60THS OF SEC
\r
16638 REALT1: CAIE 0,TFLOAT
\r
16646 REALT2: JUMPL A,OUTRNG
\r
16648 MOVE B,[200000,,A]
\r
16655 ; FUNCTIONS TO ENABLE AND DISABLE INTERRUPTS
\r
16657 MFUNCTION %ENABL,SUBR,ENABLE
\r
16660 SETZM ISTATE+1(B)
\r
16663 MFUNCTION %DISABL,SUBR,DISABLE
\r
16667 SETOM ISTATE+1(B)
\r
16678 DO.SPC: HRRZ C,INTBL(C) ; POINT TO SPECIAL CODE
\r
16679 HLRZ 0,AB ; - TWO TIMES NUM ARGS
\r
16680 PUSHJ P,(C) ; CALL ROUTINE
\r
16681 JUMPE E,CPOPJ ; NO BITS TO ENABLE, LEAVE
\r
16685 MOVE B,1(TB) ; CHANNEL
\r
16687 MOVEM 0,(E) ; SAVE IN TABLE
\r
16689 SUBI E,NETJFN-NETCHN
\r
16690 MOVE A,0 ; SETUP FOR MTOPR
\r
16693 TLO C,770000 ; DONT SETUP INR/INS
\r
16705 POPJ P, ; ***** TEMP ******
\r
16708 CAILE E,35. ; SKIP IF 1ST WORD BIT
\r
16712 IORM 0,MASK1 ; STORE IN PROTOTYPE MASK
\r
16713 .SUSET [.SMASK,,MASK1]
\r
16716 SETW2: LSH 0,-36.(E)
\r
16717 IORM 0,MASK2 ; SET UP PROTO MASK2
\r
16718 .SUSET [.SMSK2,,MASK2]
\r
16722 ; ROUTINE TO CHECK FOR CHANNEL OR LOCATIVE
\r
16724 CHNORL: GETYP A,(B) ; GET TYPE
\r
16725 CAIN A,TCHAN ; IF CHANNEL
\r
16728 PUSHJ P,LOCQ ; ELSE LOOCATIVE
\r
16731 CHNWIN: PUSH TP,(B)
\r
16735 ; SUBROUTINE TO FIND A HANDLER OF A GIVEN NAME
\r
16737 FNDINT: PUSHJ P,FNDNM
\r
16739 PUSHJ P,SPEC1 ; COULD BE FUNNY
\r
16741 INTASO: PUSH P,C ; C<0 IF SPECIAL
\r
16745 SKIPN D ; COULD BE CHANGED FOR MONITOR
\r
16746 MOVE D,MQUOTE INTERRUPT
\r
16752 POP P,C ; AND RESTOR SPECIAL INDICATOR
\r
16753 SKIPE B ; IF FOUND
\r
16754 SUB TP,[2,,2] ; REMOVE CRUFT
\r
16755 CPOPJ: POPJ P, ; AND RETURN
\r
16757 ; CHECK FOR SPECIAL INTERNAL INTERRUPT HACK
\r
16759 SPEC1: MOVSI C,-SPECLN ; BUILD AOBJN PNTR
\r
16760 SPCLOP: CAME B,@SPECIN(C) ; SKIP IF SPECIAL
\r
16761 AOBJN C,.-1 ; UNTIL EXHAUSTED
\r
16763 SKIPE E,FNDTBL(C)
\r
16765 MOVEI 0,-1(TB) ; SEE IF OK
\r
16770 ; ROUTINE TO CREATE A NEW INTERRUPT (INTERNAL ONLY--NOT ITS FLAVOR)
\r
16772 MAKINT: JUMPN C,GOTATM ; ALREADY HAVE NAME, GET THING
\r
16773 MOVEI B,(AB) ; POINT TO STRING
\r
16774 PUSHJ P,CSTAK ; CHARS TO STAKC
\r
16775 MOVE B,INTOBL+1(TVP)
\r
16777 MOVE D,MQUOTE INTERRUPT
\r
16778 GOTATM: PUSH TP,$TINTH ; MAKE SLOT FOR HEADER BLOCK
\r
16781 PUSH TP,B ; SAVE ATOM
\r
16786 MOVE A,-3(TP) ; GET NAME AND STORE SAME
\r
16789 MOVEM A,INAME+1(B)
\r
16790 SETZM ISTATE+1(B)
\r
16791 MOVEM B,-4(TP) ; STASH HEADER
\r
16796 EXCH A,-1(TP) ; INTERNAL PUT CALL
\r
16802 ; FIND NAME OF INTERRUPT
\r
16804 FNDNM: GETYP A,(B) ; TYPE
\r
16805 CAIE A,TCHSTR ; IF STRING
\r
16806 JRST FNDATM ; DONT HAVE ATOM, OTHERWISE DO
\r
16809 FNDATM: MOVE B,1(B)
\r
16810 SETZB C,D ; PREVENT LOSSAGE LATER
\r
16813 ; THE NEXT 2 INSTRUCTIONS ARE A KLUDGE TO GET THE RIGHT ERROR ATOM
\r
16815 CAMN B,IMQUOTE ERROR
\r
16816 MOVE B,MQUOTE ERROR,ERROR,INTRUP
\r
16819 IILOOK: PUSHJ P,CSTAK ; PUT CHRS ON STACK
\r
16820 MOVE B,INTOBL+1(TVP)
\r
16821 JRST ILOOKC ; LOOK IT UP
\r
16823 ; ROUTINE TO MAKE A HANDLER BLOCK
\r
16825 MHAND: MOVEI A,IHANDL*2
\r
16826 JRST GIBLOK ; GET BLOCK
\r
16828 ; HERE TO GET CHANNEL FOR "CHAR" INTERRUPT
\r
16830 GETCHN: GETYP 0,(TB) ; GET TYPE
\r
16831 CAIE 0,TCHAN ; CHANNL IS WINNER
\r
16833 MOVE A,(TB) ; USE THE CHANNEL TO NAME THE INTERRUPT
\r
16835 SKIPN CHANNO(B) ; SKIP IF WINNING CHANNEL
\r
16836 JRST CBDCHN ; LOSER
\r
16839 LOCGET: GETYP 0,(TB) ; TYPE
\r
16840 CAIN 0,TCHAN ; SKIP IF LOCATIVE
\r
16844 MOVE B,1(TB) ; GET LOCATIVE
\r
16847 ; FINAL MONITOR SETUP ROUTINES
\r
16849 S.RMON: SKIPA E,[.RDMON,,]
\r
16850 S.WMON: MOVSI E,.WRMON
\r
16853 HLRM E,INTPRI(B) ; SAVE BITS
\r
16854 MOVEI B,(TB) ; POINT TO LOCATIVE
\r
16857 MOVSI D,(ANDCAM E,) ; KILL INST
\r
16859 MOVSI D,(IORM E,)
\r
16860 PUSHJ P,SMON ; GO DO IT
\r
16867 ; SPECIAL SETUP ROUTINES FOR INITIAL INTERRUPTS
\r
16870 S.CHAR: MOVE E,1(TB) ; GET CHANNEL
\r
16872 ADDI E,36. ; GET CORRECT MASK BIT
\r
16873 ONEBIT: MOVEI 0,1 ; BIT FOR INT TO RET
\r
16877 S.CHAR: MOVE E,1(TB)
\r
16879 ILDB 0,0 ; 1ST CHAR
\r
16881 CAIE 0,"N ; NET ?
\r
16886 MOVE E,[-NNETS,,NETJFN]
\r
16890 MOVE A,E ; REMEMBER WHERE
\r
16893 FATAL NO MORE NETWORK
\r
16895 S.CHA1: MOVEI E,0
\r
16901 ; SPECIAL FOR CLOCK
\r
16903 S.DOWN: SKIPA E,[7]
\r
16904 S.CLOK: MOVEI E,13. ; FOR NOW JUST GET BIT #
\r
16907 S.PAR: MOVEI E,28.
\r
16910 ; RUNTIME AND REALTIME INTERRUPTS
\r
16912 S.RUNT: SKIPA E,[34.]
\r
16913 S.REAL: MOVEI E,35.
\r
16916 S.IOC: SKIPA E,[9.] ; IO CHANNEL ERROR
\r
16917 S.PURE: MOVEI E,26.
\r
16922 S.MPV: SKIPA E,[14.] ; BIT POS
\r
16923 S.ILOP: MOVEI E,6
\r
16926 ; HERE TO TURN ALL INFERIOR INTS
\r
16928 S.INF: MOVEI E,36.+16.+2 ; START OF BITS
\r
16929 MOVEI 0,37 ; 8 BITS WORTH
\r
16933 ; HERE TO HANDLE ITS INTERRUPTS
\r
16935 FHAND: SKIPN D,EXTINT(B) ; SKIP IF HANDLERS ARE POSSIBLE
\r
16940 ; SPECIAL CHARACTER HANDLERS
\r
16942 HCHAR: MOVEI D,CHNL0+1(TVP)
\r
16943 ADDI D,(B) ; POINT TO CHANNEL SLOT
\r
16945 SKIPN D,-72.(D) ; PICK UP CHANNEL
\r
16946 JRST IPCGOT ;WELL, IT GOTTA BEE THE THE IPC THEN
\r
16949 LDB 0,[600,,STATUS(D)] ; GET DEVICE CODE
\r
16950 CAILE 0,2 ; SKIP IF A TTY
\r
16951 JRST HNET ; MAYBE NETWORK CHANNEL
\r
16952 CAMN D,TTICHN+1(TVP)
\r
16955 MOVE B,D ; CHAN TO B
\r
16956 PUSHJ P,TTYOP2 ; RE-GOBBLE TTY
\r
16958 HCHR11: MOVE D,CHANNO(D) ; GET ITS CHANNEL
\r
16959 PUSH P,D ; AND SAVE IT
\r
16960 .CALL HOWMNY ; GET # OF CHARS
\r
16961 MOVEI B,0 ; IF TTY GONE, NO CHARS
\r
16962 RECHR: ADDI B,1 ; BUMP BY ONE FOR SOSG
\r
16963 MOVEM B,CHNCNT(D) ; AND SAVE
\r
16964 IORM A,PIRQ2 ; LEAVE THE INT ON
\r
16966 CHRLOO: MOVE D,(P) ; GET CHNNAEL NO.
\r
16967 SOSG CHNCNT(D) ; GET COUNT
\r
16971 MOVE D,BUFRIN(B) ; GET EXTRA BUFFER
\r
16972 XCT IOIN2(D) ; READ CHAR
\r
16974 PUSH TP,CHQUOTE CHAR
\r
16975 PUSH TP,$TCHRS ; SAVE CHAR FOR CALL
\r
16977 PUSH TP,$TCHAN ; SAVE CHANNEL
\r
16979 PUSHJ P,INCHAR ; PUT CHAR IN USERS BUFFER
\r
16980 MCALL 3,INTERRUPT ; RUN THE HANDLERS
\r
16981 JRST CHRLOO ; AND LOOP
\r
16983 CHRDON: .CALL HOWMNY
\r
16985 MOVEI A,1 ; SET FOR PI WORD CLOBBER
\r
16987 JUMPG B,RECHR ; ANY MORE?
\r
16995 ; HERE FOR NET CHANNEL INTERRUPT
\r
16997 HNET: CAIE 0,26 ; NETWORK?
\r
16998 JRST HSTYET ; HANDLE PSEUDO TTY ETC.
\r
17000 PUSH TP,MQUOTE CHAR,CHAR,INTRUP
\r
17002 PUSH TP,BUFRIN(D)
\r
17005 MOVE B,D ; CHAN TO B
\r
17006 PUSHJ P,INSTAT ; UPDATE THE NETWRK STATE
\r
17007 MCALL 3,INTERRUPT
\r
17011 HSTYET: PUSH TP,$TATOM
\r
17012 PUSH TP,MQUOTE CHAR,CHAR,INTRUP
\r
17015 MCALL 2,INTERRUPT
\r
17020 CBDCHN: PUSH TP,$TATOM
\r
17021 PUSH TP,EQUOTE BAD-CHANNEL
\r
17026 HCLOCK: PUSH TP,$TCHSTR
\r
17027 PUSH TP,CHQUOTE CLOCK
\r
17028 MCALL 1,INTERRUPT
\r
17031 HRUNT: PUSH TP,$TATOM
\r
17032 PUSH TP,MQUOTE RUNT,RUNT,INTRUP
\r
17033 MCALL 1,INTERRUPT
\r
17036 HREAL: PUSH TP,$TATOM
\r
17037 PUSH TP,MQUOTE REALT,REALT,INTRUP
\r
17038 MCALL 1,INTERRUPT
\r
17041 HPAR: MOVE A,MQUOTE PARITY,PARITY,INTRUP
\r
17044 HMPV: MOVE A,MQUOTE MPV,MPV,INTRUP
\r
17047 HILOPR: MOVE A,MQUOTE ILOPR,ILOPR,INTRUP
\r
17050 HPURE: MOVE A,MQUOTE PURE,PURE,INTRUP
\r
17051 HMPV1: PUSH TP,$TATOM
\r
17053 PUSH P,LCKINT ; SAVE LOCN
\r
17058 MCALL 2,EMERGENCY
\r
17065 PUSH TP,EQUOTE DANGEROUS-INTERRUPT-NOT-HANDLED
\r
17075 ; HERE TO HANDLE SYS DOWN INTERRUPT
\r
17077 HDOWN: PUSH TP,$TATOM
\r
17078 PUSH TP,MQUOTE SYSDOWN,SYSDOWN,INTRUP
\r
17079 .DIETI A, ; HOW LONG?
\r
17082 PUSH P,A ; FOR MESSAGE
\r
17083 MCALL 2,INTERRUPT
\r
17086 .SUSET [.RTTY,,B] ; DO WE NOW HAVE A TTY AT ALL?
\r
17087 JUMPL B,DIRQ ; DONT HANG AROUND
\r
17090 Excuse me, SYSTEM going down in /]
\r
17091 SKIPG (P) ; SKIP IF REALLY GOING DOWN
\r
17093 Excuse me, SYSTEM has been REVIVED!
\r
17098 IDIVI B,30. ; TO SECONDS
\r
17099 IDIVI B,60. ; A/ SECONDS B/ MINUTES
\r
17103 MOVEI B,[ASCIZ / minutes /]
\r
17107 NOMIN: MOVEI B,(C)
\r
17109 MOVEI B,[ASCIZ / seconds.
\r
17114 ; TWO DIGIT DEC OUT FROM B/
\r
17116 DECOUT: IDIVI B,10.
\r
17117 JUMPE B,DECOU1 ; NO TEN
\r
17120 DECOU1: MOVEI A,60(C)
\r
17123 ; HERE TO HANDLE I/O CHANNEL ERRORS
\r
17125 HIOC: .SUSET [.RAPRC,,A] ; CONTAINS CHANNEL OF MOST RECENT LOSSAGE
\r
17126 LDB A,[330400,,A] ; GET CHAN #
\r
17127 MOVEI C,(A) ; COPY
\r
17128 PUSH TP,$TATOM ; PUSH ERROR
\r
17129 PUSH TP,EQUOTE FILE-SYSTEM-ERROR
\r
17132 ASH C,1 ; GET CHANNEL
\r
17133 ADDI C,CHNL0+1(TVP) ; GET CHANNEL VECTOR
\r
17135 LSH A,23. ; DO A .STATUS
\r
17136 IOR A,[.STATUS A]
\r
17138 PUSHJ P,GFALS ; GEN NAMED FALSE
\r
17142 PUSH TP,MQUOTE IOC,IOC,INTRUP
\r
17148 MCALL 3,EMERGENCY
\r
17149 JUMPN B,DIRQ1 ; JUMP IF HANDLED
\r
17153 DIRQ1: SUB TP,[6,,6]
\r
17156 ; HANDLE INFERIOR KNOCKING AT THE DOOR
\r
17158 HINF: SUBI B,36.+16.+2 ; CONVERT TO INF #
\r
17160 PUSH TP,MQUOTE INFERIOR,INFERIOR,INTRUP
\r
17163 MCALL 2,INTERRUPT
\r
17168 ; HERE FOR TENEX INTS (FIRST CUT)
\r
17170 HCNTLG: MOVEI A,7
\r
17173 HCNTLS: MOVEI A,23
\r
17175 HCNGS: PUSH TP,$TATOM
\r
17176 PUSH TP,MQUOTE CHAR,CHAR,INTRUP
\r
17180 PUSH TP,TTICHN+1(TVP)
\r
17181 MCALL 3,INTERRUPT
\r
17184 HNET: MOVE A,NETJFN-NINT+NNETS(B)
\r
17187 ADDI A,CHNL0+1(TVP)
\r
17190 PUSH TP,MQUOTE CHAR,CHAR,INTRUP
\r
17192 PUSH TP,BUFRIN(B)
\r
17196 MCALL 3,INTERRUPT
\r
17201 MFUNCTION OFF,SUBR
\r
17206 GETYP A,(AB) ; ARG TYPE
\r
17207 MOVE B,1(AB) ; AND VALUE
\r
17208 CAIN A,TINTH ; HEADER, GO HACK
\r
17209 JRST OFFHD ; QUEEN OF HEARTS
\r
17213 JRST TRYHAN ; MAYBE INDIVIDUAL HANDLER
\r
17214 CAIN 0,-2 ; MORE THAN 1 ARG?
\r
17215 JRST OFFAC1 ; NO, GO ON
\r
17216 CAIG 0,-5 ; CANT BE MORE THAN 2
\r
17218 MOVEI B,2(AB) ; POINT TO 2D
\r
17220 OFFAC1: MOVEI B,(AB)
\r
17222 JUMPGE B,NOHAN1 ; NOT HANDLED
\r
17224 OFFH1: PUSH P,C ; SAVE C FOR BIT CLOBBER
\r
17227 MOVE D,MQUOTE INTERRUPT
\r
17229 MOVE B,INAME+1(B)
\r
17231 SKIPE B ; IF NO ASSOC, DONT SMASH
\r
17232 SETOM ISTATE+1(B) ; DISABLE IN CASE QUEUED
\r
17233 POP P,C ; SPECIAL?
\r
17234 JUMPGE C,FINIS ; NO, DONE
\r
17236 HRRZ C,INTBL(C) ; POINT TO SPECIAL CODE
\r
17237 PUSHJ P,(C) ; GO TO SAME
\r
17238 JUMPE E,OFINIS ; DONE
\r
17240 CAILE E,35. ; SKIP IF 1ST WORD
\r
17241 JRST CLRW2 ; CLOBBER 2D WORD BIT
\r
17242 LSH 0,-1(E) ; POSITION BIT
\r
17243 ANDCAM 0,MASK1 ; KILL BIT
\r
17244 .SUSET [.SMASK,,MASK1]
\r
17250 SUBI E,NETJFN-NETCHN
\r
17258 ANDCAM 0,PIRQ ; JUST IN CASE
\r
17261 OFINIS: MOVSI A,TINTH
\r
17265 CLRW2: LSH 0,-36.(E) ; POS BIT FOR 2D WORD
\r
17267 .SUSET [.SMSK2,,MASK2]
\r
17271 TRYHAN: CAIE A,THAND ; HANDLER?
\r
17275 GETYP 0,IPREV(B) ; GET TYPE OF PREV
\r
17277 MOVE C,IPREV+1(B)
\r
17280 JRST DOHEAD ; PREV HUST BE HDR
\r
17281 MOVEM A,INXT+1(C)
\r
17283 DOHEAD: MOVEM A,IHNDLR+1(C) ; INTO HDR
\r
17286 MOVEM C,IPREV+1(A)
\r
17287 OFFINI: SETZM IPREV+1(B)
\r
17294 PUSHJ P,GETNMS ; GET INFOR ABOUT INT
\r
17297 PUSH TP,INAME+1(B)
\r
17300 GETNMS: GETYP A,INAME(B) ; CHECK FOR SPECIAL
\r
17304 PUSHJ P,LOCQ ; LOCATIVE?
\r
17307 MOVEI B,INAME(B) ; POINT TO LOCATIVE
\r
17308 MOVSI D,(MOVE E,)
\r
17309 PUSHJ P,SMON ; GET MONITOR
\r
17311 GETNM1: HRROI C,SS.WMO ; ASSUME WRITE
\r
17314 MOVE D,MQUOTE WRITE,WRITE,INTRUP
\r
17316 MOVE D,MQUOTE READ,READ,INTRUP
\r
17319 CHGTNM: JUMPL C,CPOPJ
\r
17320 MOVE B,INAME+1(B)
\r
17322 MOVE B,1(AB) ; RESTORE IHEADER
\r
17325 ; EMERGENCY, CANT DEFER ME!!
\r
17333 MFUNCTION INTERRUPT,SUBR
\r
17339 SETZM INTHLD ; RE-ENABLE THE WORLD
\r
17341 MOVE B,1(AB) ; GET HANDLER/NAME
\r
17342 GETYP A,(AB) ; CAN BE HEADER OR NAME
\r
17343 CAIN A,TINTH ; SKIP IF NOT HEADER
\r
17347 CAIE A,TCHSTR ; SKIP IF CHAR STRING
\r
17349 MOVEI B,(AB) ; LOOK UP NAME
\r
17350 PUSHJ P,FNDNM ; GET NAME
\r
17353 CAMN B,MQUOTE CHAR,CHAR,INTRUP
\r
17355 CAME B,MQUOTE READ,READ,INTRUP
\r
17356 CAMN B,MQUOTE WRITE,WRITE,INTRUP
\r
17361 GTHEAD: SKIPE ISTATE+1(B) ; ENABLED?
\r
17362 JRST IFALSE ; IGNORE COMPLETELY
\r
17363 MOVE A,INTPRI+1(B) ; GET PRIORITY OF INTERRUPT
\r
17364 CAMLE A,CURPRI ; SEE IF MUST QUEU
\r
17365 JRST SETPRI ; MAY RUN NOW
\r
17366 SKIPE (P) ; SKIP IF DEFER OK
\r
17369 PUSH TP,$TINTH ; SAVE HEADER
\r
17371 MOVEI A,1 ; SAVE OTHER ARGS
\r
17372 PSHARG: ADD AB,[2,,2]
\r
17373 JUMPGE AB,QUEU1 ; GO MAKE QUEU ENTRY
\r
17377 QUEU1: PUSHJ P,IEVECT ; GET VECTOR
\r
17379 PUSH TP,[0] ; WILL HOLD QUEUE HEADER
\r
17383 POP P,A ; RESTORE PRIORITY
\r
17385 MOVE B,QUEUES+1(TVP) ; GET INTERRUPT QUEUES
\r
17387 JUMPGE B,GQUEU ; MAKE A QUEUE HDR
\r
17389 NXTQU: CAMN A,1(B) ; GOT PRIORITY?
\r
17390 JRST ADDQU ; YES, ADD TO THE QUEU
\r
17391 CAMG A,1(B) ; SKIP IF SPOT NOT FOUND
\r
17394 MOVE B,3(B) ; GO TO NXT QUEUE
\r
17397 GQUEU: PUSH TP,$TVEC ; SAVE NEXT POINTER
\r
17400 PUSH TP,A ; SAVE PRIORITY
\r
17409 MOVE D,(TP) ; NOW SPLICE
\r
17412 MOVEM B,QUEUES+1(TVP)
\r
17414 GQUEU1: MOVEM B,3(D)
\r
17416 ADDQU: MOVEM B,-2(TP) ; SAVE QUEU HDR
\r
17419 PUSHJ P,INCONS ; CONS IT
\r
17420 MOVE C,(TP) ;GET QUEUE HEADER
\r
17421 SKIPE D,7(C) ; IF END EXISTS
\r
17422 HRRM B,(D) ; SPLICE
\r
17424 SKIPN 5(C) ; SKIP IF START EXISTS
\r
17427 IFINI: MOVSI A,TATOM
\r
17431 SETPRI: EXCH A,CURPRI
\r
17434 PUSH TP,$TAB ; PASS AB TO HANDLERS
\r
17437 PUSHJ P,RUNINT ; RUN THE HANDLERS
\r
17438 POP P,A ; UNQUEU ANY WAITERS
\r
17443 ; HERE TO UNQUEUE WAITING INTERRUPTS
\r
17445 UNQUEU: PUSH P,A ; SAVE NEW LEVEL
\r
17447 UNQUE1: MOVE A,(P) ; TARGET LEVEL
\r
17448 CAMLE A,CURPRI ; CHECK RUG NOT PULLED OUT
\r
17450 SKIPE B,QUEUES+1(TVP)
\r
17451 CAML A,1(B) ; RIGHT LEVEL?
\r
17452 JRST UNDONE ; FINISHED
\r
17454 SKIPN C,5(B) ; ON QUEUEU?
\r
17456 HRRZ D,(C) ; CDR THE LIST
\r
17458 SKIPN D ; SKIP IF NOT LAST
\r
17459 SETZM 7(B) ; CLOBBER END POINTER
\r
17460 MOVE A,1(B) ; GET THIS PRIORITY LEVEL
\r
17461 MOVEM A,CURPRI ; MAKE IT THE CURRENT ONE
\r
17462 MOVE D,1(C) ; GET SAVED VECTOR OF INF
\r
17464 MOVE B,1(D) ; INT HEADER
\r
17466 PUSH TP,D ; AND ARGS
\r
17468 PUSHJ P,RUNINT ; RUN THEM
\r
17471 UNDONE: POP P,CURPRI ; SET CURRENT LEVEL
\r
17475 UNXQ: MOVE B,3(B) ; GO TO NEXT QUEUE
\r
17476 MOVEM B,QUEUES+1(TVP)
\r
17481 ; SUBR TO CHANGE INTERRUPT LEVEL
\r
17483 MFUNCTION INTLEV,SUBR,[INT-LEVEL]
\r
17485 JUMPGE AB,RETLEV ; JUST RETURN CURRENT
\r
17488 JRST WTYP1 ; LEVEL IS FIXED
\r
17491 CAMN A,CURPRI ; DIFFERENT?
\r
17492 JRST RETLEV ; NO RETURN
\r
17494 CAMG A,CURPRI ; SKIP IF NO UNQUEUE NEEDED
\r
17496 MOVEM A,CURPRI ; SAVE
\r
17499 RETLEV: MOVE B,CURPRI
\r
17503 RUNINT: PUSH TP,$THAND ; SAVE HANDLERS LIST
\r
17504 PUSH TP,IHNDLR+1(B)
\r
17506 SKIPN ISTATE+1(B) ; SKIP IF DISABLED
\r
17509 NXHND: MOVEM B,(TP) ; SAVE CURRENT HDR
\r
17510 MOVE A,-2(TP) ; SAVE ARG POINTER
\r
17511 PUSHJ P,CHSWAP ; SEE IF MUST SWAP
\r
17514 MOVEI C,1 ; COUNT ARGS
\r
17518 ADD D,[1STEPR,,1STEPR]
\r
17524 PUSH TP,INTFCN(B)
\r
17525 PUSH TP,INTFCN+1(B)
\r
17532 PUSHJ P,SPECBE ; BIND 1 STEP FLAG
\r
17536 MOVE C,(TP) ; RESET 1 STEP
\r
17537 MOVEM C,1STEPR+1(PVP)
\r
17541 SUB TP,[4,,4] ; NO PROCESS CHANGE, POP JUNK
\r
17544 MOVE D,TPSTO+1(E)
\r
17546 MOVEM D,TPSTO+1(E) ; FIXUP HIS STACK
\r
17547 DO.H1: GETYP A,A ; CHECK FOR A DISMISS
\r
17550 MOVE B,(TP) ; TRY FOR NEXT HANDLER
\r
17551 SKIPE B,INXT+1(B)
\r
17553 SUBTP4: SUB TP,[4,,4]
\r
17556 MFUNCTION INTAPL,SUBR,[RUNINT]
\r
17560 NOHAND: JUMPE C,NOHAN1
\r
17562 PUSH TP,EQUOTE INTERNAL-INTERRUPT
\r
17563 NOHAN1: PUSH TP,(AB)
\r
17566 PUSH TP,EQUOTE NOT-HANDLED
\r
17572 DEFERR: PUSH TP,$TATOM
\r
17573 PUSH TP,EQUOTE ATTEMPT-TO-DEFER-UNDEFERABLE-INTERRUPT
\r
17577 PUSH TP,MQUOTE INTERRUPT
\r
17578 MCALL 3,RERR ; FORCE REAL ERROR
\r
17581 ; FUNCTION TO DISMISS AN INTERRUPT TO AN ARBITRARY ACTIVATION
\r
17583 MFUNCTION DISMISS,SUBR
\r
17598 DISMI3: MOVEI A,(TB)
\r
17600 DISMI0: HRRZ B,FSAV(A)
\r
17606 MOVEI 0,(A) ; SAVE FRAME
\r
17608 HRRM A,PCSAV(E) ; GET IT BACK HERE
\r
17617 MOVE B,0 ; DEST FRAME
\r
17619 MOVE A,PSAV(E) ; NOW MUNG SAVED INT LEVEL
\r
17620 MOVEM D,-1(A) ; ZAP YOUR MUNGED
\r
17621 PUSHJ P,CHUNW ; CHECK ON UNWINDERS
\r
17622 JRST FINIS ; FALL DOWN
\r
17624 DISMI1: MOVEI E,(A)
\r
17649 DISMI2: MOVE C,(TP)
\r
17650 MOVEM C,1STEPR+1(PVP)
\r
17653 PUSHJ P,CHUNSW ; UNDO ANY PROCESS HACKING
\r
17655 CAME E,PVP ; SWAPED?
\r
17656 MOVE C,TPSTO+1(E)
\r
17660 SUB C,[4,,4] ; MAYBE FIXUP OTHER STACK
\r
17662 MOVEM C,TPSTO+1(E)
\r
17667 MOVE A,-1(P) ; SAVED PRIORITY
\r
17681 CHNGT1: HLRE B,AB
\r
17690 GTLOC1: GETYP A,2(AB)
\r
17693 MOVE D,B ; RET ATOM FOR ASSOC
\r
17697 \f; MONITOR CHECKERS
\r
17699 MONCH0: HLLZ 0,(B) ; POTENTIAL MONITORS
\r
17700 MONCH: TLZ 0,TYPMSK ; KILL TYPE
\r
17701 IOR C,0 ; IN NEW TYPE
\r
17707 TLNN 0,.WRMON ; SKIP IF WRITE MONIT
\r
17710 ; MONITOR IS ON, INVOKE HANDLER
\r
17712 PUSH TP,A ; SAVE OBJ
\r
17715 PUSH TP,D ; SAVE DATUM
\r
17716 MOVSI C,TATOM ; PREPARE TO FIND IT
\r
17717 MOVE D,MQUOTE WRITE,WRITE,INTRUP
\r
17719 JUMPE B,MONCH1 ; NOT FOUND IGNORE FOR NOW
\r
17720 PUSH TP,A ; START SETTING UP CALL
\r
17726 PUSHJ P,FRMSTK ; PUT FRAME ON STAKC
\r
17727 MCALL 4,EMERGE ; DO IT
\r
17732 HLLZ 0,(B) ; UPDATE MONITORS
\r
17737 ; NOW FOR READ MONITORS
\r
17739 RMONC0: HLLZ 0,(B)
\r
17740 RMONCH: TLNN 0,.RDMON
\r
17745 MOVE D,MQUOTE READ,READ,INTRUP
\r
17752 PUSHJ P,FRMSTK ; PUT FRAME ON STACK
\r
17758 ; PUT THE CURRENT FRAME ON THE STACK
\r
17760 FRMSTK: PUSHJ P,MAKACT
\r
17766 ; HERE TO COMPLAIN ABOUT ATTEMPTS TO MUNG PURE CODE
\r
17768 PURERR: PUSH TP,$TATOM
\r
17769 PUSH TP,EQUOTE ATTEMPT-TO-MUNG-PURE-STRUCTURE
\r
17775 ; PROCESS SWAPPING CODE
\r
17777 CHSWAP: MOVE E,PVP ; GET CURRENT
\r
17779 SKIPE D,INTPRO+1(B) ; SKIP IF NO PROCESS GIVEN
\r
17780 CAMN D,PVP ; SKIP IF DIFFERENT
\r
17783 PUSHJ P,SWAPIT ; DO SWAP
\r
17785 PSHPRO: PUSH TP,$TPVP
\r
17789 CHUNSW: MOVE E,PVP ; RET OLD PROC
\r
17790 MOVE D,-2(TP) ; GET SAVED PROC
\r
17791 CAMN D,PVP ; SWAPPED?
\r
17795 MOVE 0,PSTAT+1(D) ; CHECK STATE
\r
17798 MOVEM 0,PSTAT+1(PVP)
\r
17800 MOVEM 0,PSTAT+1(D) ; SAVE NEW STATE
\r
17806 ;SUBROUTINE TO GET BIT FOR CLOBBERAGE
\r
17808 GETBIT: MOVNS B ;NEGATE
\r
17809 MOVSI A,400000 ;GET THE BIT
\r
17810 LSH A,(B) ;SHIFT TO POSITION
\r
17811 POPJ P, ;AND RETURN
\r
17813 ;HERE TO HANDLE PDL OVERFLOW. ASK FOR A GC
\r
17817 MOVEM A,TSINT ;SAVE INT WORD
\r
17820 SKIPE GCFLG ;IS GC RUNNING?
\r
17821 JRST GCPLOV ;YES, COMPLAIN GROSSLY
\r
17823 MOVEI A,200000 ;GET BIT TO CLOBBER
\r
17824 IORM A,PIRQ ;LEAVE A MESSAGE FOR HIGHER LEVEL
\r
17826 EXCH P,GCPDL ;GET A WINNING PDL
\r
17827 HRRZ B,TSINTR ;GET POINTER TO LOSING INSTRUCTION
\r
17828 SKIPG GCPDL ; SKIP IF NOT P
\r
17829 LDB B,[270400,,-1(B)] ;GET AC FIELD
\r
17830 SKIPL GCPDL ; SKIP IF P
\r
17832 MOVEI A,(B) ;COPY IT
\r
17834 ADDI A,0STO(PVP) ;POINT TO THIS ACS CURRENT TYPE
\r
17835 HLRZ A,(A) ;GET THAT TYPE INTO A
\r
17836 CAIN B,P ;IS IT P
\r
17837 MOVEI B,GCPDL ;POINT TO SAVED P
\r
17839 CAIN B,B ;OR IS IT B ITSELF
\r
17845 MOVEI B,1(P) ;C WILL BE ON THE STACK
\r
17850 MOVE A,(B) ;GET THE LOSING POINTER
\r
17851 MOVEI C,(A) ;AND ISOLATE RH
\r
17853 CAMG C,VECTOP ;CHECK IF IN GC SPACE
\r
17855 JRST NOGROW ;NO, COMPLAIN
\r
17860 HLRZ C,A ;GET -LENGTH
\r
17861 SUBI A,-1(C) ;POINT TO A DOPE WORD
\r
17862 POP P,C ;RESTORE TYPE INTO C
\r
17863 PUSH P,D ; SAVE FOR GROWTH HACKER
\r
17865 CAIN C,TPDL ; POIN TD TO APPROPRIATE DOPE WORD
\r
17869 JUMPE D,BADPDL ; IF D STILL 0, THIS PDL IS WEIRD
\r
17870 MOVEI A,PDLBUF(A) ; POINT TO ALLEGED REAL DOPE WORD
\r
17871 SKIPN (D) ; SKIP IF PREVIOUSLY BLOWN
\r
17872 MOVEM A,(D) ; CLOBBER IN
\r
17873 CAME A,(D) ; MAKE SURE IT IS THE SAME
\r
17875 POP P,D ; RESTORE D
\r
17878 PNTRHK: MOVE C,(B) ;RESTORE PDL POINTER
\r
17879 SUB C,[PDLBUF,,0] ;FUDGE THE POINTER
\r
17880 MOVEM C,(B) ;AND STORE IT
\r
17882 POP P,C ;RESTORE THE WORLD
\r
17883 EXCH P,GCPDL ;GET BACK ORIG PDL
\r
17885 MOVE A,TSINT ;RESTORE INT WORD
\r
17887 JRST IMPCH ;LOOK FOR MORE INTERRUPTS
\r
17889 IFE ITS, JRST GCQUIT
\r
17891 TPOVFL: SETOM INTFLG ;SIMULATE PDL OVFL
\r
17893 MOVEI A,200000 ;TURN ON THE BIT
\r
17895 SUB TP,[PDLBUF,,0] ;HACK STACK POINTER
\r
17896 HLRE A,TP ;FIND DOPEW
\r
17897 SUBM TP,A ;POINT TO DOPE WORD
\r
17898 MOVEI A,1(A) ; ZERO LH AND POINT TO DOPEWD
\r
17901 CAME A,TPGROW ; MAKE SURE WINNAGE
\r
17907 ; GROW CORE IF PDL OVERFLOW DURING GC
\r
17909 GCPLOV: MOVE A,P.TOP ; GET TOP OF IMPURE
\r
17910 ASH A,-10. ; TO BLOCKS
\r
17911 EXCH P,GCPDL ; NEED A PDL TO CALL P.CORE
\r
17912 ADDI A,1 ; GO TO NEXT BLOCK
\r
17913 GRECOR: PUSHJ P,P.CORE ; GET CORE
\r
17914 JRST SLPCOR ; HANG GETTING THE CORE
\r
17915 EXCH P,GCPDL ; BPDLS BACK
\r
17917 IFE ITS, JRST GCQUIT
\r
17923 SLPCOR: MOVEI B,1
\r
17931 ;HERE TO HANDLE LOW-LEVEL CHANNELS
\r
17934 CHNACT: SKIPN GCFLG ;GET A WINNING PDL
\r
17936 ANDI A,177777 ;ISOLATE CHANNEL BITS
\r
17939 CHNA1: MOVEI B,0 ;BIT COUNTER
\r
17940 JFFO A,.+2 ;COUNT
\r
17942 SUBI B,35. ;NOW HAVE CHANNEL
\r
17947 MOVEI 0,(B) ; COPY TO 0
\r
17948 LSH 0,23. ;POSITION FOR A .STATUS
\r
17949 IOR 0,[.STATUS 0]
\r
17951 ANDI 0,77 ;ISOLATE DEVICE
\r
17955 PMIN4: MOVE 0,B ; CHAN TO 0
\r
17956 .ITYIC 0, ; INTO 0
\r
17957 JRST .+2 ; DONE, GO ON
\r
17959 SETZM GCFLCH ; LEAVE GC MODE
\r
17973 MFUNCTION GASCII,SUBR,ASCII
\r
17984 TRYNUM: CAIE A,TFIX
\r
17986 SKIPGE B,1(AB) ;GET NUMBER
\r
17988 CAILE B,177 ;CHECK RANGE
\r
17993 TOOBIG: PUSH TP,$TATOM
\r
17994 PUSH TP,EQUOTE ARGUMENT-OUT-OF-RANGE
\r
17998 ;HERE IF PDL OVERFLOW DURING GARBAGE COLLECTION
\r
18000 BADPDL: FATAL NON PDL OVERFLOW
\r
18002 NOGROW: FATAL PDL OVERFLOW ON NON EXPANDABLE PDL
\r
18004 PDLOSS: FATAL PDL OVEFLOW BUFFER EXHAUSTED
\r
18006 DLOSER: PUSH P,LOSRS(B)
\r
18017 ;MEMORY PROTECTION INTERRUPT
\r
18019 IOC: FATAL IO CHANNEL ERROR IN GARBAGE COLLECTOR
\r
18020 IMPV: FATAL MPV IN GARBAGE COLLECTOR
\r
18022 IPURE: FATAL PURE WRITE IN GARBAGE COLLECTOR
\r
18023 ILOPR: FATAL ILLEGAL OPEREATION IN GARBAGE COLLECTOR
\r
18027 ;SUBROUTINE TO BE CALLED AT INITIALIZE TIME TO SETUP INTS
\r
18029 INTINT: SETZM CHNCNT
\r
18030 MOVE A,[CHNCNT,,CHNCNT+1]
\r
18033 .SUSET [.SPICLR,,[-1]]
\r
18034 MOVE A,MASK1 ;SET MASKS
\r
18036 .SETM2 A, ;SET BOTH MASKS
\r
18038 MOVEM A,QUEUES(TVP)
\r
18039 SETZM QUEUES+1(TVP) ;UNQUEUE ANY OLD INTERRUPTS
\r
18045 ; INITIALIZE TENEX INTERRUPT SYSTEM
\r
18047 INTINT: CIS ; CLEAR THE INT WORLD
\r
18048 SETZM INTFLG ; IN CASE RESTART
\r
18049 MOVSI A,TVEC ; FIXUP QUEUES
\r
18050 MOVEM A,QUEUES(TVP)
\r
18051 SETZM QUEUES+1(TVP)
\r
18052 SETZM CURPRI ; AND PRIORITY LEVEL
\r
18053 MOVEI A,MFORK ; TURN ON MY INTERRUPTS
\r
18054 MOVE B,[LEVTAB,,CHNTAB] ; POINT TO TABLES
\r
18055 SIR ; TELL SYSTEM ABOUT THEM
\r
18056 MOVE B,MASK1 ; SET UP FOR INT BITS
\r
18057 AIC ; TURN THEM ON
\r
18058 MOVSI A,7 ; CNTL G AND CHANNEL 0
\r
18059 ATI ; ACTIVATE IT
\r
18060 MOVE A,[23,,1] ; CNTL S AND CHANNEL 1
\r
18061 ATI ; ACTIVATE IT
\r
18062 MOVEI A,MFORK ; DO THE ENABLE
\r
18070 MFUNCTION QUITTER,SUBR
\r
18081 CAIN B,^S ; HANDLE CNTL-S
\r
18086 PUSHJ P,CLEAN ; CLEAN UP I/O CHANNELS
\r
18088 PUSH TP,EQUOTE CONTROL-G?
\r
18092 RETLIS: MOVEI D,(TB) ; FIND A LISTEN OR ERROR TO RET TO
\r
18094 RETLI1: HRRZ A,OTBSAV(D)
\r
18095 HRRZ C,FSAV(A) ; CHECK FUNCTION
\r
18097 CAIN C,ERROR ; FOUND?
\r
18098 JRST FNDHIM ; YES, GO TO SAME
\r
18099 CAIN C,ERROR% ; FUNNY ERROR
\r
18101 CAIN C,TOPLEV ; NO ERROR/LISTEN
\r
18106 FNDHIM: PUSH TP,$TTB
\r
18109 MOVE B,(TP) ; NEW FRAME
\r
18112 PUSHJ P,CHUNW ; UNWIND?
\r
18117 CLEAN: MOVE B,3(AB) ; GET IN CHAN
\r
18119 MOVE B,3(AB) ; CHANNEL BAKC
\r
18121 SKIPN C,ECHO(C) ; GET ECHO
\r
18125 CAMN C,[PUSHJ P,MTYO]
\r
18127 LDB A,[270400,,C]
\r
18128 TYONUM: LSH A,23.
\r
18133 MOVEI A,101 ; OUTPUT JFN
\r
18137 CLUNQ: SETZB A,CURPRI
\r
18142 ONINT: 0 ; INT FUDGER
\r
18144 ;RANDOM IMPURE CRUFT NEEDED
\r
18145 CHNCNT: BLOCK 16. ; # OF CHARS IN EACH CHANNEL
\r
18149 PIRQ: 0 ;HOLDS REQUEST BITS FOR 1ST WORD
\r
18150 PIRQ2: 0 ;SAME FOR WORD 2
\r
18152 MASK1: 1200,,220540 ;FIRST MASK
\r
18153 MASK2: 0 ;SECOND THEREOF
\r
18154 CURPRI: 0 ; CURRENT PRIORITY
\r
18157 NETJFN: BLOCK NNETS
\r
18160 P1: 0 ; PC INT LEVEL 1
\r
18161 P2: 0 ; PC INT LEVEL 2
\r
18162 P3: 0 ; PC INT LEVEL 3
\r
18172 \fTITLE MAIN LOOP AND GLOBALLY REFERENCED SUBROUTINES
\r
18176 .GLOBAL PATCH,TBINIT,PIDSTO,PROCID,PTIME,GCPDL,PBASE,TYPTOP,RERR,FRMSTK,EMERGE
\r
18177 .GLOBAL PAT,PDLBUF,INTINT,START,SWAP,ICR,SPBASE,TPBASE,TPBAS,SAT,CURPRI,CHFINI
\r
18178 .GLOBAL TOPLEVEL,INTOBL,INITIA,ERROBL,MAINPR,RESFUN,STATUS,TYPVEC,ROOT,TTICHN,TTOCHN
\r
18179 .GLOBAL TTYOPE,MOPEN,MCLOSE,MIOT,ILVAL,MESS,ERROR,CHFRM,IGVAL,TYPBOT,ASOVEC
\r
18180 .GLOBAL PRINT,PRIN1,PRINC,MUDSTR,VECBOT,CSTACK,IFALSE,TYPLOO,RCALL,SWAPIN,CTMPLT
\r
18181 .GLOBAL IDPROC,CHFSWP,ILOC,MAKACT,BNDV,SPECSTORE,BINDID,IGLOC,MTYO,MSGTYP,CAFRE1
\r
18182 .GLOBAL EVATYP,EVTYPE,APLTYP,APTYPE,PRNTYP,PRTYPE,AGC,SGSNAM,NAPT,APLQ,STRTO6
\r
18183 .GLOBAL 6TOCHS,TYPFND,STBL,CHNL0,N.CHNS,CLOSAL,%LOGOUT,%SSNAM,%RSNAM,%KILLM
\r
18184 .GLOBAL MAKINF,%VALRET,COMPERR,IPUT,IGET,TMATCH,INITIZ,IPCINI,%UNAM,%JNAM,%RUNAM,%RJNAM
\r
18185 .GLOBAL NOTTY,PATEND,CFRAME,CARGS,CFUNCT,CITYPE,CTYPEQ,CPTYPE,CTYPEP,CUTYPE,CCHUTY
\r
18186 .GLOBAL RTFALS,PGINT,PURCLN,CTYPEC,CTYPEW,IDVAL1,CALLTY,MESSAG,INITFL,WHOAMI
\r
18187 .GLOBAL %SLEEP,%HANG,%TOPLQ,ONINT,CHUNW,CURFCN,BUFRIN,TD.LNT,TD.GET,TD.PUT,MPOPJ
\r
18188 .GLOBAL PURVEC,PLOAD,SSPECS,OUTRNG
\r
18192 MONITS==1 ; SET TO 1 IF PC DEMON WANTED
\r
18193 .VECT.==1 ; BIT TO INDICATE VECTORS FOR GCHACK
\r
18195 ;MAIN LOOP AND STARTUP
\r
18197 START: MOVEI 0,0 ; SET NO HACKS
\r
18198 MOVEM 0,WHOAMI ; HACK FOR TS FOO linked to TS MUDDLE
\r
18199 MOVE PVP,MAINPR ; MAKE SURE WE START IN THE MAIN PROCESS
\r
18200 JUMPE 0,INITIZ ; MIGHT BE RESTART
\r
18201 MOVE P,PSTO+1(PVP) ; SET UP FOR BOOTSTRAP HACK
\r
18202 MOVE TP,TPSTO+1(PVP)
\r
18203 INITIZ: SKIPN P ; IF NO CURRENT P
\r
18204 MOVE P,PSTO+1(PVP) ; PDL TO GET OFF THE GROUND
\r
18205 SKIPN TP ; SAME FOR TP
\r
18206 MOVE TP,TPSTO+1(PVP) ; GET A TP TO WORK WITH
\r
18207 MOVE TVP,TVPSTO+1(PVP) ; GET A TVP
\r
18208 SETZB R,M ; RESET RSUBR AC'S
\r
18211 PUSHJ P,TTYOPE ;OPEN THE TTY
\r
18213 SKIPE WHOAMI ; SKIP IF THIS IS MUDDLE
\r
18214 JRST .+3 ; ELSE NO MESSAGE
\r
18215 SKIPN NOTTY ; IF NO TTY, IGNORE
\r
18216 PUSHJ P,MSGTYP ;TYPE OUT TO USER
\r
18218 XCT MESSAG ;MAYBE PRINT A MESSAGE
\r
18219 PUSHJ P,INTINT ;INITIALIZE INTERRUPT HANDLER
\r
18221 PUSHJ P,PURCLN ; CLEAN UP PURE SHARED AREA
\r
18222 RESTART: ;RESTART A PROCESS
\r
18224 MOVE B,TBINIT+1(PVP) ;POINT INTO STACK AT START
\r
18225 PUSHJ P,CHUNW ; LEAVE WHILE DOING UNWIND CHECK
\r
18227 MOVEI A,TFALSE ; IN CASE FALLS OFF PROCESS
\r
18238 MFUNCTION LISTEN,SUBR
\r
18241 PUSH P,[0] ;FLAG: DON'T PRINT ERROR MSG
\r
18244 ; USER SUPPLIED ERROR HANDLER, TEMPORARY KLUDGE
\r
18247 ERROR: MOVE B,IMQUOTE ERROR
\r
18248 PUSHJ P,IGVAL ; GET VALUE
\r
18250 CAIN C,TSUBR ; CHECK FOR NO CHANGE
\r
18251 CAIE B,RERR1 ; SKIP IF NOT CHANGED
\r
18253 JRST RERR1 ; GO TO THE DEFAULT
\r
18254 PUSH TP,A ; SAVE VALUE
\r
18256 MOVE C,AB ; SAVE AB
\r
18257 MOVEI D,1 ; AND COUNTER
\r
18258 USER1: PUSH TP,(C) ; PUSH THEM
\r
18260 ADD C,[2,,2] ; BUMP
\r
18263 ACALL D,APPLY ; EVAL USERS ERROR
\r
18267 TPSUBR==TSUBR+400000
\r
18269 MFUNCTION ERROR%,PSUBR,ERROR
\r
18271 RMT [EXPUNGE TPSUBR
\r
18275 PUSH TP,MQUOTE ERROR,ERROR,INTRUP
\r
18276 PUSHJ P,FRMSTK ; PUT ERROR'S FRAME ON STACK
\r
18279 RERR2: JUMPGE C,RERR22
\r
18284 RERR22: ACALL D,EMERGENCY
\r
18289 PUSH P,[-1] ;PRINT ERROR FLAG
\r
18291 ER1: MOVE B,IMQUOTE INCHAN
\r
18292 PUSHJ P,ILVAL ; CHECK INPUT CHANNEL IS SOME KIND OF TTY
\r
18294 CAIE A,TCHAN ; SKIP IF IT IS A CHANNEL
\r
18295 JRST ER2 ; NO, MUST REBIND
\r
18296 CAMN B,TTICHN+1(TVP)
\r
18298 ER2: MOVE B,IMQUOTE INCHAN
\r
18299 MOVEI C,TTICHN(TVP) ; POINT TO VALU
\r
18300 PUSHJ P,PUSH6 ; PUSH THE BINDING
\r
18301 MOVE B,TTICHN+1(TVP) ; GET IN CHAN
\r
18302 NOTINC: SKIPE NOTTY
\r
18308 MCALL 2,TTYECH ; ECHO INPUT
\r
18309 NOECHO: MOVE B,IMQUOTE OUTCHAN
\r
18310 PUSHJ P,ILVAL ; GET THE VALUE
\r
18312 CAIE A,TCHAN ; SKIP IF OK CHANNEL
\r
18313 JRST ER3 ; NOT CHANNEL, MUST REBIND
\r
18314 CAMN B,TTOCHN+1(TVP)
\r
18316 ER3: MOVE B,IMQUOTE OUTCHAN
\r
18317 MOVEI C,TTOCHN(TVP)
\r
18318 PUSHJ P,PUSH6 ; PUSH THE BINDINGS
\r
18319 NOTOUT: MOVE B,IMQUOTE OBLIST
\r
18320 PUSHJ P,ILVAL ; GET THE VALUE OF OBLIST
\r
18321 PUSHJ P,OBCHK ; IS IT A WINNER ?
\r
18322 SKIPA A,$TATOM ; NO, SKIP AND CONTINUE
\r
18323 JRST NOTOBL ; YES, DO NOT DO REBINDING
\r
18324 MOVE B,IMQUOTE OBLIST
\r
18328 JRST MAKOB ; NO GLOBAL OBLIST, MAKE ONE
\r
18329 MOVEI C,(B) ; COPY ADDRESS
\r
18330 MOVE A,(C) ; GET THE GVAL
\r
18332 PUSHJ P,OBCHK ; IS IT A WINNER ?
\r
18333 JRST MAKOB ; NO, GO MAKE A NEW ONE
\r
18334 MOVE B,IMQUOTE OBLIST
\r
18337 NOTOBL: PUSH TP,[TATOM,,-1] ;FOR BINDING
\r
18338 PUSH TP,IMQUOTE LER,[LERR ]INTRUP
\r
18340 HRLI A,TFRAME ; CORRCT TYPE
\r
18345 MOVE A,PVP ; GET PROCESS
\r
18346 ADD A,[PROCID,,PROCID] ; POINT TO ID (ALSO LEVEL)
\r
18349 MOVE A,PROCID(PVP)
\r
18350 ADDI A,1 ; BUMP ERROR LEVEL
\r
18352 PUSH TP,PROCID+1(PVP)
\r
18355 MOVE B,IMQUOTE READ-TABLE
\r
18357 PUSH TP,[TATOM,,-1]
\r
18358 PUSH TP,IMQUOTE READ-TABLE
\r
18359 GETYP C,A ; TO GVAL OF READ-TABLE ON ERROR AND
\r
18360 CAIE C,TVEC ; TOP ERRET'S
\r
18365 PUSH TP,$TUNBOUND
\r
18370 PUSHJ P,SPECBIND ;BIND THE CRETANS
\r
18371 MOVE A,-1(P) ;RESTORE SWITHC
\r
18372 JUMPE A,NOERR ;IF 0, DONT PRINT ERROR MESS
\r
18374 PUSH TP,EQUOTE *ERROR*
\r
18376 MCALL 1,PRINC ;PRINT THE MESSAGE
\r
18377 NOERR: MOVE C,AB ;GET A COPY OF AB
\r
18379 ERRLP: JUMPGE C,LEVPRT ;IF NONE, RE-ENTER READ-EVAL-PRINT LOOP
\r
18383 GETYP A,(C) ; GET ARGS TYPE
\r
18386 MOVE A,1(C) ; GET ATOM
\r
18389 CAMN A,ERROBL+1(TVP) ; DONT SKIP IF IN ERROR OBLIST
\r
18390 MOVEI B,PRINC ; DONT PRINT TRAILER
\r
18391 ERROK: PUSH P,B ; SAVE ROUTINE POINTER
\r
18394 MCALL 0,TERPRI ; CRLF
\r
18395 POP P,B ; GET ROUTINE BACK
\r
18399 ADD C,[2,,2] ;BUMP SAVED AB
\r
18400 JRST ERRLP ;AND CONTINUE
\r
18403 LEVPRT: XCT INITFL ;LOAD MUDDLE INIT FILE IF FIRST TIME
\r
18406 PUSH TP,EQUOTE [LISTENING-AT-LEVEL ]
\r
18407 MCALL 1,PRINC ;PRINT LEVEL
\r
18408 PUSH TP,$TFIX ;READY TO PRINT LEVEL
\r
18409 HRRZ A,(P) ;GET LEVEL
\r
18410 SUB P,[2,,2] ;AND POP STACK
\r
18412 MCALL 1,PRIN1 ;PRINT WITHOUT SPACES ETC.
\r
18413 PUSH TP,$TATOM ;NOW PROCESS
\r
18414 PUSH TP,EQUOTE [ PROCESS ]
\r
18415 MCALL 1,PRINC ;DONT SLASHIFY SPACES
\r
18416 PUSH TP,PROCID(PVP) ;NOW ID
\r
18417 PUSH TP,PROCID+1(PVP)
\r
18424 PUSH TP,EQUOTE [ INT-LEVEL ]
\r
18427 JRST MAINLP ; FALL INTO MAIN LOOP
\r
18429 \f;ROUTINES FOR ERROR-LISTEN
\r
18433 JRST CPOPJ1 ; WIN FOR SINGLE OBLIST
\r
18434 CAIE 0,TLIST ; IF LIST, MAKE SURE EACH IS AN OBLIST
\r
18435 JRST CPOPJ ; ELSE, LOSE
\r
18437 JUMPE B,CPOPJ ; NIL ,LOSE
\r
18440 PUSH P,[0] ;FLAG FOR DEFAULT CHECKING
\r
18441 MOVEI 0,1000 ; VERY BIG NUMBER FOR CIRCULARITY TEST
\r
18444 SOJE 0,OBLOSE ; CIRCULARITY TEST
\r
18445 HRRZ B,(TP) ; GET LIST POINTER
\r
18447 CAIE A,TOBLS ; SKIP IF WINNER
\r
18448 JRST DEFCHK ; CHECK FOR SPECIAL ATOM DEFAULT
\r
18453 OBLOSE: SUB TP,[2,,2]
\r
18457 DEFCHK: SKIPN (P) ; BEEN HERE BEFORE ?
\r
18458 CAIE A,TATOM ; OR, NOT AN ATOM ?
\r
18459 JRST OBLOSE ; YES, LOSE
\r
18461 CAME A,MQUOTE DEFAULT
\r
18462 JRST OBLOSE ; LOSE
\r
18463 SETOM (P) ; SET FLAG
\r
18464 HRRZ B,(B) ; CHECK FOR END OF LIST
\r
18466 JUMPN B,OBCHK0 ; NOT THE END, CONTINUE LOOKING
\r
18467 JRST OBLOSE ; LOSE FOR DEFAULT AT THE END
\r
18471 PUSH6: PUSH TP,[TATOM,,-1]
\r
18480 MAKOB: PUSH TP,INITIAL(TVP)
\r
18481 PUSH TP,INITIAL+1(TVP)
\r
18482 PUSH TP,ROOT(TVP)
\r
18483 PUSH TP,ROOT+1(TVP)
\r
18486 PUSH TP,IMQUOTE OBLIST
\r
18490 PUSH TP,[TATOM,,-1]
\r
18491 PUSH TP,IMQUOTE OBLIST
\r
18499 ;THIS IS IT FOLKS...THE MAIN LOOP. READ, EVAL, PRINT
\r
18501 MAINLP: MOVE A,$TATOM ;KLUDGE BY NDR LIKE ERROR TO LET LOOSER REDEFINE
\r
18502 MOVE B,MQUOTE REP
\r
18503 PUSHJ P,ILVAL ;GET ITS LVAL TO SEE IF REDEFINED
\r
18507 MOVE A,$TATOM ;SEE IF IT HAS GVAL SINCE NO LVAL
\r
18508 MOVE B,MQUOTE REP
\r
18513 REPCHK: CAIN C,TSUBR
\r
18517 REREPE: PUSH TP,A
\r
18522 MCALL 1,APPLY ;LOOSER HAS REDEFINED SO CALL HIS
\r
18524 IREPER: PUSH P,[0] ;INDICATE FALL THROUGH
\r
18527 ERRREP: PUSH TP,[TATOM,,-1]
\r
18528 PUSH TP,MQUOTE REP
\r
18535 PUSH TP,EQUOTE NON-APPLICABLE-REP
\r
18544 MFUNCTION REPER,SUBR,REP
\r
18546 PUSH P,[1] ;INDICATE DIRECT CALL
\r
18547 REPERF: MCALL 0,TERPRI
\r
18554 PUSH TP,IMQUOTE LAST-OUT
\r
18561 POP P,C ;FLAG FOR FALL THROUGH OR CALL
\r
18562 JUMPN C,FINIS ;IN CASE LOOSER CALLED REP
\r
18566 ;FUNCTION TO RETRY A PREVIOUS FUNCTION CALL
\r
18568 MFUNCTION RETRY,SUBR
\r
18571 JUMPGE AB,RETRY1 ; USE MOST RECENT
\r
18574 GETYP A,(AB) ; CHECK TYPE
\r
18577 MOVEI B,(AB) ; POINT TO ARG
\r
18579 RETRY1: MOVE B,IMQUOTE LER,[LERR ]INTRUP
\r
18580 PUSHJ P,ILOC ; LOCATIVE TO FRAME
\r
18581 RETRY2: PUSHJ P,CHFSWP ; CHECK VALIDITY AND SWAP IF NECESSARY
\r
18582 HRRZ 0,OTBSAV(B) ; CHECK FOR TOP
\r
18583 JUMPE 0,RESTAR ; YES RE-ENTER TOP LEVEL
\r
18585 PUSH TP,B ; SAVE FRAME
\r
18586 MOVE B,OTBSAV(B) ; GET PRVIOUS FOR UNBIND HACK
\r
18588 PUSHJ P,CHUNW ; CHECK ANY UNWINDING
\r
18589 CAME SP,SPSAV(TB) ; UNBINDING NEEDED?
\r
18590 PUSHJ P,SPECSTORE
\r
18591 MOVE P,PSAV(TB) ; GET OTHER STUFF
\r
18593 HLRE A,AB ; COMPUTE # OF ARGS
\r
18594 MOVNI A,-FRAMLN(A) ; MAKE TP POINT PAST FRAME
\r
18596 MOVE C,TPSAV(TB) ; COMPUTE TP
\r
18599 MOVE TB,B ; FIX UP TB
\r
18600 HRRZ C,FSAV(TB) ; GET FUNCTION
\r
18601 CAMGE C,VECTOP ; CHECK FOR RSUBR
\r
18604 GETYP 0,(C) ; RSUBR OR ENTRY?
\r
18608 MOVS R,(C) ; SET UP R
\r
18613 RETRNT: CAIE 0,TRSUBR
\r
18616 RETRN4: HRRZ C,2(C) ; OFFSET
\r
18617 RETRN3: SKIPL M,1(R)
\r
18619 RETRN7: ADDI C,(M)
\r
18622 RETRN5: MOVEI D,(M) ; TOTAL OFFSET
\r
18624 ADD M,PURVEC+1(TVP)
\r
18629 RETRN6: HLRZ A,1(R)
\r
18633 JRST RETRER ; LOSER
\r
18639 RETRN1: MOVE B,1(C)
\r
18651 RETRN2: PUSH TP,$TATOM
\r
18652 PUSH TP,EQUOTE CANT-RETRY-ENTRY-GONE
\r
18655 RETRER: PUSH TP,$TATOM
\r
18656 PUSH TP,EQUOTE PURE-LOAD-FAILURE
\r
18660 ;FUNCTION TO DO ERROR RETURN
\r
18662 MFUNCTION ERRET,SUBR
\r
18665 HLRE A,AB ; -2*# OF ARGS
\r
18666 JUMPGE A,STP ; RESTART PROCESS
\r
18667 ASH A,-1 ; -# OF ARGS
\r
18668 AOJE A,ERRET2 ; NO FRAME SUPPLIED
\r
18674 PUSHJ P,CHPROC ; POINT TO FRAME SLOT
\r
18676 ERRET2: MOVE B,IMQUOTE LER,[LERR ]INTRUP
\r
18677 PUSHJ P,ILVAL ; GET ITS VALUE
\r
18678 ERRET3: PUSH TP,A
\r
18681 PUSHJ P,CHFSWP ; CHECK VALIDITY AND SWAP IF NECESSARY
\r
18682 HRRZ 0,OTBSAV(B) ; TOP LEVEL?
\r
18684 PUSHJ P,CHUNW ; ANY UNWINDING
\r
18688 ; FUNCTION TO RETURN LAST ERROR FRAME OR PREVIOUS FRAME
\r
18690 MFUNCTION FRAME,SUBR
\r
18693 JUMPGE AB,FRM1 ; DEFAULT CASE
\r
18694 CAMG AB,[-3,,0] ; SKIP IF OK ARGS
\r
18696 PUSHJ P,OKFRT ; A FRAME OR SIMILAR THING?
\r
18699 FRM1: PUSHJ P,CFRAME ; GO TO INTERNAL
\r
18702 CFRAME: JUMPN A,FRM2 ; ARG SUPPLIED?
\r
18703 MOVE B,IMQUOTE LER,[LERR ]INTRUP
\r
18706 FRM2: PUSHJ P,CHPROC ; CHECK FOR PROCESS
\r
18709 MOVEI B,-1(TP) ; POINT TO SLOT
\r
18710 PUSHJ P,CHFRM ; CHECK IT
\r
18711 MOVE C,(TP) ; GET FRAME BACK
\r
18712 MOVE B,OTBSAV(C) ;GET PREVIOUS FRAME
\r
18714 TRNN B,-1 ; SKIP IF OK
\r
18717 FRM3: JUMPN B,FRM4 ; JUMP IF WINNER
\r
18718 MOVE B,IMQUOTE THIS-PROCESS
\r
18719 PUSHJ P,ILVAL ; GET PROCESS OF INTEREST
\r
18720 GETYP A,A ; CHECK IT
\r
18722 MOVE B,PVP ; USE CURRENT
\r
18723 MOVEI A,PVLNT*2+1(B) ; POINT TO DOPE WORDS
\r
18724 MOVE B,TBINIT+1(B) ; AND BASE FRAME
\r
18725 FRM4: HLL B,OTBSAV(B) ;TIME
\r
18729 OKFRT: AOS (P) ;ASSUME WINNAGE
\r
18742 CHPROC: GETYP 0,A ; TYPE
\r
18745 MOVEI A,PVLNT*2+1(B)
\r
18746 CAMN B,PVP ; THIS PROCESS?
\r
18748 MOVE B,TBSTO+1(B)
\r
18751 CHPRO1: MOVE B,OTBSAV(TB)
\r
18754 ; FUNCTION TO RETURN ARGS TUPLE FOR A FRAME
\r
18756 MFUNCTION ARGS,SUBR
\r
18758 PUSHJ P,OKFRT ; CHECK FRAME TYPE
\r
18763 CARGS: PUSHJ P,CHPROC
\r
18766 MOVEI B,-1(TP) ; POINT TO FRAME SLOT
\r
18767 PUSHJ P,CHFRM ; AND CHECK FOR VALIDITY
\r
18768 MOVE C,(TP) ; FRAME BACK
\r
18770 CARGS1: GETYP 0,FSAV(C) ; IS THIS A FUNNY ONE
\r
18771 CAIE 0,TCBLK ; SKIP IF FUNNY
\r
18772 JRST .+3 ; NO NORMAL
\r
18773 MOVE C,OTBSAV(C) ; ASSOCIATE WITH PREVIOUS FRAME
\r
18775 HLR A,OTBSAV(C) ; TIME IT AND
\r
18776 MOVE B,ABSAV(C) ; GET POINTER
\r
18777 SUB TP,[2,,2] ; FLUSH CRAP
\r
18780 ; FUNCTION TO RETURN FUNCTION ASSOCIATED WITH A FRAME
\r
18782 MFUNCTION FUNCT,SUBR ;RETURNS FUNCTION NAME OF
\r
18783 ENTRY 1 ; FRAME ARGUMENT
\r
18784 PUSHJ P,OKFRT ; CHECK TYPE
\r
18789 CFUNCT: PUSHJ P,CHPROC
\r
18793 PUSHJ P,CHFRM ; CHECK IT
\r
18794 MOVE C,(TP) ; RESTORE FRAME
\r
18795 HRRZ A,FSAV(C) ;FUNCTION POINTER
\r
18796 CAMG A,VECTOP ;IS THIS AN RSUBR ?
\r
18798 SKIPA B,@-1(A) ;NO, GET SUBR'S NAME POINTER
\r
18799 MOVE B,(A)+3 ;YES, GET RSUBR'S NAME ENTRY
\r
18806 PUSH TP,EQUOTE FRAME-NO-LONGER-EXISTS
\r
18812 PUSH TP,EQUOTE TOP-LEVEL-FRAME
\r
18818 ; ROUTINE TO HANG INDEFINITELY WITH INTERRUPTS ENABLED
\r
18820 MFUNCTION HANG,SUBR
\r
18824 JUMPGE AB,HANG1 ; NO PREDICATE
\r
18827 REHANG: MOVE A,[PUSHJ P,CHKPRH]
\r
18828 MOVEM A,ONINT ; CHECK PREDICATE AFTER ANY INTERRUPT
\r
18831 HANG1: ENABLE ;LET OURSELVES BE INTERRUPTED OUT
\r
18833 DISABLE ;PREVENT INTERRUPTS AT RANDOM TIMES
\r
18840 ; ROUTINE TO SLEEP FOR POSITIVE NUMBER OF SECONDS WITH INTERRUPTS ENABLED
\r
18841 ; ARGUMENT SHOULD BE OF TYPE FIX OR FLOAT AND NON-NEGATIVE
\r
18843 MFUNCTION SLEEP,SUBR
\r
18854 SLEEP1: GETYP 0,(AB)
\r
18858 JUMPL B,OUTRNG ;ARG SHOULDNT BE NEGATIVE
\r
18859 IMULI B,30. ;CONVERT TO # OF THIRTIETHS OF A SECOND
\r
18860 JRST SLEEPR ;GO SLEEP
\r
18861 CAIE 0,TFLOAT ;IF IT WASNT FIX MAKE SURE IT IS FLOAT
\r
18862 JRST WTYP1 ;WRONG TYPE ARG
\r
18864 FMPR B,[30.0] ;CONVERT TO FLOATING # OF THIRTIETHS OF A SECOND
\r
18865 MULI B,400 ;KLUDGE TO FIX IT
\r
18868 MOVE B,C ;MOVE THE FIXED NUMBER INTO B
\r
18869 JUMPL B,OUTRNG ;CHECK TO SEE THAT WE HAVE POSITIVE NUMBER
\r
18871 RESLEE: MOVE B,[PUSHJ P,CHKPRS]
\r
18889 SETZM ONINT ; TURN OFF FEATURE FOR NOW
\r
18893 HANGP: SKIPA B,[REHANG]
\r
18894 SLEEPP: MOVEI B,RESLEE
\r
18907 MFUNCTION VALRET,SUBR
\r
18908 ; SUBR TO VALRET A STRING TO SUPERIOR ITS PROCESS
\r
18911 GETYP A,(AB) ; GET TYPE OF ARGUMENT
\r
18912 CAIE A,TCHSTR ; IS IT A CHR STRING?
\r
18913 JRST WTYP1 ; NO...ERROR WRONG TYPE
\r
18914 PUSHJ P,CSTACK ; COPY THE CHR STRING TO THE STACK
\r
18915 ; CSTACK IS IN ATOMHK
\r
18916 MOVEI B,0 ; ASCIZ TERMINATOR
\r
18917 EXCH B,(P) ; STORE AND RETRIEVE COUNT
\r
18919 ; CALCULATE THE BEGINNING ADDR OF THE STRING
\r
18920 MOVEI A,-1(P) ; GET ADDR OF TOP OF STACK
\r
18921 SUBI A,-1(B) ; GET STARTING ADDR
\r
18922 PUSHJ P,%VALRE ; PASS UP TO MONITOR
\r
18923 JRST IFALSE ; IF HE RETURNS, RETURN FALSE
\r
18926 MFUNCTION LOGOUT,SUBR
\r
18928 ; SUBR TO DO A .LOGOUT (VALID ONLY AT TOP LEVEL)
\r
18930 PUSHJ P,%TOPLQ ; SKIP IF AT TOP LEVEL
\r
18933 PUSHJ P,%LOGOUT ; TRY TO FLUSH
\r
18934 JRST IFALSE ; COULDN'T DO IT...RETURN FALSE
\r
18936 ; FUNCTS TO GET UNAME AND JNAME
\r
18938 MFUNCTION UNAME,SUBR
\r
18945 MFUNCTION JNAME,SUBR
\r
18952 ; FUNCTION TO SET AND READ GLOBAL SNAME
\r
18954 MFUNCTION SNAME,SUBR
\r
18961 GETYP A,(AB) ; ARG MUST BE STRING
\r
18965 PUSH TP,IMQUOTE SNM
\r
18971 SNAME1: MOVE B,IMQUOTE SNM
\r
18980 RSUJNM: PUSHJ P,6TOCHS ; CONVERT IT
\r
18984 SGSNAM: MOVE B,IMQUOTE SNM
\r
18998 PUSHJ P,%SSNAM ; SET SNAME IN SYSTEM
\r
19003 ;THIS SUBROUTINE ALLOCATES A NEW PROCESS TAKES NO ARGS AND
\r
19004 ;IS CALLED BY PUSHJ P,. RETURNS IN A AND B A NEW PROCESS.
\r
19006 ICR: MOVEI A,PVLNT ;SETUP CALL TO VECTOR FOR PVP
\r
19007 PUSHJ P,IVECT ;GOBBLE A VECTOR
\r
19008 HRLI C,PVBASE ;SETUP A BLT POINTER
\r
19009 HRRI C,(B) ;GET INTO ADDRESS
\r
19010 BLT C,PVLNT*2-1(B) ;COPY A PROTOTYPE INTO NEW PVP
\r
19011 MOVSI C,400000+SPVP+.VECT. ;SET SPECIAL TYPE
\r
19012 MOVEM C,PVLNT*2(B) ;CLOBBER IT IN
\r
19013 PUSH TP,A ;SAVE THE RESULTS OF VECTOR
\r
19016 PUSH TP,$TFIX ;GET A UNIFORM VECTOR
\r
19019 ADD B,[PDLBUF-2,,-1] ;FUDGE WITH BUFFER
\r
19020 MOVE C,(TP) ;REGOBBLE PROCESS POINTER
\r
19021 MOVEM B,PSTO+1(C) ;STORE IN ALL HOMES
\r
19022 MOVEM B,PBASE+1(C)
\r
19025 MOVEI A,TPLNT ;PREPARE TO CREATE A TEMPORARY PDL
\r
19026 PUSHJ P,IVECT ;GET THE TEMP PDL
\r
19027 ADD B,[PDLBUF,,0] ;PDL GROWTH HACK
\r
19028 MOVE C,(TP) ;RE-GOBBLE NEW PVP
\r
19029 SUB B,[1,,1] ;FIX FOR STACK
\r
19030 MOVEM B,TPBASE+1(C)
\r
19032 ;SETUP INITIAL BINDING
\r
19035 MOVEM B,SPBASE+1(C) ;SAVE AS BASE OF SP
\r
19036 MOVEM B,SPSTO+1(C) ;AND CURRENT THEREOF
\r
19037 MOVEM B,CURFCN+1(C) ; AND AS CURRENT FCN FOR SPEC/UNSPEC LOGIC
\r
19038 PUSH B,IMQUOTE THIS-PROCESS
\r
19039 PUSH B,$TPVP ;GIVE IT PROCESS AS VALUE
\r
19041 ADD B,[2,,2] ;FINISH FRAME
\r
19042 MOVEM B,TPSTO+1(C) ;MAKE THIS THE CURRENT STACK POINTER
\r
19043 MOVEM C,PVPSTO+1(C) ;SAVE THE NEW PVP ITSELF
\r
19044 MOVEM TVP,TVPSTO+1(C) ;AND THE GOOD OLD TRANSFER VECTOR
\r
19045 AOS A,IDPROC ;GOBBLE A UNIQUE PROCESS I.D.
\r
19046 MOVEM A,PROCID+1(C) ;SAVE THAT ALSO
\r
19047 AOS A,PTIME ; GET A UNIQUE BINDING ID
\r
19048 MOVEM A,BINDID+1(C)
\r
19050 MOVSI A,TPVP ;CLOBBER THE TYPE
\r
19051 MOVE B,(TP) ;AND POINTER TO PROCESS
\r
19055 ;MINI ROUTINE TO CALL VECTOR WITH COUNT IN A
\r
19057 IVECT: PUSH TP,$TFIX
\r
19059 MCALL 1,VECTOR ;GOBBLE THE VECTOR
\r
19063 ;SUBROUTINE TO SWAP A PROCESS IN
\r
19064 ;CALLED WITH JSP A,SWAP AND NEW PVP IN B
\r
19066 SWAP: ;FIRST STORE ALL THE ACS
\r
19068 IRP A,,[PVP,TVP,AB,TB,TP,SP,P,M,R]
\r
19069 MOVEM A,A!STO+1(PVP)
\r
19072 SETOM 1(TP) ; FENCE POST MAIN STACK
\r
19073 MOVEM TP,TPSAV(TB) ; CORRECT FRAME
\r
19074 SETZM PSAV(TB) ; CLEAN UP CURRENT FRAME
\r
19078 MOVE E,PVP ;RETURN OLD PROCESS IN E
\r
19079 MOVE PVP,D ;AND MAKE NEW ONE BE D
\r
19082 ;NOW RESTORE NEW PROCESSES AC'S
\r
19084 IRP A,,[PVP,TVP,AB,TB,TP,SP,P,M,R]
\r
19085 MOVE A,A!STO+1(PVP)
\r
19088 JRST (C) ;AND RETURN
\r
19093 ;SUBRS ASSOCIATED WITH TYPES
\r
19095 ;INTERNAL FUNCTION TO GET STRAGE ALLOCATION TYPE
\r
19096 ;GETS THE TYPE CODE IN A AND RETURNS SAT IN A.
\r
19098 SAT: LSH A,1 ;TIMES 2 TO REF VECTOR
\r
19099 HRLS A ;TO BOTH HALVES TO HACK AOBJN POINTER
\r
19100 ADD A,TYPVEC+1(TVP) ;ACCESS THE VECTOR
\r
19101 HRR A,(A) ;GET PROBABLE SAT
\r
19102 JUMPL A,.+2 ;DID WE REALLY HAVE A VALID TYPE
\r
19103 MOVEI A,0 ;NO RETURN 0
\r
19105 POPJ P, ;AND RETURN
\r
19107 ;TYPE (ITYPE) ARE FUNCTIONS TO RETURN THE ATOMIC NAME OF THE
\r
19108 ;TYPE OF A GOODIE. TYPE TAKES ITS ARGS ON AP AND RETURNS IN A AND B.
\r
19109 ;ITYPE TAKES ITS ARGS IN A AND B AND RETURNS IN SAME (B=0) FOR INVALID
\r
19111 MFUNCTION TYPE,SUBR
\r
19114 GETYP A,(AB) ;TYPE INTO A
\r
19115 TYPE1: PUSHJ P,ITYPE ;GO TO INTERNAL
\r
19116 JUMPN B,FINIS ;GOOD RETURN
\r
19117 TYPERR: PUSH TP,$TATOM ;SETUP ERROR CALL
\r
19118 PUSH TP,EQUOTE TYPE-UNDEFINED
\r
19119 JRST CALER1" ;STANDARD ERROR HACKER
\r
19121 CITYPE: GETYP A,A ; GET TYPE FOR COMPILER CALL
\r
19122 ITYPE: LSH A,1 ;TIMES 2
\r
19123 HRLS A ;TO BOTH SIDES
\r
19124 ADD A,TYPVEC+1(TVP) ;GET ACTUAL LOCATION
\r
19125 JUMPGE A,TYPERR ;LOST, TYPE OUT OF BOUNDS
\r
19126 MOVE B,1(A) ;PICKUP TYPE
\r
19130 ; PREDICATE -- IS OBJECT OF TYPE SPECIFIED
\r
19132 MFUNCTION %TYPEQ,SUBR,[TYPE?]
\r
19136 MOVE D,AB ; GET ARGS
\r
19143 PUSHJ P,ITYPQ ; GO INTERNAL
\r
19147 ITYPQ: GETYP A,A ; OBJECT
\r
19149 TYPEQ0: SOJL C,CIFALS
\r
19151 CAIE 0,TATOM ; Type name must be an atom
\r
19153 CAMN B,1(D) ; Same as the OBJECT?
\r
19154 JRST CPOPJ1 ; Yes, return type name
\r
19156 JRST TYPEQ0 ; No, continue comparing
\r
19158 CIFALS: MOVEI B,0
\r
19162 CTYPEQ: SOJE A,CIFALS ; TREAT NO ARGS AS FALSE
\r
19163 MOVEI D,1(A) ; FIND BASE OF ARGS
\r
19166 SUBM TP,D ; D POINTS TO BASE
\r
19167 MOVE E,D ; SAVE FOR TP RESTORE
\r
19168 ADD D,[3,,3] ; FUDGE
\r
19169 MOVEI C,(A) ; NUMBER OF TYPES
\r
19172 JFCL ; IGNORE SKIP FOR NOW
\r
19173 MOVE TP,E ; SET TP BACK
\r
19174 JUMPL B,CPOPJ1 ; SKIP
\r
19177 ; Entries to get type codes for types for fixing up RSUBRs and assembling
\r
19179 MFUNCTION %TYPEC,SUBR,[TYPE-C]
\r
19188 CAMGE AB,[-3,,0] ; skip if only type name given
\r
19190 MOVE C,MQUOTE ANY
\r
19192 TYPEC1: PUSHJ P,CTYPEC ; go to internal
\r
19195 GTPTYP: CAMGE AB,[-5,,0]
\r
19203 CTYPEC: PUSH P,C ; save primtype checker
\r
19204 PUSHJ P,TYPLOO ; search type vector
\r
19206 CAMN B,MQUOTE ANY
\r
19219 CTPEC1: MOVEI B,(D)
\r
19223 MFUNCTION %TYPEW,SUBR,[TYPE-W]
\r
19232 MOVE C,MQUOTE ANY
\r
19237 CTYPW3: PUSHJ P,CTYPEW
\r
19240 CTYPW1: GETYP 0,2(AB)
\r
19243 CAMGE AB,[-5,,0] ; JUMP IF RH IS GIVEN
\r
19248 CTYPW2: CAMGE AB,[-7,,0]
\r
19257 PUSHJ P,CTYPEC ; GET CODE IN B
\r
19263 ;PRIMTTYPE RETURNS THE TYPE ATOM OF A PRIMITIVE TYPE IN A CLASS
\r
19265 STBL: REPEAT NUMSAT,MQUOTE INTERNAL-TYPE
\r
19269 IRP A,,[[1WORD,WORD],[2WORD,LIST],[NWORD,UVECTOR],[2NWORD,VECTOR],[STORE,STORAGE]
\r
19270 [ARGS,TUPLE],[FRAME,FRAME],[ATOM,ATOM],[LOCID,LOCD],[CHSTR,STRING]
\r
19271 [PVP,PROCESS],[ASOC,ASOC],[LOCA,LOCA],[LOCS,LOCS],[LOCU,LOCU],[LOCV,LOCV]
\r
19272 [LOCL,LOCL],[LOCN,LOCAS],[LOCT,LOCT]]
\r
19282 LOC STBL+NUMSAT+1
\r
19285 MFUNCTION TYPEPRIM,SUBR
\r
19295 CTYPEP: PUSHJ P,TYPLOO ; CONVERT ATOM TO CODE
\r
19296 HRRZ A,(A) ; SAT TO A
\r
19300 MFUNCTION PRIMTYPE,SUBR
\r
19304 MOVE A,(AB) ;GET TYPE
\r
19308 CPTYPE: GETYP A,A
\r
19309 PUSHJ P,SAT ;GET SAT
\r
19310 PTYP1: JUMPE A,TYPERR
\r
19311 MOVE B,MQUOTE TEMPLATE
\r
19312 CAIG A,NUMSAT ; IF BIG SAT, THEN TEMPLATE
\r
19318 ; RSUBR MAKES A VECTOR INTO AN OBJECT OF TYPE RSUBR, ALSO SLIGHTLY MUNGING IT
\r
19320 MFUNCTION RSUBR,SUBR
\r
19324 CAIE A,TVEC ; MUST BE VECTOR
\r
19326 MOVE B,1(AB) ; GET IT
\r
19327 GETYP A,(B) ; CHECK 1ST ELEMENTS TYPE
\r
19328 CAIN A,TPCODE ; PURE CODE
\r
19332 HLRM B,(B) ; CLOBEER SPECIAL COUNT FIELD
\r
19336 NRSUBR: PUSH TP,$TATOM
\r
19337 PUSH TP,EQUOTE FIRST-ELEMENT-OF-VECTOR-NOT-CODE
\r
19340 ; ROUTINE TO GENERATE ENTRYY OTHER THAN FIRST TO RSUBRR
\r
19342 MFUNCTION MENTRY,SUBR,[RSUBR-ENTRY]
\r
19346 GETYP 0,(AB) ; TYPE OF ARG
\r
19347 CAIE 0,TVEC ; BETTER BE VECTOR
\r
19352 MOVE B,1(AB) ; GET VECTOR
\r
19355 GETYP 0,(B) ; FIRST ELEMENT
\r
19358 MENTR2: GETYP 0,2(B)
\r
19362 HRRM C,2(B) ; OFFSET INTO VECTOR
\r
19367 MENTR1: CAIE 0,TATOM
\r
19369 MOVE B,1(B) ; GET ATOM
\r
19370 PUSHJ P,IGVAL ; GET VAL
\r
19374 MOVE B,1(AB) ; RESTORE B
\r
19377 BENTRY: PUSH TP,$TATOM
\r
19378 PUSH TP,EQUOTE BAD-VECTOR
\r
19381 ; SUBR TO GET ENTRIES OFFSET
\r
19383 MFUNCTION LENTRY,SUBR,[ENTRY-LOC]
\r
19397 RTFALS: MOVSI A,TFALSE
\r
19401 ;SUBROUTINE CALL FOR RSUBRs
\r
19402 RCALL: SUBM M,(P) ;CALCULATE PC's OFFSET IN THE RSUBR
\r
19403 PUSHJ P,@0 ;GO TO THE PROPER SUBROUTINE
\r
19404 SUBM M,(P) ;RECONSTITUTE THE RSUBR's PC
\r
19408 ; ERRORS IN COMPILED CODE MAY END UP HERE
\r
19412 PUSH TP,EQUOTE ERROR-IN-COMPILED-CODE
\r
19416 ;CHTYPE TAKES TWO ARGUMENTS. ANY GOODIE AND A AN ATOMIC TYPE NAME
\r
19417 ;IT CHECKS THE STORAGE ALLOCATION TYPES OF THE TWO ARE THE SAME AND
\r
19418 ;IF THEY ARE CHANGES THE TYPE OF THE FIRST TO THAT NAME D IN THE SECOND
\r
19420 MFUNCTION CHTYPE,SUBR
\r
19423 GETYP A,2(AB) ;FIRST CHECK THAT ARG 2 IS AN ATOM
\r
19426 MOVE B,3(AB) ;AND TYPE NAME
\r
19427 PUSHJ P,TYPLOO ;GO LOOKUP TYPE
\r
19428 TFOUND: HRRZ B,(A) ;GOBBLE THE SAT
\r
19429 TRNE B,CHBIT ; SKIP IF CHTYPABLE
\r
19431 TRNE B,TMPLBT ; TEMPLAT
\r
19433 AND B,[-1,,SATMSK]
\r
19434 GETYP A,(AB) ;NOW GET TYPE TO HACK
\r
19435 PUSHJ P,SAT ;FIND OUT ITS SAT
\r
19436 JUMPE A,TYPERR ;COMPLAIN
\r
19438 JRST CHTMPL ; JUMP IF TEMPLATE DATA
\r
19439 CAIE A,(B) ;DO THEY AGREE?
\r
19440 JRST TYPDIF ;NO, COMPLAIN
\r
19441 CHTMP1: MOVSI A,(D) ;GET NEW TYPE
\r
19442 HRR A,(AB) ; FOR DEFERRED GOODIES
\r
19443 JUMPL B,CHMATC ; CHECK IT
\r
19444 MOVE B,1(AB) ;AND VALUE
\r
19447 CHTMPL: MOVE E,1(AB) ; GET ARG
\r
19450 MOVE 0,3(AB) ; SEE IF TO "TEMPLATE"
\r
19451 CAME 0,MQUOTE TEMPLATE
\r
19456 CHMATC: PUSH TP,A
\r
19457 PUSH TP,1(AB) ; SAVE GOODIE
\r
19461 MOVE D,MQUOTE DECL
\r
19462 PUSHJ P,IGET ; FIND THE DECL
\r
19464 MOVE D,1(AB) ; NOW GGO TO MATCH
\r
19471 TYPLOO: PUSHJ P,TYPFND
\r
19474 PUSH TP,$TATOM ;LOST, GENERATE ERROR
\r
19475 PUSH TP,EQUOTE BAD-TYPE-NAME
\r
19478 TYPFND: MOVE A,TYPVEC+1(TVP) ;GOBBLE DOWN TYPE VECTOR
\r
19479 MOVEI D,0 ;INITIALIZE TYPE COUNTER
\r
19480 TLOOK: CAMN B,1(A) ;CHECK THIS ONE
\r
19482 ADDI D,1 ;BUMP COUNTER
\r
19483 AOBJP A,.+2 ;COUTN DOWN ON VECTOR
\r
19489 TYPDIF: PUSH TP,$TATOM ;MAKE ERROR MESSAGE
\r
19490 PUSH TP,EQUOTE STORAGE-TYPES-DIFFER
\r
19494 TMPLVI: PUSH TP,$TATOM
\r
19495 PUSH TP,EQUOTE DECL-VIOLATION
\r
19499 ; FUNCTION TO ADD A NEW TYPE TO THE WORLD WITH GIVEN PRIMITIVE TYPE
\r
19501 MFUNCTION NEWTYPE,SUBR
\r
19505 HLRZ 0,AB ; CHEC # OF ARGS
\r
19506 CAILE 0,-4 ; AT LEAST 2
\r
19509 JRST TMA ; NOT MORE THAN 3
\r
19510 GETYP A,(AB) ; GET 1ST ARGS TYPE (SHOULD BE ATOM)
\r
19511 GETYP C,2(AB) ; SAME WITH SECOND
\r
19512 CAIN A,TATOM ; CHECK
\r
19516 MOVE B,3(AB) ; GET PRIM TYPE NAME
\r
19517 PUSHJ P,TYPLOO ; LOOK IT UP
\r
19518 HRRZ A,(A) ; GOBBLE SAT
\r
19519 HRLI A,TATOM ; MAKE NEW TYPE
\r
19520 PUSH P,A ; AND SAVE
\r
19521 MOVE B,1(AB) ; SEE IF PREV EXISTED
\r
19523 JRST NEWTOK ; DID NOT EXIST BEFORE
\r
19524 MOVEI B,2(A) ; FOR POSSIBLE TMPLAT BIT
\r
19525 HRRZ A,(A) ; GET SAT
\r
19526 HRRZ 0,(P) ; AND PROPOSED
\r
19529 CAIN 0,(A) ; SKIP IF LOSER
\r
19530 JRST NEWTFN ; O.K.
\r
19533 PUSH TP,EQUOTE TYPE-ALREADY-EXISTS
\r
19537 MOVE B,1(AB) ; NEWTYPE NAME
\r
19538 PUSHJ P,INSNT ; MUNG IN NEW TYPE
\r
19540 NEWTFN: CAML AB,[-5,,] ; SKIP IF TEMPLAT SUPPLIED
\r
19542 MOVEI 0,TMPLBT ; GET THE BIT
\r
19543 IORM 0,-2(B) ; INTO WORD
\r
19544 MOVE A,(AB) ; GET TYPE NAME
\r
19547 MOVE D,MQUOTE DECL
\r
19548 PUSH TP,4(AB) ; GET TEMLAT
\r
19551 NEWTF1: MOVE A,(AB)
\r
19552 MOVE B,1(AB) ; RETURN NAME
\r
19555 ; SET UP GROWTH FIELDS
\r
19557 IGROWT: SKIPA A,[111100,,(C)]
\r
19558 IGROWB: MOVE A,[001100,,(C)]
\r
19560 SUB C,B ; POINT TO DOPE WORD
\r
19561 MOVE B,TYPIC ; INDICATED GROW BLOCK
\r
19566 PUSH TP,B ; SAVE NAME OF NEWTYPE
\r
19567 MOVE C,TYPBOT+1(TVP) ; CHECK GROWTH NEED
\r
19568 CAMGE C,TYPVEC+1(TVP)
\r
19569 JRST ADDIT ; STILL ROOM
\r
19570 GAGN: PUSHJ P,IGROWB ; SETUP BOTTOM GROWTH
\r
19571 SKIPE C,EVATYP+1(TVP)
\r
19572 PUSHJ P,IGROWT ; SET UP TOP GROWTH
\r
19573 SKIPE C,APLTYP+1(TVP)
\r
19575 MOVE C,[11.,,5] ; SET UP INDICATOR FOR AGC
\r
19576 PUSHJ P,AGC ; GROW THE WORLD
\r
19577 AOJL A,GAGN ; BAD AGC LOSSAGE
\r
19578 MOVE 0,[-101,,-100]
\r
19579 ADDM 0,TYPBOT+1(TVP) ; FIX UP POINTER
\r
19581 ADDIT: MOVE C,TYPVEC+1(TVP)
\r
19582 SUB C,[2,,2] ; ALLOCATE ROOM
\r
19583 MOVEM C,TYPVEC+1(TVP)
\r
19584 HLRE B,C ; PREPARE TO BLT
\r
19585 SUBM C,B ; C POINTS DOPE WORD END
\r
19586 HRLI C,2(C) ; GET BLT AC READY
\r
19588 POP TP,-1(B) ; CLOBBER IT IN
\r
19593 ; Interface to interpreter for setting up tables associated with
\r
19594 ; template data structures.
\r
19595 ; A/ <
\b-name of type>
\b-
\r
19596 ; B/ <
\b-length ins>
\b-
\r
19597 ; C/ <
\b-uvector of length code or 0>
\r
19598 ; D/ <
\b-uvector of GETTERs>
\b-
\r
19599 ; E/ <
\b-uvector of PUTTERs>
\b-
\r
19601 CTMPLT: SUBM M,(P) ; could possibly gc during this stuff
\r
19602 SKIPE C ; for now dont handle vector of length ins
\r
19603 FATAL TEMPLATE DATA WITH COMPUTED LENGTH
\r
19604 PUSH TP,$TATOM ; save name of type
\r
19606 PUSH P,B ; save length instr
\r
19607 HLRE A,TD.LNT+1(TVP) ; check for template slots left?
\r
19608 HRRZ B,TD.LNT+1(TVP)
\r
19609 SUB B,A ; point to dope words
\r
19610 HLRZ B,1(B) ; get real length
\r
19611 ADDM B,A ; any room?
\r
19612 JUMPG A,GOODRM ; jump if ok
\r
19614 PUSH TP,$TUVEC ; save getters and putters
\r
19618 MOVEI A,6(B) ; grow it 10 by copying
\r
19619 PUSH P,A ; save new length
\r
19620 PUSHJ P,CAFRE1 ; get frozen uvector
\r
19621 ADD B,[10,,10] ; rest it down some
\r
19622 HRL C,TD.LNT+1(TVP) ; prepare to BLT in
\r
19623 MOVEM B,TD.LNT+1(TVP) ; and save as new length vector
\r
19624 HRRI C,(B) ; destination
\r
19625 ADD B,(P) ; final destination address
\r
19627 MOVE A,(P) ; length for new getters
\r
19629 MOVE C,TD.GET+1(TVP) ; get old for copy
\r
19630 MOVEM B,TD.GET+1(TVP)
\r
19633 BLT C,-13(B) ; zap those guys in
\r
19634 MOVE A,(P) ; finally putters
\r
19636 MOVE C,TD.PUT+1(TVP)
\r
19637 MOVEM B,TD.PUT+1(TVP)
\r
19638 HRRI C,(B) ; BLT pointer
\r
19641 SUB P,[1,,1] ; flush stack craft
\r
19646 GOODRM: MOVE B,TD.LNT+1(TVP) ; move down to fit new guy
\r
19647 SUB B,[1,,1] ; will always win due to prev checks
\r
19648 MOVEM B,TD.LNT+1(TVP)
\r
19650 HLRE A,TD.LNT+1(TVP)
\r
19652 ADDI A,-1(B) ; A/ final destination
\r
19654 POP P,(A) ; new length ins munged in
\r
19655 HLRE A,TD.LNT+1(TVP)
\r
19656 MOVNS A ; A/ offset for other guys
\r
19657 PUSH P,A ; save it
\r
19658 ADD A,TD.GET+1(TVP) ; point for storing uvs of ins
\r
19661 ADD A,TD.PUT+1(TVP)
\r
19662 MOVEM E,-1(A) ; store putter also
\r
19663 POP P,A ; compute primtype
\r
19666 MOVE B,(TP) ; ready to mung type vector
\r
19668 PUSHJ P,INSNT ; insert into vector
\r
19672 ; FUNCTIONS TO SET UP EVALUATION AND APPLICATION RULES FOR DATA TYPES
\r
19674 MFUNCTION EVALTYPE,SUBR
\r
19678 PUSHJ P,CHKARG ; VERIFY WINNAGE IN ARGS
\r
19679 MOVEI A,EVATYP ; POINT TO TABLE
\r
19680 MOVEI E,EVTYPE ; POINT TO PURE VERSION
\r
19681 TBLCAL: PUSHJ P,TBLSET ; SETUP TABLE ENTRY
\r
19684 MFUNCTION APPLYTYPE,SUBR
\r
19689 MOVEI A,APLTYP ; POINT TO APPLY TABLE
\r
19690 MOVEI E,APTYPE ; PURE TABLE
\r
19694 MFUNCTION PRINTTYPE,SUBR
\r
19699 MOVEI A,PRNTYP ; POINT TO APPLY TABLE
\r
19700 MOVEI E,PRTYPE ; PURE TABLE
\r
19703 ; CHECK ARGS AND SETUP FOR TABLE HACKER
\r
19705 CHKARG: GETYP A,(AB) ; 1ST MUST BE TYPE NAME
\r
19708 MOVE B,1(AB) ; GET ATOM
\r
19709 PUSHJ P,TYPLOO ; VERIFY THAT IT IS A TYPE
\r
19710 PUSH P,D ; SAVE TYPE NO.
\r
19711 HRRZ A,(A) ; GET SAT
\r
19714 GETYP A,2(AB) ; GET 2D TYPE
\r
19715 CAIE A,TATOM ; EITHER TYPE OR APPLICABLE
\r
19716 JRST TRYAPL ; TRY APPLICABLE
\r
19717 MOVE B,3(AB) ; VERIFY IT IS A TYPE
\r
19719 HRRZ A,(A) ; GET SAT
\r
19721 POP P,C ; RESTORE SAVED SAT
\r
19722 CAIE A,(C) ; SKIP IF A WINNER
\r
19723 JRST TYPDIF ; REPORT ERROR
\r
19724 POP P,C ; GET SAVED TYPE
\r
19725 MOVEI B,0 ; TELL THAT WE ARE A TYPE
\r
19728 TRYAPL: PUSHJ P,APLQ ; IS THIS APPLICABLE
\r
19731 MOVE B,2(AB) ; RETURN SAME
\r
19737 ; HERE TO PUT ENTRY IN APPROPRIATE TABLE
\r
19739 TBLSET: HRLI A,(A) ; FOR TVP HACKING
\r
19740 ADD A,TVP ; POINT TO TVP SLOT
\r
19742 PUSH TP,D ; SAVE VALUE
\r
19745 PUSH P,C ; SAVE TYPE BEING HACKED
\r
19747 SKIPE B,1(A) ; SKIP IF VECTOR DOESN'T EXIST YET
\r
19749 HLRE A,TYPBOT+1(TVP) ; GET CURRENT TABLE LNTH
\r
19752 PUSHJ P,IVECT ; GET VECTOR
\r
19753 MOVE C,(TP) ; POINT TO RETURN POINT
\r
19754 MOVEM B,1(C) ; SAVE VECTOR
\r
19757 POP P,C ; RESTORE TYPE
\r
19761 JUMPN A,TBLOK1 ; JUMP IF FUNCTION ETC. SUPPLIED
\r
19762 CAILE D,NUMPRI ; SKIP IF ORIGINAL TYPE
\r
19763 MOVNI E,(D) ; CAUSE E TO ENDUP 0
\r
19764 ADDI E,(D) ; POINT TO PURE SLOT
\r
19765 TBLOK1: ADDI C,(C) ; POINT TO VECTOR SLOT
\r
19767 JUMPN A,OK.SET ; OK TO CLOBBER
\r
19768 ADDI B,(D) ; POINT TO TARGET TYPE'S SLOT
\r
19769 ADDI B,(D) ; POINT TO TARGET TYPE'S SLOT
\r
19770 SKIPN A,(B) ; SKIP IF WINNER
\r
19771 SKIPE 1(B) ; SKIP IF LOSER
\r
19772 SKIPA D,1(B) ; SETUP D
\r
19773 JRST CH.PTB ; CHECK PURE TABLE
\r
19775 OK.SET: MOVEM A,(C) ; STORE
\r
19777 MOVE A,(AB) ; RET TYPE
\r
19781 CH.PTB: MOVEI A,0
\r
19782 MOVE D,[SETZ NAPT]
\r
19787 CALLTY: MOVE A,TYPVEC(TVP)
\r
19788 MOVE B,TYPVEC+1(TVP)
\r
19791 MFUNCTION ALLTYPES,SUBR
\r
19795 MOVE A,TYPVEC(TVP)
\r
19796 MOVE B,TYPVEC+1(TVP)
\r
19801 ;FUNCTION TO RETURN TYPE OF ELEMENTS IN A UVECTOR
\r
19803 MFUNCTION UTYPE,SUBR
\r
19807 GETYP A,(AB) ;GET U VECTOR
\r
19811 MOVE B,1(AB) ; GET UVECTOR
\r
19815 CUTYPE: HLRE A,B ;GET -LENGTH
\r
19817 SUB B,A ;POINT TO TYPE WORD
\r
19819 JRST ITYPE ; GET NAME OF TYPE
\r
19821 ; FUNCTION TO CHANGE UNIFORM TYPE OF A VECTOR
\r
19823 MFUNCTION CHUTYPE,SUBR
\r
19827 GETYP A,2(AB) ;GET 2D TYPE
\r
19830 GETYP A,(AB) ; CALL WITH UVECTOR?
\r
19834 MOVE A,1(AB) ; GET UV POINTER
\r
19835 MOVE B,3(AB) ;GET ATOM
\r
19837 MOVE A,(AB) ; RETURN UVECTOR
\r
19841 CCHUTY: PUSH TP,$TUVEC
\r
19843 PUSHJ P,TYPLOO ;LOOK IT UP
\r
19844 HRRZ B,(A) ;GET SAT
\r
19848 HLRE C,(TP) ;-LENGTH
\r
19850 SUB E,C ;POINT TO TYPE
\r
19851 GETYP A,(E) ;GET TYPE
\r
19852 JUMPE A,WIN0 ;ALLOW TYPE "LOSE" TO CHANGE TO ANYTHING
\r
19853 PUSHJ P,SAT ;GET SAT
\r
19855 CAIE A,(B) ;COMPARE
\r
19857 WIN0: HRLM D,(E) ;CLOBBER NEW ONE
\r
19862 CANTCH: PUSH TP,$TATOM
\r
19863 PUSH TP,EQUOTE CANT-CHTYPE-INTO
\r
19871 PUSH TP,EQUOTE NON-ATOMIC-ARGUMENT
\r
19879 ; SUBROUTINE TO LEAVE MUDDLE CLOSING ALL CHANNELS ON THE WAY
\r
19881 MFUNCTION QUIT,SUBR
\r
19886 PUSHJ P,CLOSAL ; DO THE CLOSES
\r
19888 JRST IFALSE ; JUST IN CASE
\r
19890 CLOSAL: MOVE B,TVP ; POINT TO XFER VECCTOR
\r
19891 ADD B,[CHNL0+2,,CHNL0+2] ; POINT TO 1ST (NOT INCLUDING TTY I/O)
\r
19894 PUSH P,[N.CHNS-1] ; MAX NO. OF CHANS
\r
19896 CLOSA1: MOVE B,(TP)
\r
19899 SKIPN C,-1(B) ; THIS ONE OPEN?
\r
19901 CAME C,TTICHN+1(TVP)
\r
19902 CAMN C,TTOCHN+1(TVP)
\r
19904 PUSH TP,-2(B) ; PUSH IT
\r
19906 MCALL 1,FCLOSE ; CLOSE IT
\r
19907 CLOSA4: SOSLE (P) ; COUNT DOWN
\r
19914 CLOSA3: SKIPN B,CHNL0+1(TVP)
\r
19920 MOVEM B,CHNL0+1(TVP)
\r
19924 ; LITTLE ROUTINES USED ALL OVER THE PLACE
\r
19930 MSGTYP: HRLI B,440700 ;MAKE BYTE POINTER
\r
19931 MSGTY1: ILDB A,B ;GET NEXT CHARACTER
\r
19932 JUMPE A,CPOPJ ;NULL ENDS STRING
\r
19933 CAIE A,177 ; DONT PRINT RUBOUTS
\r
19935 JRST MSGTY1 ;AND GET NEXT CHARACTER
\r
19940 WHOAMI: 0 ; SYAYS WHETHER I AM REALLY A MUDDLE OR SOME HACK
\r
19943 ;GARBAGE COLLECTORS PDLS
\r
19946 GCPDL: -GCPLNT,,GCPDL
\r
19953 MUDSTR: ASCII /MUDDLE
\7f\7f\7f/
\r
19957 ASCIZ / IN OPERATION./
\r
19959 ;MARKED PDLS FOR GC PROCESS
\r
19962 ; DUMMY FRAME FOR INITIALIZER CALLS
\r
19972 TPBAS: BLOCK ITPLNT+PDLBUF
\r
19974 ITPLNT+2+PDLBUF+7,,0
\r
19982 $TMATO: TATOM,,-1
\r
19991 TITLE PURE-PAGE LOADER
\r
19995 MAPCH==0 ; channel for MAPing
\r
19996 ELN==3 ; Length of table entry
\r
19998 .GLOBAL PURVEC,PURTOP,PURBOT,P.TOP,MUDSTR,STRTO6,PLOAD,AGC,GCDOWN
\r
19999 .GLOBAL SQUTOA,IGVAL,IBLOCK,PURCLN,MOVPUR,GETPAG,GCFLG,NOSHUF
\r
20006 IF1, .INSRT STENEX >
\r
20010 PURDIR==SIXBIT /MUD50/ ; directory containing pure pages
\r
20011 OPURDI==SIXBIT /MHILIB/
\r
20012 OFIXDI==SIXBIT /MHILIB/
\r
20013 FIXDIR==SIXBIT /MUD50/
\r
20014 ARC==1 ; flag saying fixups on archive
\r
20025 ; This routine taskes a slot offset in register A and
\r
20026 ; maps in the associated file. It clobbers all ACs
\r
20027 ; It skip returns if it wins.
\r
20029 PLOAD: PUSH P,A ; save slot offset
\r
20030 ADD A,PURVEC+1(TVP) ; point into pure vector
\r
20031 MOVE B,(A) ; get sixbit of name
\r
20033 MOVE C,MUDSTR+2 ; get version number
\r
20034 PUSHJ P,CSIXBT ; vers # to six bit
\r
20035 HRRI C,(SIXBIT /SAV/)
\r
20037 .SUSET [.RSNAM,,0] ; GET CURRENT SNAME TO 0
\r
20038 .SUSET [.SSNAM,,[PURDIR]] ; get sname for it
\r
20039 MOVE A,[SIXBIT / &DSK/] ; build open block
\r
20040 .OPEN MAPCH,A ; try to open file
\r
20041 JRST FIXITU ; no current version, fix one up
\r
20042 PUSH P,0 ; for compat wit tenex and save old sname
\r
20043 DOTCAL FILLEN,[[1000,,MAPCH],[2000,,A]]
\r
20045 ADDI A,PGMSK ; in case not even # of pages
\r
20046 ASH A,-PGSHFT ; to pages
\r
20047 PUSH P,A ; save the length
\r
20050 MOVE E,P ; save pdl base
\r
20051 PUSH P,[0] ; slots for building strings
\r
20053 MOVE A,[440700,,1(E)]
\r
20054 MOVE C,[440600,,B]
\r
20057 JUMPE 0,.+4 ; violate cardinal ".+ rule"
\r
20058 ADDI 0,40 ; to ASCII
\r
20062 PUSH P,[ASCII / SAV/]
\r
20063 MOVE C,MUDSTR+2 ; get ascii of vers no.
\r
20064 IORI C,1 ; hair to change r.o. to space
\r
20067 ANDCM C,0 ; C has 1st 1
\r
20069 MOVEI 0,0 ; use zer name
\r
20073 AND 0,MSKS(C) ; get rid of r.o.s
\r
20075 MOVEI B,-1(P) ; point to it
\r
20077 HRROI D,1(E) ; point to name
\r
20080 PUSH P,[100000,,]
\r
20081 PUSH P,[377777,,377777]
\r
20082 PUSH P,[-1,,[ASCIZ /DSK/]]
\r
20083 PUSH P,[-1,,[ASCIZ /MUDLIB/]]
\r
20090 MOVE D,4(E) ; save final version string
\r
20094 MOVE B,[440000,,240000]
\r
20097 MOVE P,E ; flush crap
\r
20099 SIZEF ; get length
\r
20101 PUSH P,C ; save # of pages
\r
20104 PUSHJ P,ALOPAG ; get the necessary pages
\r
20106 PUSH P,B ; save page number
\r
20108 MOVN A,-1(P) ; get neg count
\r
20109 MOVSI A,(A) ; build aobjn pointer
\r
20110 HRR A,(P) ; get page to start
\r
20111 MOVE B,A ; save for later
\r
20112 HLLZ 0,A ; page pointer for file
\r
20113 DOTCAL CORBLK,[[1000,,200000],[1000,,-1],A,[1000,,MAPCH],0]
\r
20114 JRST MAPLS3 ; total wipe out
\r
20115 .CLOSE MAPCH, ; no need to have file open anymore
\r
20118 MOVE D,-1(P) ; # of pages to D
\r
20119 HRLI B,400000 ; specify this fork
\r
20120 HRROI E,(B) ; build page aobjn for later
\r
20121 TLC E,-1(D) ; sexy way of doing lh
\r
20122 HRLZ A,-2(P) ; JFN to lh of A
\r
20123 MOVSI C,120000 ; bits for read/execute
\r
20128 SOJG D,.-3 ; map 'em all
\r
20130 CLOSF ; try to close file
\r
20131 JFCL ; ignore failure
\r
20135 ; now try to smash slot in PURVEC
\r
20137 PLOAD1: MOVE A,PURVEC+1(TVP) ; get pointer to it
\r
20138 ASH B,PGSHFT ; convert to aobjn pointer to words
\r
20139 MOVE C,-3(P) ; get slot offset
\r
20140 ADDI C,(A) ; point to slot
\r
20141 MOVEM B,1(C) ; clobber it in
\r
20142 ANDI B,-1 ; isolate address of page
\r
20143 HRRZ D,PURVEC(TVP) ; get offset into vector for start of chain
\r
20144 TRNE D,400000 ; skip if not end marker
\r
20146 HRLI D,A ; set up indexed pointer
\r
20148 HRRZ 0,@D ; get its address
\r
20149 JUMPE 0,SCHAIN ; no chain exists, start one
\r
20150 CAILE 0,(B) ; skip if new one should be first
\r
20151 AOJA D,INLOOP ; jump into the loop
\r
20153 SUBI D,1 ; undo ADDI
\r
20154 FCLOB: MOVE E,-3(P) ; get offset for this guy
\r
20155 HRRM D,2(C) ; link up
\r
20156 HRRM E,PURVEC(TVP) ; store him away
\r
20159 SCHAIN: MOVEI D,400000 ; get end of chain indicator
\r
20160 JRST FCLOB ; and clobber it in
\r
20162 INLOOP: MOVE E,D ; save in case of later link up
\r
20163 HRR D,@D ; point to next table entry
\r
20164 TRNE D,400000 ; 400000 is the end of chain bit
\r
20165 JRST SLFOUN ; found a slot, leave loop
\r
20166 ADDI D,1 ; point to address of progs
\r
20167 HRRZ 0,@D ; get address of block
\r
20168 CAILE 0,(B) ; skip if still haven't fit it in
\r
20169 AOJA D,INLOOP ; back to loop start and point to chain link
\r
20170 SUBI D,1 ; point back to start of slot
\r
20172 SLFOUN: MOVE 0,-3(P) ; get offset into vector of this guy
\r
20173 HRRM 0,@E ; make previous point to us
\r
20174 HRRM D,2(C) ; link it in
\r
20177 PLOADD: AOS -4(P) ; skip return
\r
20179 MAPLS3: SUB P,[1,,1] ; flush stack crap
\r
20180 MAPLS1: SUB P,[1,,1]
\r
20184 .SUSET [.SSNAM,,0] ; restore SNAME
\r
20189 ; Here if no current version exists
\r
20191 FIXITU: PUSH TP,$TFIX
\r
20192 PUSH TP,0 ; maybe save sname
\r
20195 PUSH P,C ; save final name
\r
20196 MOVE C,[SIXBIT /FIXUP/] ; name of fixup file
\r
20197 IFN <PURDIR-OFIXDI>,.SUSET [.SSNAM,,[OFIXDI]]
\r
20198 IFN ARC, HRRI A,(SIXBIT /ARC/)
\r
20200 IFE ARC, JRST MAPLOS
\r
20201 IFN ARC, PUSHJ P,ARCLOS
\r
20202 MOVE 0,[-2,,A] ; prepare to read version and length
\r
20203 PUSH P,B ; save program name
\r
20206 FATAL BAD FIXUP FILE
\r
20207 PUSH P,B ; save version number of fixup file
\r
20208 MOVEI A,-2(A) ; length -2 (for vers and length)
\r
20209 PUSHJ P,IBLOCK ; get a UVECTOR for the fixups
\r
20210 PUSH TP,$TUVEC ; and save
\r
20214 MOVEM 0,ASTO(PVP) ; prepare for moby iot (interruptable)
\r
20216 .IOT MAPCH,A ; get fixups
\r
20220 POP P,A ; restore version number
\r
20221 IDIVI A,100. ; get 100s digit in a rest in B
\r
20222 ADDI A,20 ; convert to sixbit
\r
20223 IDIVI B,10. ; B tens digit C 1s digit
\r
20226 MOVE 0,[220600,,D]
\r
20227 MOVSI D,(SIXBIT /SAV/)
\r
20233 MOVE B,[SIXBIT / &DSK/]
\r
20234 MOVE C,(P) ; program name
\r
20235 IFN <OPURDI-OFIXDI>,.SUSET [.SSNAM,,[OPURDI]]
\r
20236 .OPEN MAPCH,B ; try for this one
\r
20238 DOTCAL FILLEN,[[1000,,MAPCH],[2000,,A]]
\r
20240 ADDI A,PGMSK ; in case not exact pages
\r
20241 ASH A,-PGSHFT ; to pages
\r
20243 PUSHJ P,ALOPAG ; find some pages
\r
20245 MOVN A,(P) ; build aobjn pointer
\r
20250 DOTCAL CORBLK,[[1000,,104000],[1000,,-1],A,[1000,,MAPCH],0]
\r
20256 PUSH TP,$TPDL ; save stack pointer
\r
20258 PUSH P,D ; save vers string
\r
20259 HRROI A,[ASCIZ /FIXUP/]
\r
20260 MOVEM A,10.(E) ; into name slot
\r
20261 MOVEI A,5(E) ; point to arg block
\r
20265 MOVEI C,(A) ; save JFN in case OPNEF loses
\r
20266 MOVE B,[440000,,200000]
\r
20269 BIN ; length of fixups to B
\r
20270 PUSH P,A ; save JFN
\r
20271 MOVEI A,-2(B) ; length of uvextor to get
\r
20274 PUSH TP,B ; sav it
\r
20275 POP P,A ; restore JFN
\r
20276 BIN ; read in vers #
\r
20277 MOVE D,B ; save vers #
\r
20281 SIN ; read in entire fixups
\r
20282 CLOSF ; and close file of same
\r
20283 JFCL ; ignore cailure to close
\r
20284 HRROI C,1(E) ; point to name
\r
20289 MOVE 0,[ASCII / /]
\r
20290 MOVEM 0,4(E) ; all spaces
\r
20292 IDIVI A,100. ; to ascii
\r
20297 MOVE 0,[440700,,4(E)]
\r
20304 MOVEI A,5(E) ; ready for 'nother GTJFN
\r
20307 MOVEI C,(A) ; save JFN in case OPENF loses
\r
20308 MOVE B,[440000,,240000]
\r
20316 PUSHJ P,ALOPAG ; get the pages
\r
20318 MOVEI D,(B) ; save pointer
\r
20319 MOVN A,(P) ; build page aobjn pntr
\r
20321 EXCH D,(P) ; get length
\r
20324 HRLZ A,-1(P) ; JFN for PMAP
\r
20325 MOVSI C,120400 ; bits for read/execute/copy-on-write
\r
20335 POP P,B ; restore page #
\r
20338 ; now to do fixups
\r
20340 MOVE A,(TP) ; pointer to them
\r
20341 ASH B,PGSHFT ; aobjn to program
\r
20343 FIX1: SKIPL E,(A) ; read one hopefully squoze
\r
20344 FATAL ATTEMPT TO TYPE FIX PURE
\r
20346 PUSHJ P,SQUTOA ; look it up
\r
20350 HLRZ D,(A) ; get old value
\r
20351 SUBM E,D ; D is diff between old and new
\r
20352 HRLM E,(A) ; fixup the fixups
\r
20353 MOVEI 0,0 ; flag for which half
\r
20354 FIX4: JUMPE 0,FIXRH ; jump if getting rh
\r
20355 MOVEI 0,0 ; next time will get rh
\r
20356 AOBJP A,FIX2 ; done?
\r
20357 HLRZ C,(A) ; get lh
\r
20358 JUMPE C,FIX3 ; 0 terminates
\r
20359 FIX5: ADDI C,(B) ; access the code
\r
20360 ADDM D,-1(C) ; and fix it up
\r
20363 FIXRH: MOVEI 0,1 ; change flag
\r
20364 HRRZ C,(A) ; get it and
\r
20367 FIX3: AOBJN A,FIX1 ; do next one
\r
20371 IFN <PURDIR-OPURDI> .SUSET [.SSNAM,,[PURDIR]]
\r
20372 .OPEN MAPCH,[SIXBIT / 'DSK_PURE_>/]
\r
20374 MOVE E,B ; save pointer
\r
20375 ASH E,-PGSHFT ; to page AOBJN
\r
20376 .IOT MAPCH,B ; write out the goodie
\r
20381 .FDELE 0 ; attempt to rename to right thing
\r
20384 MOVE B,[SIXBIT / &DSK/]
\r
20386 FATAL WHERE DID THE FILE GO?
\r
20387 HLLZ 0,E ; pointer to file pages
\r
20388 PUSH P,E ; SAVE FOR END
\r
20389 DOTCAL CORBLK,[[1000,,200000],[1000,,-1],E,[1000,,MAPCH],0]
\r
20390 FATAL LOSSAGE LOSSAGE PAGES LOST
\r
20393 SKIPGE MUDSTR+2 ; skip if not experimental
\r
20395 PUSHJ P,GENVN ; get version number as a number
\r
20397 IFN <PURDIR-FIXDIR>,.SUSET [.SSNAM,,[FIXDIR]]
\r
20398 IFE ARC, .OPEN MAPCH,[SIXBIT / 'DSK_FIXU_>/]
\r
20399 IFN ARC, .OPEN MAPCH,[SIXBIT / 'ARC_FIXU_>/]
\r
20400 IFE ARC, FATAL CANT WRITE FIXUPS
\r
20401 IFN ARC, PUSHJ P,ARCFAT
\r
20402 HLRE A,E ; get length
\r
20404 ADDI A,2 ; account for these 2 words
\r
20405 MOVE 0,[-2,,A] ; write version and length
\r
20407 .IOT MAPCH,E ; out go the fixups
\r
20411 MOVE D,[SIXBIT /FIXUP/]
\r
20413 FATAL FIXUP WRITE OUT FAILED
\r
20418 MOVE E,-2(TP) ; restore P-stack base
\r
20419 MOVEI 0,600000 ; fixup args to GTJFN
\r
20421 MOVE D,B ; save page number
\r
20422 POP P,4(E) ; current version name in
\r
20423 MOVEI A,5(E) ; pointer ro arg block
\r
20426 FATAL MAP FIXUP LOSSAGE
\r
20427 MOVE B,[440000,,100000]
\r
20429 FATAL MAP FIXUP LOSSAGE
\r
20430 MOVEI B,(D) ; ready to write it out
\r
20433 SOUT ; zap it out
\r
20434 TLO A,400000 ; dont recycle the JFN
\r
20437 ANDI A,-1 ; kill sign bit
\r
20438 MOVE B,[440000,,240000]
\r
20440 FATAL MAP FIXUP LOSSAGE
\r
20442 ASH B,-PGSHFT ; aobjn to pages
\r
20444 HLRE D,B ; -count
\r
20458 HRROI 0,[ASCIZ /FIXUP/] ; now write out new fixup file
\r
20464 JRST NOFIXO ; exp vers, dont write out
\r
20467 MOVEI D,(B) ; save vers in D
\r
20469 FATAL MAP FIXUP LOSSAGE
\r
20470 MOVE B,[440000,,100000]
\r
20472 FATAL MAP FIXUP LOSSAGE
\r
20473 HLRE B,(TP) ; length of fixup vector
\r
20475 ADDI B,2 ; for length and version words
\r
20477 MOVE B,D ; and vers #
\r
20479 MOVSI B,444400 ; byte pointer to fixups
\r
20485 NOFIXO: MOVE A,(P) ; save aobjn to pages
\r
20490 HRRZ A,(P) ; get page #
\r
20491 HLRE C,(P) ; and # of same
\r
20492 MOVE B,(P) ; set B up for return
\r
20496 MOVE 0,-2(TP) ; saved sname
\r
20505 MAPLS4: .CLOSE MAPCH,
\r
20510 MAPLS4: SKIPA A,[4,,4]
\r
20511 MAPLS5: MOVE A,[6,,6]
\r
20522 ARCLOS: PUSHJ P,CKLOCK
\r
20529 ARCFAT: PUSHJ P,CKLOCK
\r
20530 FATAL CANT WRITE FIXUP FILE
\r
20535 LDB 0,[220600,,0]
\r
20536 CAIN 0,23 ; file locked?
\r
20537 JRST WAIT ; wait and retry
\r
20549 ; Here to try to get a free page block for new thing
\r
20550 ; A/ # of pages to get
\r
20552 ALOPAG: PUSHJ P,GETPAG ; try to get enough pages
\r
20554 AOS (P) ; won skip return
\r
20555 MOVEI 0,(B) ; update PURBOT/PURTOP to reflect current state
\r
20560 GETPAG: MOVE C,P.TOP ; top of GC space
\r
20561 ASH C,-PGSHFT ; to page number
\r
20562 MOVE B,PURBOT ; current bottom of pure space
\r
20563 ASH B,-PGSHFT ; also to pages
\r
20564 SUBM B,C ; pages available ==> C
\r
20565 CAIGE C,(A) ; skip if have enough already
\r
20566 JRST GETPG1 ; no, try to shuffle around
\r
20567 SUBI B,(A) ; B/ first new page
\r
20569 POPJ P, ; return with new free page in B
\r
20571 ; Here if shuffle must occur or gc must be done to make room
\r
20573 GETPG1: MOVEI 0,0
\r
20574 SKIPE NOSHUF ; if can't shuffle, then ask gc
\r
20576 MOVE 0,PURTOP ; get top of mapped pure area
\r
20577 SUB 0,P.TOP ; total free words to 0
\r
20578 ASH 0,-PGSHFT ; to pages
\r
20579 CAIGE 0,(A) ; skip if winnage possible
\r
20580 JRST ASKAGC ; please AGC give me some room!!
\r
20581 SUBM A,C ; C/ amount we must flush to make room
\r
20583 ; Here to find pages for flush using LRU algorithm
\r
20585 GL1: MOVE B,PURVEC+1(TVP) ; get pointer to pure sr vector
\r
20586 MOVEI 0,-1 ; get very large age
\r
20588 GL2: SKIPN 1(B) ; skip if not already flushed
\r
20590 HLRZ D,2(B) ; get this ones age
\r
20591 CAMLE D,0 ; skip if this is a candidate
\r
20593 MOVE E,B ; point to table entry with E
\r
20594 MOVEI 0,(D) ; and use as current best
\r
20595 GL3: ADD B,[ELN,,ELN] ; look at next
\r
20598 HLRE B,1(E) ; get length of flushee
\r
20599 ASH B,-PGSHFT ; to negative # of pages
\r
20600 ADD C,B ; update amount needed
\r
20601 SETZM 1(E) ; indicate it will be gone
\r
20602 JUMPG C,GL1 ; jump if more to get
\r
20604 ; Now compact pure space
\r
20606 PUSH P,A ; need all acs
\r
20608 HRRZ D,PURVEC(TVP) ; point to first in core addr order
\r
20609 HRRZ C,PURTOP ; get destination page
\r
20610 ASH C,-PGSHFT ; to page number
\r
20612 CL1: ADD D,PURVEC+1(TVP) ; to real pointer
\r
20613 SKIPE 1(D) ; skip if this one is a flushee
\r
20616 HRRZ D,2(D) ; point to next one in chain
\r
20617 JUMPN E,CL3 ; jump if not first one
\r
20618 HRRM D,PURVEC(TVP) ; and use its next as first
\r
20621 CL3: HRRM D,2(E) ; link up
\r
20624 ; Found a stayer, move it if necessary
\r
20626 CL2: MOVEI E,(D) ; another pointer to slot
\r
20627 HLRE B,1(D) ; - length of block
\r
20628 HRRZ D,1(D) ; pointer to block
\r
20629 SUB D,B ; point to top of block
\r
20630 ASH D,-PGSHFT ; to page number
\r
20631 CAIN D,(C) ; if not moving, jump
\r
20634 ASH B,-PGSHFT ; to pages
\r
20636 CL5: SUBI C,1 ; move to pointer and from pointer
\r
20638 DOTCAL CORBLK,[[1000,,200000],[1000,,-1],C,[1000,,-1],D]
\r
20639 FATAL PURE SHUFFLE LOSSAGE
\r
20640 AOJL B,CL5 ; count down
\r
20643 PUSH P,B ; save # of pages
\r
20644 MOVEI A,-1(D) ; copy from pointer
\r
20645 HRLI A,400000 ; get this fork code
\r
20646 RMAP ; get a JFN (hopefully)
\r
20647 EXCH D,(P) ; D # of pages (save from)
\r
20648 ADDM D,(P) ; update from
\r
20649 MOVEI B,-1(C) ; to pointer in B
\r
20651 MOVSI C,120000 ; read/execute modes
\r
20653 PMAP ; move a page
\r
20656 AOJL D,.-3 ; move them all
\r
20662 ; Update the table address for this loser
\r
20664 SUBM C,D ; compute offset (in pages)
\r
20665 ASH D,PGSHFT ; to words
\r
20666 ADDM D,1(E) ; update it
\r
20667 CL7: HRRZ D,2(E) ; chain on
\r
20668 CL4: TRNN D,400000 ; skip if end of chain
\r
20671 ASH C,PGSHFT ; to words
\r
20672 MOVEM C,PURBOT ; reset pur bottom
\r
20676 CL6: HRRZ C,1(E) ; get new top of world
\r
20677 ASH C,-PGSHFT ; to page #
\r
20680 ; SUBR to create an entry in the vector for one of these guys
\r
20682 MFUNCTION PCODE,SUBR
\r
20686 GETYP 0,(AB) ; check 1st arg is string
\r
20689 GETYP 0,2(AB) ; second must be fix
\r
20693 MOVE A,(AB) ; convert name of program to sixbit
\r
20696 PCODE4: MOVE C,(P) ; get name in sixbit
\r
20698 ; Now look for either this one or an empty slot
\r
20701 MOVE B,PURVEC+1(TVP)
\r
20703 PCODE2: CAMN C,(B) ; skip if this is not it
\r
20704 JRST PCODE1 ; found it, drop out of loop
\r
20705 JUMPN E,.+3 ; dont record another empty if have one
\r
20706 SKIPN (B) ; skip if slot filled
\r
20707 MOVE E,B ; remember pointer
\r
20709 JUMPL B,PCODE2 ; jump if more to look at
\r
20711 JUMPE E,PCODE3 ; if E=0, error no room
\r
20712 MOVEM C,(E) ; else stash away name and zero rest
\r
20717 PCODE1: MOVE E,B ; build <slot #>,,<offset>
\r
20718 MOVEI 0,0 ; flag whether new slot
\r
20719 SKIPE 1(E) ; skip if mapped already
\r
20723 HLRE E,PURVEC+1(TVP)
\r
20727 SKIPN NOSHUF ; skip if not shuffling
\r
20729 JUMPN 0,FINIS ; jump if winner
\r
20739 PCOERR: PUSH TP,$TATOM
\r
20740 PUSH TP,EQUOTE PURE-LOAD-FAILURE
\r
20744 PCODE3: HLRE A,PURVEC+1(TVP) ; get current length
\r
20746 ADDI A,10*ELN ; add 10(8) more entry slots
\r
20748 EXCH B,PURVEC+1(TVP) ; store new one and get old
\r
20749 HLRE A,B ; -old length to A
\r
20750 MOVSI B,(B) ; start making BLT pointer
\r
20751 HRR B,PURVEC+1(TVP)
\r
20752 SUBM B,A ; final dest to A
\r
20756 ; Here if must try to GC for some more core
\r
20758 ASKAGC: SKIPE GCFLG ; if already in GC, lose
\r
20760 SUBM A,0 ; amount required to 0
\r
20761 ASH 0,PGSHFT ; TO WORDS
\r
20762 MOVEM 0,GCDOWN ; pass as funny arg to AGC
\r
20763 EXCH A,C ; save A from gc's destruction
\r
20764 IFN ITS, .IOPUSH MAPCH, ; gc uses same channel
\r
20766 MOVE C,[8,,9.] ; SET UP INDICATORS FOR GC
\r
20769 IFN ITS, .IOPOP MAPCH,
\r
20773 PUSH TP,EQUOTE NO-MORE-PAGES
\r
20776 ; Here to clean up pure space by flushing all shared stuff
\r
20778 PURCLN: SKIPE NOSHUF
\r
20781 HRRM B,PURVEC(TVP) ; flush chain pointer
\r
20782 MOVE B,PURVEC+1(TVP) ; get pointer to table
\r
20783 SETZM 1(B) ; zero pointer entry
\r
20784 SETZM 2(B) ; zero link and age slots
\r
20785 ADD B,[ELN,,ELN] ; go to next slot
\r
20786 JUMPL B,.-3 ; do til exhausted
\r
20787 MOVE B,PURBOT ; now return pages
\r
20788 SUB B,PURTOP ; compute page AOBJN pointer
\r
20789 JUMPE B,CPOPJ ; no pure pages?
\r
20794 DOTCAL CORBLK,[[1000,,0],[1000,,-1],B]
\r
20795 FATAL SYSTEM WONT TAKE CORE BACK?
\r
20798 HLRE D,B ; - # of pges to flush
\r
20799 HRLI B,400000 ; specify hacking hom fork
\r
20806 MOVE B,PURTOP ; now fix up pointers
\r
20807 MOVEM B,PURBOT ; to indicate no pure
\r
20810 ; Here to move the entire pure space.
\r
20811 ; A/ # and direction of pages to move (+ ==> up)
\r
20813 MOVPUR: SKIPE NOSHUF
\r
20814 FATAL CANT MOVE PURE SPACE AROUND
\r
20815 IFE ITS [ASH A,1]
\r
20816 SKIPN B,A ; zero movement, ignore call
\r
20819 ASH B,PGSHFT ; convert to words for pointer update
\r
20820 MOVE C,PURVEC+1(TVP) ; loop through updating non-zero entries
\r
20826 MOVE C,PURTOP ; found pages at top and bottom of pure
\r
20830 ADDM B,PURTOP ; update to new boundaries
\r
20832 CAIN C,(D) ; differ?
\r
20834 JUMPG A,PUP ; if moving up, go do separate CORBLKs
\r
20837 SUBM D,C ; -size of area to C (in pages)
\r
20838 MOVEI E,(D) ; build pointer to bottom of destination
\r
20842 DOTCAL CORBLK,[[1000,,200000],[1000,,-1],E,[1000,,-1],D]
\r
20843 FATAL CANT MOVE PURE
\r
20846 PUP: SUBM C,D ; pages to move to D
\r
20847 ADDI A,(C) ; point to new top
\r
20851 DOTCAL CORBLK,[[1000,,200000],[1000,,-1],A,[1000,,-1],C]
\r
20852 FATAL CANT MOVE PURE
\r
20857 SUBM D,C ; pages to move to D
\r
20858 MOVSI E,(C) ; build aobjn pointer
\r
20859 HRRI E,(D) ; point to lowest
\r
20860 ADD D,A ; D==> new lowest page
\r
20861 PURCL1: MOVSI A,400000 ; specify here
\r
20862 HRRI A,(E) ; get a page
\r
20863 RMAP ; get a real handle on it
\r
20864 MOVE B,D ; where to go
\r
20872 PUP: SUB D,C ; - count to D
\r
20873 MOVSI E,(D) ; start building AOBJN
\r
20874 HRRI E,(C) ; aobjn to top
\r
20875 ADD C,A ; C==> new top
\r
20878 PUPL: MOVSI A,400000
\r
20880 RMAP ; get real handle
\r
20892 CSIXBT: MOVEI 0,5
\r
20893 PUSH P,[440700,,C]
\r
20894 PUSH P,[440600,,D]
\r
20896 CSXB2: ILDB E,-1(P)
\r
20902 CSXB1: SUB P,[2,,2]
\r
20906 GENVN: MOVE C,[440700,,MUDSTR+2]
\r
20927 TITLE MAPS -- MAP FUNCTIONS FOR MUDDLE
\r
20933 .GLOBAL TYPSEG,NXTLM,NAPT,APLQ,INCR1,SPECBI,FRMSTK,MAPPLY
\r
20934 .GLOBAL CHFSWP,SSPEC1,ILVAL,CHUNW
\r
20938 INCNT==0 ; INNER LOOP COUNT
\r
20939 LISTNO==-1 ; ARG NUMBER BEING HACKED
\r
20940 ARGCNT==-2 ; FINAL ARG COUNTER
\r
20941 NARGS==-3 ; NUMBER OF STRUCTURES
\r
20942 NTHRST==-4 ; 0=> MAP REST, OTHERWISE MAP FIRST
\r
20944 ; MAP THE "CAR" OF EACH LIST
\r
20946 MFUNCTION MAPF,SUBR
\r
20948 PUSH P,. ; PUSH NON-ZERO
\r
20951 ; MAP THE "CDR" OF EACH LIST
\r
20953 MFUNCTION MAPR,SUBR
\r
20958 HLRE C,AB ; HOW MANY ARGS
\r
20959 ASH C,-1 ; TO # OF PAIRS
\r
20960 ADDI C,3 ; AT LEAST 3
\r
20961 JUMPG C,TFA ; NOT ENOUGH
\r
20962 GETYP A,(AB) ; TYPE OF CONSTRUCTOR
\r
20963 CAIN A,TFALSE ; ANY CONSING NEEDE?
\r
20964 JRST MAP2 ; NO, SKIP CHECK
\r
20965 PUSHJ P,APLQ ; CHECK IF APPLICABLE
\r
20966 JRST NAPT ; NO, ERROR
\r
20967 MAP2: MOVNS C ; POS NO. OF ARGS (-3)
\r
20968 ADDI C,1 ; C/ NOW # OF LISTS...
\r
20969 PUSH P,C ; SAVE IT
\r
20970 PUSH TP,[TATOM,,-1] ; ALL **GFP** INSTRUCTIONS ARE TO DO WITH MAPRET
\r
20971 PUSH TP,MQUOTE LMAP,[LMAP ]INTRUP
\r
20972 PUSHJ P,FRMSTK ; **GFP**
\r
20973 PUSH TP,[0] ; **GFP**
\r
20974 PUSH TP,[0] ; **GFP**
\r
20975 PUSHJ P,SPECBIND ; **GFP**
\r
20976 MOVE C,(P) ; RESTORE COUNT OF ARGS
\r
20977 MOVE A,AB ; COPY ARG POINTER
\r
20978 MOVSI 0,TAB ; CLOBBER A'S TYPE
\r
20979 MOVEM 0,ASTO(PVP)
\r
20981 ARGLP: INTGO ; STACK MAY OVERFLOW
\r
20982 PUSH TP,4(A) ; SKIP FCNS
\r
20985 SOJG C,ARGLP ; ALL UP ON STACK
\r
20987 ; ALL STRUCTURES ARE ON THE STACK, NOW PUSH THE CONSTRUCTOR
\r
20989 PUSH TP,(AB) ; CONSTRUCTOR
\r
20992 PUSH P,[-1] ; FUNNY TEMPS
\r
20996 ; OUTER LOOP CDRING EACH STRUCTURE
\r
20998 OUTRLP: SETZM LISTNO(P) ; START AT 0TH LIST
\r
20999 MOVE 0,NARGS(P) ; TOTAL # OF STRUCS
\r
21000 MOVEM 0,INCNT(P) ; AS COUNTER IN INNER LOOP
\r
21001 PUSH TP,2(AB) ; PUSH THE APPLIER
\r
21004 ; INNER LOOP, CONS UP EACH APPLICATION
\r
21007 MOVEI E,2 ; READY TO BUMP LISTNO
\r
21008 ADDB E,LISTNO(P) ; CURRENT STORED AND IN C
\r
21009 ADDI E,(TB)4 ; POINT TO A STRUCTURE
\r
21010 MOVE A,(E) ; PICK IT UP
\r
21011 MOVE B,1(E) ; AND VAL
\r
21012 PUSHJ P,TYPSEG ; SETUP TO REST IT ETC.
\r
21013 SKIPL ARGCNT(P) ; DONT INCR THE 1ST TIME
\r
21014 XCT INCR1(C) ; INCREMENT THE LOSER
\r
21015 MOVE 0,DSTO(PVP) ; UPDATE THE LIST
\r
21017 MOVEM D,1(E) ; CLOBBER AWAY
\r
21018 PUSH TP,DSTO(PVP) ; FOR REST CASE
\r
21020 PUSHJ P,NXTLM ; SKIP IF GOT ONE, ELSE DONT
\r
21021 JRST DONEIT ; FINISHED
\r
21023 SKIPN NTHRST(P) ; SKIP IF MAP REST
\r
21025 MOVEM A,-1(TP) ; IUSE AS ARG
\r
21027 INRLP1: SOSE INCNT(P) ; COUNT ARGS
\r
21028 JRST INRLP ; MORE, GO DO THEM
\r
21031 ; ALL ARGS PUSHED, APPLY USER FCN
\r
21033 SKIPGE ARGCNT(P) ; UN NEGATE ARGCNT
\r
21035 MOVE A,NARGS(P) ; GET # OF ARGS
\r
21037 ACALL A,MAPPLY ; APPLY THE BAG BITER
\r
21039 GETYP 0,(AB) ; GET TYPE OF CONSTRUCTOR
\r
21040 CAIN 0,TFALSE ; SKIP IF ONE IS THERE
\r
21047 OUTRL1: MOVEM A,-1(TP) ; SAVE PARTIAL VALUE
\r
21051 ; HERE IF ALL FINISHED
\r
21053 DONEIT: HRLS C,LISTNO(P) ; HOW MANY DONE
\r
21054 SUB TP,[2,,2] ; FLUSH SAVED VAL
\r
21055 SUB TP,C ; FLUSH TUPLE OF CRUFT
\r
21056 DONEI1: SKIPGE ARGCNT(P)
\r
21057 SETZM ARGCNT(P) ; IN CASE STILL NEGATIVE
\r
21058 SETZM DSTO(PVP) ; UNSCREW
\r
21059 GETYP 0,(AB) ; ANY CONSTRUCTOR
\r
21061 JRST MFINIS ; NO, LEAVE
\r
21062 AOS D,ARGCNT(P) ; IF NO ARGS
\r
21063 ACALL D,APPLY ; APPLY IT
\r
21067 ; HERE TO FINISH IF CONSTRUCTOR WAS #FALSE ()
\r
21073 ; **GFP** FROM HERE TO THE END
\r
21075 MFUNCTION MAPLEAVE,SUBR
\r
21081 MOVE B,MQUOTE LMAP,[LMAP ]INTRUP
\r
21084 CAIE 0,TFRAME ; MAKE SURE WINNER
\r
21088 MOVEI B,-1(TP) ; POINT TO FRAME POINTER
\r
21091 JUMPL C,MAPL1 ; RET VAL SUPPLIED
\r
21096 MAPL1: MOVE A,(C)
\r
21100 MFUNCTION MAPSTOP,SUBR
\r
21107 MFUNCTION MAPRET,SUBR
\r
21112 MAPREC: MOVE B,MQUOTE LMAP,[LMAP ]INTRUP
\r
21113 PUSHJ P,ILVAL ; GET VALUE
\r
21114 GETYP 0,A ; FRAME?
\r
21120 POP P,0 ; RET/STOP SWITCH
\r
21121 JUMPN 0,MAPRC1 ; JUMP IF STOP
\r
21122 PUSHJ P,CHFSWP ; CHECK IT OUT (AND MAYBE SWAP)
\r
21125 MAPRC1: PUSHJ P,CHFSWP
\r
21127 MAPRC2: HRRZ E,SPSAV(B) ; UNBIND BEFORE RETURN
\r
21130 ADDI E,1 ; FUDGE FOR UNBINDER
\r
21131 PUSHJ P,SSPEC1 ; UNBINDER
\r
21132 HLRE D,(TP) ; FIND NUMBER
\r
21133 JUMPE D,MAPRE1 ; SKIP IF NONE TO MOVE
\r
21134 MOVNS E,D ; AND PLUS IT
\r
21135 HRLI E,(E) ; COMPUTE NEW TP
\r
21136 ADD E,TPSAV(B) ; NEW TP
\r
21137 HRRZ C,TPSAV(B) ; GET OLD TOP
\r
21139 HRL C,(TP) ; AND NEW BOT
\r
21141 BLT C,(E) ; BRING IT ALL DOWN
\r
21142 MAPRE1: ASH D,-1 ; NO OF ARGS
\r
21143 HRRI TB,(B) ; PREPARE TO FINIS
\r
21146 POP P,0 ; GET PC TO GO TO
\r
21147 MOVEM 0,PCSAV(TB)
\r
21148 JRST CONTIN ; BACK TO MAPPER
\r
21150 NLOCR1: TDZA A,A ; ZER SW
\r
21152 GETYP 0,(AB) ; CHECK IF BUILDING
\r
21154 JRST FLUSHM ; REMOVE GOODIES
\r
21155 ADDM B,ARGCNT(P) ; BUMP ARG COUNTER
\r
21156 NLOCR2: JUMPE A,DONEI1
\r
21159 FLUSHM: ASH B,1 ; FLUSH GOODIES DROPPED
\r
21164 NOTM: PUSH TP,$TATOM
\r
21165 PUSH TP,EQUOTE NOT-IN-MAP-FUNCTION
\r
21169 \f; THE FOLLOWING INFORMATION IS MEANT AS GUIDE TO THE CARE AND FEEDING
\r
21170 ; OF MUDDLE. IT ATTEMPTS TO SPECIFY PROGRAMMING CONVENTIONS AND
\r
21171 ; SUPPLY SYMBOLS AND MACROS NEEDED BY ALL MODULES IN A MUDDLE.
\r
21173 ; FOR EFFICIENCY THE STANDARD MODE OF RUNNING IS UNINTERRUPTABLE.
\r
21174 ; WITH EXPLICIT CHECKS FOR PENDING INTERRUPTS. THE INTGO MACRO
\r
21175 ; PERFORMS THE APPROPRIATE CHECK
\r
21177 ; FOR INTERRUPTS TO WORK IN INTERRUPTABLE CODE, IT MUST
\r
21178 ; BE ABSOLUTELY PURE. BETWEEN ANY TWO INSTRUCTIONS OF
\r
21179 ; INTERRUPTABLE CODE THERE MAY BE AN INTERUPT IN WHICH
\r
21180 ; A COMPACTING GARBAGE COLLECTION MAY OCCUR.
\r
21181 ; NOTE: A SCRATCH AC MAY CONTAIN POINTERS TO GC SPACE IN
\r
21182 ; INTERRUPTABLE CODE OR DURING AN INTGO IF THE TYPE CODE FOR THAT AC'S
\r
21183 ; SLOT IN THE PROCESS VECTOR IS SET TO REFLECT ITS CONTENTS.
\r
21185 ; ALL ATOM POINTERS WILL BE REFERRED TO IN ASSEMBLED CODE BY
\r
21186 ; MQUOTE <PNAME> -- FOR NORMAL ATOMS
\r
21187 ; EQUOTE <PNAME> -- FOR ERROR COMMENT ATOMS
\r
21189 ; FUNCTION CALLS TO INITIAL FUNCTIONS WILL BE CALLED USING THE FOLLOWING:
\r
21191 ; MCALL N,<PNAME> ;SEE MCALL MACRO
\r
21192 ; ACALL AC,<PNAME> ; SEE ACALL MACRO
\r
21194 ; UNLESS PNAME IS NOT A VALID MIDAS SYMBOL, IN WHICH CASE ANOTHER INTERNAL
\r
21195 ; NAME WILL BE USED
\r
21197 ; WHEN CALLING A SUBR THROUGH AN INDEX OR INDIRECT, THE UUOS GENERATED
\r
21198 ; BY THE MACROS SHOULLD BE USED.
\r
21199 ; THESE ARE .MCALL AND .ACALL -- EXAMPLE:
\r
21206 \f; ORGANIZATION OF CORE STORAGE IN THE MUDDLE SYSTEM (ENVIRONMENT)
\r
21208 ; 20: SPECIAL CODE FOR UUO AND INTERUPTS
\r
21210 ;CODBOT: WORD CONTAINING LOCATION OF BOTTOMMOST WORD OF IMPURE CODE
\r
21212 ; --IMPURE CODE--
\r
21214 ;CODTOP: WORD CONTAINING LOCATION OFWORD AFTER LAST WORD OF CODE
\r
21216 ;PARBOT: WORD CONTAINING LOCATION OFBOTTOMMOST LIST
\r
21220 ;PARTOP: WORD CONTAINING LOCATION OFWORD AFTER LAST PAIR WORD
\r
21222 ;VECBOT: WORD CONTAINING LOCATION OFFIRST WORD OF VECTORS
\r
21226 ;VECTOP: WORD CONTAINING LOCATION OFWORD AFTER TOPMOST VECTOR
\r
21227 ; THE WORD BEFORE VECTOP IS THE DOPE FOR THE LAST VECTOR
\r
21229 ; --GC MARK PDL (SOMETIMES NOT THERE)--
\r
21231 ;CORTOP: TOP OF LOW-SEGMENT/IMPURE CORE
\r
21233 ;600000: START OF PURE CODE (SHARED ALSO)
\r
21240 \f; BASIC DATA TYPES PRE-DEFINED IN MUDDLE
\r
21242 ; PRIMITIVE DATA TYPES
\r
21243 ; IF T IS A DATA TYPE THEN $T=[T,,0]
\r
21245 ; DATA TYPES ARE ASSIGNED BY THE TYPMAK MACRO IN SOME ARBITRARY ORDER
\r
21248 ;TLOSE ;ILLEGAL TYPE (USED PRIMARILY FOR ERRORS)
\r
21249 ;TFIX ;FIXED POINT
\r
21250 ;TFLOAT ;FLOATING POINT
\r
21251 ;TCHRS ;WORD OF UP TO 5 ASCII CHARACTERS
\r
21252 ;TENTRY ; MARKS BEGINNING OF A FRAME ON TP STACK
\r
21253 ;TSUBR ;BUILT IN FUNCTION WITH EVALUATED ARGS
\r
21254 ;TFSUBR ;BUILT IN FUNCTION WITH UN-EVALUATED ARGS
\r
21255 ;TUNBOU ;TYPE GIVEN TO UNBOUND OR UNASSIGNED ATOM
\r
21256 ;TBIND ;MARKS BEGINNING OF BINDING BLOCK ON TP STACK
\r
21257 ;TILLEG ;POINTER PREVIOUSLY HERE NOW ILLEGAL
\r
21258 ;TTIME ;UNIQUE NUMBER (SEE FLOAD)
\r
21259 ;TLIST ;POINTER TO LIST ELEMENT
\r
21260 ;TFORM ;POINTER TO LIST ELEMENT BUT USED AS AN EXPRESSION
\r
21261 ;TSEG ;SAME AS FORM BUT VALUE IS MUST BE STRUCTURED AND IS USED
\r
21263 ;TEXPR ;POINTER TO LIST ELEMENT BUT USED AS AN INTERPRETIVE FUNCTION
\r
21264 ;TFUNAR ;LIKE TEXPR BUT HAS PARTIALLY EVALUATED ARGS
\r
21265 ;TLOCL ;LOCATIVE TO LIST ELEMENT (SEE AT,IN AND SETLOC)
\r
21266 ;TFALSE ;NOT TRUTH
\r
21267 ;TDEFER ;POINTER TO REAL VALUE (ONLY APPEARS AS CAR OF LIST)
\r
21268 ;TUVEC ;AOBJN POINTER TO UNIFORM VECTOR
\r
21269 ;TOBLS ;AOBJN TO UVEC OF LISTS OF ATOMS. USED AS SYMBOL TABLE
\r
21270 ;TVEC ;VECTOR (AOBJN POINTER TO GENERALIZED VECTOR)
\r
21271 ;TCHAN ;VECTOR OF INFO DESCRIBING AN I/O CHANNEL
\r
21272 ;TLOCV ;LOCATIVE TO GENERAL VECTOR (SEE AT,IN AND SETLOC)
\r
21273 ;TTVP ;POINTER TO TRANSFER VECTOR
\r
21274 ;TBVL ;BEGINS A VECTOR BINDING ON THE TP STACK
\r
21275 ;TTAG ;VECTOR OF INFO SPECIFYING A GENERALIZED TAG
\r
21276 ;TPVP ;POINTER TO PROCESS VECTOR
\r
21277 ;TLOCI ;POINTER TO ATOM VALUE ON STACK (INTERNAL NOT SEEN BY USER)
\r
21278 ;TTP ;POINTER TO MAIN MARKED STACK
\r
21279 ;TSP ;POINTER TO CURRENT BINDINGS ON STACK
\r
21280 ;TLOCS ;LOCATIVE TO STACK (NOT CURRENTLY USED)
\r
21281 ;TPP ;POINTER TO PLANNER PDL (NOT CURRENTLY USED)
\r
21282 ;TPLD ;POINTER TO P-STACK (UNMARKED)
\r
21283 ;TARGS ;POINTER TO AN ARG BLOCK (HAIRY KLUDGE)
\r
21284 ;TAB ;SAVED AB (NOT GIVEN TO USER)
\r
21285 ;TTB ;SAVED TB (NOT GIVEN TO USER)
\r
21286 ;TFRAME ;USER POINTER TO STACK FRAME
\r
21287 ;TCHSTR ;BYTE POINTER TO STRING OF CHARS (COUNT ALSO INCLUDED)
\r
21288 ;TATOM ;POINTER TO ATOM
\r
21289 ;TLOCD ;USER LOCATIVE TO ATOM VALUE
\r
21290 ;TBYTE :POINTER TO ARBITRARY BYTE STRING (NOT CURRENTLY USED)
\r
21291 ;TENV ;USER POINTER TO FRAME USED AS AN ENVIRONMENT
\r
21292 ;TACT ;USER POINTER TO FRAME FOR A NAMED ACTIVATION
\r
21293 ;TASOC ;ASSOCIATION TRIPLE
\r
21294 ;TLOCU ;LOCATIVE TO UVECTOR ELEMENT (SEE AT,IN AND SETLOC)
\r
21295 ;TLOCS ;LOCATIVE TO A BYTE IN A CHAR STRING (SEE AT,IN AND SETLOC)
\r
21296 ;TLOCA ;LOCATIVE TO ELEMENT IN ARG BLOCK
\r
21301 ;TINFO ;POINTER TO LIST ELEMENT USED WITH ARG POINTERS
\r
21304 ;TCSUBR ;CARE SUBR (USED ONLY WITH CUDDLE SEE -- WJL)
\r
21305 ;TWORD ;36-BIT WORD
\r
21306 ;TRSUBR ;COMPILED PROGRAM (ACTUALLY A VECTOR POINTER)
\r
21307 ;TCODE ;UNIFORM VECTOR OF INSTRUCTIONS
\r
21308 ;TCLIST ;NOT USED
\r
21309 ;TBITS ;GENERAL BYTE POINTER
\r
21310 ;TSTORA ;POINTER TO NON GC IMPURE STUFF
\r
21311 ;TPICTU ;E&S CODE IN NON GC SPACE
\r
21312 ;TSKIP ;ENVIRONMENT SPLICE
\r
21313 ;TLINK ;LEXICAL LINK
\r
21314 ;TINTH ;INTERRUPT HEADER
\r
21315 ;THAND ;INTERRUPT HANDLER
\r
21316 ;TLOCN ;LOCATIVE TO ASSOCIATION
\r
21317 ;TDECL ;POINTER TO LIST OF ATOMS AND TYPE DECLARATIONS
\r
21318 ;TDISMI ;TYPE MEANING DONT RUN REST OF HANDLERS
\r
21319 ;TDCLI ; INTERNAL TYPE FOR SAVED FUNCTION BODY
\r
21320 ;TMENT ; POINTER TO MAIN ENTRY OF WHICH THIS IS PART
\r
21321 ;TENTER ; NON-MAIN ENTRY TO AN RSUBR
\r
21322 ;TSPLICE ; RETURN FROM READ MACRO MEANS SPLICE SUBELEMENTS IN
\r
21323 ;TPCODE ; PURE CODE POINTER IN FUNNY FORMAT
\r
21324 ;TTYPEW : TYPE WORD
\r
21325 ;TTYPEC ; TYPE CODE
\r
21326 ;TGATOM ; ATOM WITH GVALUE
\r
21327 ;TREADA ; READ ACTIVATION HACK
\r
21328 ;TUNWIN ; INTERNAL FOR UNWIND SPEC ON STACK
\r
21329 ;TUBIND ; BINDING OF UNSPECIAL ATOM
\r
21330 ;TMACRO ; EVAL MACRO
\r
21332 ; STORGE ALLOCATION TYPES. ALLOCATED BY AN "IRP" LATER IN THIS FILE
\r
21335 ;S1WORD ;UNMARKED STUFF OF NO INTEREST TO AGC
\r
21336 ;S2WORD ;POINTERS TO ELEMENTS IN PAIR SPACE (LIST, FORM, EXPR ETC.)
\r
21337 ;S2DEFR ;DEFERRED LIST VALUES
\r
21338 ;SNWORD ;POINTERS TO UNIFORM VECTORS
\r
21339 ;S2NWOR ;POINTERS TO GENERAL VECTORS
\r
21340 ;STPSTK ;STACK POINTERS
\r
21341 ;SPSTK ;UNMARKED STACK POINTERS
\r
21342 ;SARGS ;POINTERS TO ARG BLOCKS (USER)
\r
21343 ;SABASE ;POINTER TO ARG BLOCK (INTERNAL)
\r
21344 ;STBASE ;POINTER TO FRAME (INTERNAL)
\r
21345 ;SFRAME ;POINTER TO FRAME (USER)
\r
21346 ;SBYTE ;GENERAL BYTE POINTER
\r
21347 ;SATOM ;POINTER TO ATOM
\r
21348 ;SLOCID ;POINTER TO VALUE CELL OF ATOM
\r
21349 ;SPVP ;PROCESS VECTORS
\r
21350 ;SCHSTR ;ASCII BYTE POINTER
\r
21351 ;SASOC ;POINTER TO ASSOCIATION BLOCK
\r
21352 ;SINFO ;LIST CELL CONTAINING EXTRA ARGBLOCK INFO
\r
21353 ;SSTORE ;NON GC STORGAGE POINTER
\r
21354 ;SLOCA ;ARG BLOCK LOCATIVE
\r
21355 ;SLOCD ;USER VALUE CELL LOCATIVE
\r
21356 ;SLOCS ;LOCATIVE TO STRING
\r
21357 ;SLOCU ;LOCATIVE TO UVECTOR
\r
21358 ;SLOCV ;LOCATIVE TO GENERAL VECTOR
\r
21359 ;SLOCL ;LOCATIVE TO LIST ELEENT
\r
21360 ;SLOCN ;LOCATIVE TO ASSOCIATION
\r
21361 ;SGATOM ;REALLY ATOM BUT SPECIAL GC HACK
\r
21363 ;NOTE: TO FIND OUT IF A GIVEN STORAGE ALLOCATION TYPE NEEDS TO BE DEFERRED, REFER TO
\r
21364 ;LOCATION "MKTBS:" OFFSET BY THE STORAGE TYPE. IF IT IS <0, THAT SAT NEEDS TO BE DEFERRED.
\r
21366 ;ONE WAY TO DO THIS IS TO PUT A REAL TYPE CODE IN AC A AND PUHSJ P,NWORDT
\r
21367 ; A WILL CONTAIN 1 IF NO DEFERRED NEEDED OR 2 IF DEFER IS NEEDED
\r
21369 \f; SOME MUDDLE DATA FORMATS
\r
21371 ; FORMAT OF LIST ELEMENT
\r
21373 ; WORD 1: SIGN BIT, RESERVED FOR GARBAGE COLLECTOR
\r
21374 ; BITS 1-17 TYPE OF FIRST ELEMENT OF LIST
\r
21375 ; BITS 18-35 POINTS TO REST OF LIST (ALWAYS ANOTHER LIST OR 0)
\r
21377 ; WORD 2: DATUM OF FIRST ELEMENT OF LIST OF TYPE SPECIFIED
\r
21379 ; IF DATUM REQUIRES 54 BITS TO SPECIFY, TYPE WILL BE "TDEFER" AND
\r
21380 ; VALUE WILL BE AN 18 BIT POINTER TO FULL 2 WORD PAIR
\r
21384 ;FORMAT OF GENERAL VECTOR (OF N ELEMENTS)
\r
21385 ;POINTED INTO BY AOBJN POINTER
\r
21386 ;A GENERAL VECTOR HAS FEWER THAN 2^16 ELEMENTS
\r
21389 ; TYPE<1> TYPE OF FIRST OBJECT (THE RIGHT HALF OF THE TYPE WORD MIGHT BE NONZERO)
\r
21390 ; OBJ<1> OBJECT OF SPECIFIED TYPE
\r
21398 ; VD(1)-VECTOR DOPE--SIGN-NOT UNIFORM, BITS 1-17 TYPE,,18-35 GROWTH/SHRINKAGE
\r
21399 ; VD(2)-VECTOR DOPE--SIGN-G.C.; BITS 1-17 ARE 2*N+1,,18-35 G.C. RELOCATION EITHER UP OR DOWN
\r
21402 \f;SPECIAL VECTORS IN THE INITIAL SYSTEM
\r
21404 ;THE SYSTEM KEEPS RELEVANT INFORMATION CONCERNING ALL TYPES
\r
21405 ;IN A TYPE VECTOR, TYPVEC, WHICH MAY BE INDEXED BY THE TYPE NUMBER
\r
21406 ;FOUND IN THE TYPE FIELD OF ANY GOODIE. TABLES APLTYP AND EVLTYP ALSO EXIST
\r
21407 ;THEY SPECIFY HOW DIFFERENT TYPES EVAL AND APPLY.
\r
21409 ;TYPE IN AC A, PUSHJ P,SAT RETURNS STORAGE TYPE IN A
\r
21411 ;TYPE TO NAME OF TYPE TRANSLATION TABLE
\r
21413 ; TATOM,,<STORAGE ALLOCATION TYPE>+CHBIT+TMPLBT
\r
21417 ; CHBIT ON MEANS YOU CANT RANDOMLY CHTYPE INTO THIS TYPE
\r
21418 ; TMPLBT ON MEANS A TEMPLATE EXISTS DESCRIBING THIS
\r
21420 ;AN ATOM IS A BLOCK IN VECTOR SPACE WITH THE FOLLOWING FORMAT
\r
21422 ; <TUNBOU OR TLOCI>,,<0 OR BINDID> ; TLOCI MEANS VAL EXISTS.
\r
21424 ; ; BINDID SPECS ENV IN
\r
21425 ; WHICH LOCAL VAL EXISTS
\r
21426 ; <LOCATIVE TO VALUE OR 0>
\r
21427 ; <POINTER TO OBLIST OR 0>
\r
21428 ; <ASCII /PNAME/>
\r
21429 ; <400000+SATOM,,0>
\r
21430 ; <LNTH>,,0 (SIGN BIT FOR G.C. RH FOR G.C. RELOCATION)
\r
21432 ;POINTERS TO INITIAL STRUCTURES AND ATOMS NEEDED BY COMPILED CODE
\r
21433 ;WILL BE POINTED TO BY THE TRANSFER VECTOR
\r
21434 ;A POINTER TO THIS VECTOR ALWAYS EXISTS IN AC TVP
\r
21435 ;THE FORMAT OF THIS VECTOR IS:
\r
21445 ;INFORMATION CONCERNING EACH PROCESS IS KEPT IN THE PROCESS VECTOR
\r
21446 ;A POINTER TO THE CURRENT PROCESS ALWAYS EXISTS IN AC PVP
\r
21447 ;THE FORMAT OF A PROCESS VECTOR IS:
\r
21450 ; PROCID ;UNIQUE ID OF THIS PROCESS
\r
21452 ; 20 ELEMENTS (I.E. 40 WORDS) CONTAINIG SAVED ACS
\r
21453 ; CAN BE REFERENCED SYMBOLICALLY USING SYMBOLS
\r
21454 ; OF THE FORM AC!STO(PVP)
\r
21456 ; OTHER PROCESS LOCAL INFO LIKE LEXICAL STATE, PROCESS STATE,LAST RESUMER
\r
21465 ;FORMAT OF PUSH DOWN STACKS USED AND CONVENTIONS
\r
21468 PRINTC /MUDDLE - INSERT FILE FOR ALL PROGRAMS
\r
21472 IF2 [PRINTC /MUDDLE
\r
21477 P"=17 ;THE UNMARKED PDL POINTER (USED BY THE OUTSIDE WORLD AND MUDDLE)
\r
21478 R"=16 ;REFERENCE BASE FOR RSUBRS
\r
21479 M"=15 ;CODE BASE FOR RSUBRS
\r
21480 SP"=14 ;SPECIAL PDL (USED BY MUDDLE FOR VARIABLE BINDINGS)(SPECIAL PDL IS PART OF TP)
\r
21481 TP"=13 ;MARKED PDL (USED BY MUDDLE FOR ARGS TO FUNCTIONS
\r
21482 ;AND MARKED TEMPORARIES)
\r
21483 TB"=12 ;MARKED PDL BASE POINTER AND CURRENT FRAME POINTER
\r
21484 AB"=11 ;ARGUMENT PDL BASE (MARKED)
\r
21485 ;AB IS AN AOBJN POINTER TO THE ARGUMENTS
\r
21486 TVP"=7 ;TRANSFER VECTOR POINTER
\r
21487 PVP"=6 ;PROCESS VECTOR POINTER
\r
21489 ;THE FOLLOWING ACS ARE 'SCRATCH' FOR MUDDLE
\r
21491 A"=1 ; A AND B CONTAIN TYPE AND VALUE UPON FUNCTION RETURNS
\r
21497 NIL"=0 ;END OF LIST MARKER
\r
21499 ;MACRO TO DEFINE MAIN IF NOT DEFINED
\r
21504 IFE <<<.AFNM1>_-24.>-<SIXBIT / T./>>,ITS==0
\r
21505 IFN ITS,[PRINTC /ITS VERSION
\r
21507 IFE ITS,[PRINTC /TENEX VERSION
\r
21512 DEFINE DEFMAI ARG,\D
\r
21514 IFE <D-17>,ARG==0
\r
21522 IF2,EXPUNGE DEFMAI
\r
21524 \f;DEFINE TYPES AND $TYPES AND IF MAIN NOT 0, MAKE THE $TYPE WORDS
\r
21527 IFN MAIN,NUMPRI==-1
\r
21530 NUMPRI==-1 ;NUMBER OF PRIMITIVE TYPES
\r
21532 DEFINE TYPMAK SAT,LIST
\r
21538 IFN MAIN,[$!T!B=[T!B,,0]
\r
21543 RMT [ADDTYP SAT,A
\r
21548 ;MACRO TO ADD STUFF TO TYPE VECTOR
\r
21551 DEFINE ADDTYP SAT,TYPE,NAME,CHF,\CH
\r
21553 IFSN [CHF],CH==CHBIT
\r
21554 IFSE [NAME]IN,CH==CHBIT
\r
21557 IFSN [NAME],[IFSE [NAME]IN,MQUOTE INTERNAL
\r
21558 IFSN [NAME]IN,MQUOTE [NAME]
\r
21560 IFSE [NAME],MQUOTE TYPE
\r
21569 IF2 [IFE MAIN,[DEFINE TYPMAK SAT,LIST
\r
21570 RMT [EXPUN [LIST]
\r
21576 ;DEFINE THE STORAGE ALLOCATION TYPES IN THE WORLD
\r
21580 GENERAL==400000,,0 ;FLAG FOR BEING A GENERAL VECTOR
\r
21583 DEFINE PRMACR HACKER
\r
21585 IRP A,,[1WORD,2WORD,2DEFRD,NWORD,2NWORD,TPSTK,PSTK,ARGS
\r
21586 ABASE,TBASE,FRAME,BYTE,ATOM,LOCID,PVP,CHSTR,ASOC,INFO,STORE
\r
21587 LOCA,LOCD,LOCS,LOCU,LOCV,LOCL,LOCN,GATOM,LOCT]
\r
21606 ;MACRO FOR SAVING STUFF TO DO LATER
\r
21610 DEFINE HERE G00002,G00003
\r
21611 G00002!G00003!TERMIN
\r
21615 HERE [DEFINE HERE G00002,G00003
\r
21616 G00002!][A!G00003!TERMIN]
\r
21621 RMT [EXPUNGE GENERAL,NUMSTA
\r
21629 RMT [PRMACR XPUNGR
\r
21639 ; FLAG INDICATING VECTOR FOR GCHACK
\r
21643 ; DEFINE SYMBLOS FOR VARIOUS OBLISTS
\r
21645 SYSTEM==0 ;MAIN SYSTEM OBLIST
\r
21646 ERRORS==1 ;ERROR COMMENT OBLIST
\r
21647 INTRUP==2 ;INERRUPT OBLIST
\r
21648 MUDDLE==3 ;MUDDLE GLOBAL SYMBOLS (ADDRESSES)
\r
21650 RMT [EXPUNGE SYSTEM,ERRORS,INTRUP
\r
21652 ; DEFINE SYMBOLS FOR PROCESS STATES
\r
21660 IFE MAIN,[RMT [EXPUNGE RESMBL,RUNABL,RUNING,DEAD,BLOCKED
\r
21662 ]
\f;BUILD THE TYPE CODES AND ADD STUFF TO TYPVEC AND DEFINE $!TYPE)
\r
21664 IFN MAIN,[RMT [SAVE==.
\r
21670 TYPMAK S1WORD,[[LOSE],FIX,FLOAT,[CHRS,CHARACTER],[ENTRY,IN],[SUBR,,1],[FSUBR,,1]]
\r
21671 TYPMAK S1WORD,[[UNBOUND,,1],[BIND,IN],[ILLEGAL,,1],TIME]
\r
21672 TYPMAK S2WORD,[LIST,FORM,[SEG,SEGMENT],[EXPR,FUNCTION],[FUNARG,CLOSURE]]
\r
21673 TYPMAK SLOCL,[LOCL]
\r
21674 TYPMAK S2WORD,[FALSE]
\r
21675 TYPMAK S2DEFRD,[[DEFER,IN]]
\r
21676 TYPMAK SNWORD,[[UVEC,UVECTOR],[OBLS,OBLIST,-1]]
\r
21677 TYPMAK S2NWORD,[[VEC,VECTOR],[CHAN,CHANNEL,1]]
\r
21678 TYPMAK SLOCV,[LOCV]
\r
21679 TYPMAK S2NWORD,[[TVP,IN],[BVL,IN],[TAG,,1]]
\r
21680 TYPMAK SPVP,[[PVP,PROCESS]]
\r
21681 TYPMAK STPSTK,[[LOCI,IN],[TP,IN],[SP,IN],[LOCS,IN]]
\r
21682 TYPMAK S2WORD,[[MACRO]]
\r
21683 TYPMAK SPSTK,[[PDL,IN]]
\r
21684 TYPMAK SARGS,[[ARGS,TUPLE]]
\r
21685 TYPMAK SABASE,[[AB,IN]]
\r
21686 TYPMAK STBASE,[[TB,IN]]
\r
21687 TYPMAK SFRAME,[FRAME]
\r
21688 TYPMAK SCHSTR,[[CHSTR,STRING]]
\r
21689 TYPMAK SATOM,[ATOM]
\r
21690 TYPMAK SLOCID,[LOCD]
\r
21691 TYPMAK SBYTE,[BYTE]
\r
21692 TYPMAK SFRAME,[[ENV,ENVIRONMENT],[ACT,ACTIVATION,1]]
\r
21693 TYPMAK SASOC,[ASOC]
\r
21694 TYPMAK SLOCU,[LOCU]
\r
21695 TYPMAK SLOCS,[LOCS]
\r
21696 TYPMAK SLOCA,[LOCA]
\r
21697 TYPMAK S1WORD,[[CBLK,IN]]
\r
21698 TYPMAK STMPLT,[[TMPLT,TEMPLATE]]
\r
21699 TYPMAK SLOCT,[LOCT]
\r
21700 ;THE FOLLOWING TYPES (THROUGH CSUBR) CAN PROBABLY BE RECYCLED
\r
21701 TYPMAK S1WORD,[[PC,IN]]
\r
21702 TYPMAK SINFO,[[INFO,IN]]
\r
21703 TYPMAK SATOM,[[BNDS,IN]]
\r
21704 TYPMAK S2NWORD,[[BVLS,IN]]
\r
21705 TYPMAK S1WORD,[[CSUBR,,1]]
\r
21707 TYPMAK S1WORD,[[WORD]]
\r
21708 TYPMAK S2NWORD,[[RSUBR,,1]]
\r
21709 TYPMAK SNWORD,[CODE]
\r
21710 ;TYPE CLIST CAN PROBABLY BE RECYCLED
\r
21711 TYPMAK S2WORD,[[CLIST,IN]]
\r
21712 TYPMAK S1WORD,[[BITS]]
\r
21713 TYPMAK SSTORE,[STORAGE,PICTURE]
\r
21714 TYPMAK STPSTK,[[SKIP,IN]]
\r
21715 TYPMAK SATOM,[[LINK,,1]]
\r
21716 TYPMAK S2NWORD,[[INTH,IHEADER,1],[HAND,HANDLER,1]]
\r
21717 TYPMAK SLOCN,[[LOCN,LOCAS]]
\r
21718 TYPMAK S2WORD,[DECL]
\r
21719 TYPMAK SATOM,[DISMISS]
\r
21720 TYPMAK S2WORD,[[DCLI,IN]]
\r
21721 TYPMAK S2NWORD,[[ENTER,RSUBR-ENTRY,1]]
\r
21722 TYPMAK S2WORD,[SPLICE]
\r
21723 TYPMAK S1WORD,[[PCODE,PCODE,1],[TYPEW,TYPE-W,1],[TYPEC,TYPE-C,1]]
\r
21724 TYPMAK SGATOM,[[GATOM,IN]]
\r
21725 TYPMAK SFRAME,[[READA,,1]]
\r
21726 TYPMAK STBASE,[[UNWIN,IN]]
\r
21727 TYPMAK S1WORD,[[UBIND,IN]]
\r
21728 IFN MAIN,[RMT [LOC SAVE
\r
21731 IF2,EXPUNGE TYPMAK,DOTYPS
\r
21733 RMT [EQUALS XP EXPUNGE
\r
21738 DEFINE EXPUN LIST
\r
21750 MONMSK==TYPMSK#777777
\r
21756 DEFINE GETYP AC,ADR
\r
21757 LDB AC,[221500,,ADR]
\r
21760 DEFINE GETYPF AC,ADR
\r
21761 LDB AC,[003700,,ADR]
\r
21768 .GLOBAL .MONWR,.MONRD,.MONEX
\r
21769 RMT [IF2 IFE MAIN, XP .WRMON,.RDMON,.EXMON
\r
21776 IFE MAIN,[RMT [XP SATMSK,TYPMSK,MONMSK,CHBIT
\r
21779 \f;MUDDLE WIDE GLOBALS
\r
21781 ;DEFINE ENTRIES IN PROCESS VECTOR AS BEING GLOBAL
\r
21784 IRP A,,[0,A,B,C,D,E,PVP,TVP,TP,TB,AB,P,PB,SP,M,R]
\r
21788 .GLOBAL CALER1,FINIS,VECTOP,VECBOT,INTFLG
\r
21790 ;GLOBALS FOR MACROS IN VECTOR AND PAIR SPACE
\r
21792 .GLOBAL VECLOC,PARLOC,TVBASE,TVLOC,PVLOC,PVBASE,SQUTBL,SQULOC
\r
21793 .GLOBAL PARTOP,CODTOP,HITOP,HIBOT,SPECBIND,LCKINT
\r
21794 .GLOBAL GETWNA,WNA,TFA,TMA,WRONGT,WTYP,WTYP1,WTYP2,WTYP3,CALER,CALER1
\r
21798 ;STORAGE ALLOCATIN SPECIFICATION GLOBALS
\r
21800 NSUBRS==600. ; ESTIMATE OF # OF SUBRS IN WOLD
\r
21801 TPLNT"==2000 ;TEMP PDL LENGTHH
\r
21802 GSPLNT==2000 ;INITIAL GLOBAL SP
\r
21803 GCPLNT"==100. ;GARBAGE COLLECTOR'S PDL LENGTH
\r
21804 PVLNT"==100 ;LENGTH OF INITIAL PROCESS VECTOR
\r
21805 TVLNT"==6000 ;MAX TRANSFER VECTOR
\r
21806 ITPLNT"==100 ;TP FOR GC
\r
21807 PLNT"==1000 ;PDL FOR USER PROCESS
\r
21809 ;LOCATIONS OF VARIOUS STORAGE AREAS
\r
21811 PARBASE"==32000 ;START OF PAIR SPACE
\r
21812 VECBASE"==44000 ;START OF VECTOR SPACE
\r
21813 IFN MAIN,[PARLOC"==PARBASE
\r
21819 ;SYMBLOS ASSOCIATED WITH STACK FRAMES
\r
21820 ;TB POINTS TO CURRENT FRAME, THE SYMBOLS BELOW ARE OFFSETS ON TB
\r
21822 FRAMLN==7 ;LENGTH OF A FRAME
\r
21823 FSAV==-7 ;POINT TO CALLED FUNCTION
\r
21824 OTBSAV==-6 ;POINT TO PREVIOUS FRAME AND CONTAINS TIME
\r
21825 ABSAV==-5 ;ARGUMENT POINTER
\r
21826 SPSAV==-4 ;BINDING POINTER
\r
21827 PSAV==-3 ;SAVED P-STACK
\r
21828 TPSAV==-2 ;TOP OF STACK POINTER
\r
21829 PCSAV==-1 ;PCWORD
\r
21831 RMT [EXPUNGE FRAMLN
\r
21833 IFE MAIN,[RMT [EXPUNGE PCSAV TPSAV SPSAV PSAV ABSAV FSAV OTBSAV
\r
21838 ; ARGS ARE PUSHED ON THE STACK AS TYPE VALUE PAIRS
\r
21840 .GLOBAL .MCALL,.ACALL,FINIS,CONTIN,.ECALL,FATINS
\r
21842 ; CALL WITH AN ASSEMBLE TIME KNOWN NUMBER OF ARGUMENTS
\r
21847 IFGE <17-N>,.MCALL N,F
\r
21848 IFL <17-N>,[PRINTC /LOSSAGE AT MCALL - TOO MANY ARGS
\r
21854 ; CALL WITH RUN TIME KNOWN NUMBER OF ARGS IN AC SPECIFIED BY N
\r
21861 ; STANDARD SUBROUTINE RETURN
\r
21865 ; ARGUMENTS WILL NO LONGER BE ON THE STACK WHEN RETURN HAS HAPPENED
\r
21866 ; VALUE SHOULD BE IN A AND B
\r
21868 ;CHECK THAT THE ENTRY POINT WAS CALLED WITH N ARGUMENTS
\r
21878 ; MACROS ASSOCIATED WIT INTERRUPT PROCESSING
\r
21879 ;INTERRUPT IF THERE IS A WAITING INTERRUPT
\r
21886 ;TO BECOME INTERRUPTABLE
\r
21893 ;TO BECOME UNITERRUPTABLE
\r
21900 ;MACRO TO BUILD TYPE DISPATCH TABLES EASILY
\r
21902 DEFINE TBLDIS NAME,DEFAULT,LIST,LNTH
\r
21905 REPEAT LNTH+1,DEFAULT
\r
21907 IRP TYPE,LOCN,[A]
\r
21916 ; DISPATCH FOR NUMPRI GOODIES
\r
21918 DEFINE DISTBL NAME,DEFAULT,LIST
\r
21919 TBLDIS NAME,DEFAULT,[LIST]NUMPRI
\r
21922 DEFINE DISTBS NAME,DEFAULT,LIST
\r
21923 TBLDIS NAME,DEFAULT,[LIST]NUMSAT
\r
21932 ;MACROS FOR INITIIAL MUDDLE LIST STRUCTURE
\r
21934 ;CHAR STRING MAKER, RETURNS POINTER AND TYPE
\r
21937 DEFINE MACHAR NAME,TYPE,VAL,\LNT,WHERE,LAST
\r
21940 LNT==.LENGTH \NAME!\
\r
21949 ;MACRO TO DEFINE ATOMS
\r
21951 DEFINE MAKAT NAME,TYAT,VALU,OBLIS,REFER,LOCN,\TVENT,FIRST
\r
21959 TVENT==FIRST-.+2,,FIRST
\r
21960 IFSN [LOCN],LOCN==TVENT
\r
21961 ADDTV TATOM,TVENT,REFER
\r
21966 \f;MACROS TO SWITCH BACK AND FORTH INTO AND OUT OF VECTOR AND PAIR SPACE
\r
21967 ;GENERAL SWITCHER
\r
21969 DEFINE LOCSET LOCN,RETNAM,NEWLOC,OTHLOC,F1,F2,TOPWRD,\SAVE,SAVEF1,SAVEF2,NEW
\r
21974 IFN F2,OTHLOC==SAVE
\r
21978 IFE F1,[NEWLOC==.
\r
21990 IFSN LOCN,,LOCN==.
\r
21996 DEFINE VECTGO LOCN
\r
21997 LOCSET LOCN,VECRET,VECLOC,PARLOC,VECFLG,PARFLG,VECTOP
\r
22000 DEFINE PARGO LOCN
\r
22001 LOCSET LOCN,PARRET,PARLOC,VECLOC,PARFLG,VECFLG,PARTOP
\r
22004 DEFINE ADDSQU NAME,\SAVE
\r
22013 DEFINE ADDTV TYPE,GOODIE,REFER,\SAVE
\r
22016 TVOFF==.-TVBASE+1
\r
22023 ;MACRO TO ADD TO PROCESS VECTOR
\r
22025 DEFINE ADDPV TYPE,GOODIE,OFFS,\SAVE
\r
22029 IFSN OFFS,,OFFS==PVOFF
\r
22040 ;MACRO TO DEFINE A FUNCTION ATOM
\r
22042 DEFINE MFUNCTION NAME,TYPE,PNAME
\r
22047 IFSE [PNAME],MAKAT NAME,T!TYPE,NAME,SYSTEM,<NAME-1>
\r
22048 IFSN [PNAME],MAKAT [PNAME]T!TYPE,NAME,SYSTEM,<NAME-1>
\r
22052 ; VERSION OF MQUOTE WITH IMPURE BIT ON
\r
22054 DEFINE IMQUOTE ARG,PNAME,OBLIS,\LOCN
\r
22059 IFSE [PNAME],MAKAT [ARG]<400000+TUNBOU>,0,OBLIS,LOCN
\r
22061 IFSN [PNAME],MAKAT [PNAME]<400000+TUNBOU>,0,OBLIS,LOCN
\r
22065 ;MACRO TO DEFINE QUOTED GOODIE
\r
22067 DEFINE MQUOTE ARG,PNAME,OBLIS,\LOCN
\r
22072 IFSE [PNAME],MAKAT [ARG]TUNBOU,0,OBLIS,LOCN
\r
22073 IFSN [PNAME],MAKAT [PNAME]TUNBOU,0,OBLIS,LOCN
\r
22080 DEFINE CHQUOTE NAME,\LOCN,TYP,VAL
\r
22083 MACHAR [NAME]TYP,VAL
\r
22084 ADDTV TYP,VAL,LOCN
\r
22089 ; SPECIAL ERROR MQUOTE
\r
22091 DEFINE EQUOTE ARG,PNAME
\r
22092 MQUOTE ARG,[PNAME]ERRORS TERMIN
\r
22095 ; MACRO DO .CALL UUOS
\r
22097 DEFINE DOTCAL NM,LIST,\LOCN
\r
22106 IFSE [R][][<SETZ>\<Q>
\r
22112 ; MACRO TO HANDLE FATAL ERRORS
\r
22114 DEFINE FATAL MSG/
\r
22115 FATINS [ASCIZ /:
\e FATAL ERROR MSG
\e\r
22124 ;CHARACTER TABLE GENERATING MACROS
\r
22126 DEFINE SETSYM WRDL,BYTL,COD
\r
22127 WRD!WRDL==<WRD!WRDL>&<MSK!BYTL>
\r
22128 WRD!WRDL==<WRD!WRDL>\<<COD&177>_<<4-BYTL>*7+1>>
\r
22131 DEFINE INIWRD N,INIT
\r
22139 ;MACRO TO KILL THESE SYMBOLS LATER
\r
22145 MSK!N==<177_<<4-N>*7+1>>#<-1>
\r
22148 ;MACRO TO KILL MASKS LATER
\r
22154 NWRDS==<NCHARS+CHRWD-1>/CHRWD
\r
22156 REPEAT CHRWD,SETMSK \.RPCNT
\r
22158 REPEAT NWRDS,INIWRD \.RPCNT,004020100402
\r
22161 REPEAT NWRDS,OUTWRD \.RPCNT
\r
22165 ;MACRO TO GENERATE THE DUMMIES EASLILIER
\r
22167 DEFINE INITCH \DUM1,DUM2,DUM3
\r
22170 DEFINE SETCOD COD,LIST
\r
22173 DUM2==CHAR-DUM1*5
\r
22174 SETSYM \DUM1,\DUM2,COD
\r
22178 DEFINE SETCHR COD,LIST
\r
22179 IRPC CHAR,,[LIST]
\r
22182 DUM2==DUM3-DUM1*5
\r
22183 SETSYM \DUM1,\DUM2,COD
\r
22187 DEFINE INCRCO OCOD,LIST
\r
22190 DUM2==CHAR-DUM1*5
\r
22191 SETSYM \DUM1,\DUM2,\<OCOD+.IRPCN>
\r
22195 DEFINE INCRCH OCOD,LIST
\r
22196 IRPC CHAR,,[LIST]
\r
22199 DUM2==DUM3-DUM1*5
\r
22200 SETSYM \DUM1,\DUM2,\<OCOD+.IRPCN>
\r
22203 RMT [EXPUNGE DUM1,DUM2,DUM3
\r
22204 REPEAT NWRDS,KILLWD \.RPCNT
\r
22205 REPEAT CHRWD,KILMSK \.RPCNT
\r
22213 ;REDEFINE END DO ALL THE REMOTES (ON LAST PASS ONLY)
\r
22239 IF2 EXPUNGE PARFLG,VECFLG,CHRWD,NN,NUMPRI,PURITY,EAD,ACD,PUSHED
\r
22240 IF2 EXPUNGE INSTNT,DUMMY1,PRIM,PPLNT,GSPLNT,MEDIAT
\r
22245 ;MACROS TO PRINT VERSIONS OF PROGRAMS DURING ASSEMBLY
\r
22248 DEFINE NUMGEN SYM,\REST,N
\r
22252 IFN N,IFGE <31-N>,IFGE <N-20>,TOTAL==TOTAL*10.+<N-20>
\r
22253 IFN NN,NUMGEN REST
\r
22258 PRINTC /VERSION = N
\r
22277 DEFINE VATOM SYM,\LOCN,TV,A,B
\r
22283 A==<<<<SYM_-30.>&77>+40>_29.>
\r
22284 B==<<SYM_-24.>&77>
\r
22285 IFN B,A==A+<<B+40>_22.>
\r
22286 B==<<SYM_-18.>&77>
\r
22287 IFN B,A==A+<<B+40>_15.>
\r
22288 B==<<SYM_-12.>&77>
\r
22289 IFN B,A==A+<<B+40>_8.>
\r
22290 B==<<SYM_-6.>&77>
\r
22291 IFN B,A==A+<<B+40>_1.>
\r
22293 IFN <SYM&77>,<<SYM&77>+40>_29.
\r
22296 TV==LOCN-.+2,,LOCN
\r
22301 ;VATOM .FNAM1 ;"HACK REMOVED FOR EFFICIENCY"
\r
22304 ;MACRO TO REMMVE SYMBOLS OF THE FORM "GXXXXX"
\r
22306 DEFINE GEXPUN \SYM
\r
22309 NUMGEN \<SIXBIT /SYM!/>
\r
22321 DEFINE ..LOC NEW,OLD
\r
22322 .LIFS .LPUR"+.LIMPU"
\r
22335 ; PURE - MACRO TO SWITCH LOADING TO PURE CORE.
\r
22338 IFE PURITY-1, ..LOC .LPUR,.LIMPU
\r
22342 ; IMPURE - MACRO TO SWITCH LOADING TO IMPURE CORE.
\r
22345 IFE PURITY, ..LOC .LIMPU,.LPUR
\r
22351 TITLE MUDEX -- TENEX DEPENDANT MUDDLE CODE
\r
22362 .GLOBAL %SSNAM,%RSNAM,%KILLM,%LOGOU,%SLEEP,%VALRE,NOTTY,MSGTYP,TTYOP2
\r
22363 .GLOBAL %UNAM,%JNAM,%RUNAM,%RJNAM,%GCJOB,%SHWND,%SHFNT,%GETIP,%INFMP
\r
22364 .GLOBAL GCHN,WNDP,FRNP,MESSAG,INITFL,6TOCHS,SGSNAM,MTYO,PGINT,WHOAMI
\r
22365 .GLOBAL %TOPLQ,IBLOCK,TMTNXS,TNXSTR,%HANG,ILLUUO,UUOH,IPCINI,CTIME,BFLOAT
\r
22369 WRTP==1000,,100000
\r
22371 CRJB==1000,,400001
\r
22375 CTIME: JOBTM ; get run time in milli secs
\r
22377 JSP A,BFLOAT ; Convert to floating
\r
22378 FDVRI B,(1000.0) ; Change to units of seconds
\r
22382 ; SET THE SNAME GLOBALLY
\r
22386 ; READ THE GLOBAL SNAME
\r
22390 ; KILL THE CURRENT JOB
\r
22395 ; PASS STRING TO SUPERIOR (MONITOR?)
\r
22400 ; LOGOUT OF SYSTEM (MUST BE "TOP LEVEL")
\r
22405 ; GO TO SLEEP A WHILE
\r
22407 %SLEEP: IMULI A,33. ; TO MILLI SECS
\r
22423 ; HERE TO SEE IF WE ARE A TOP LEVEL JOB
\r
22430 ; GET AN INFERIOR FOR THE GARBAGE COLLECTOR
\r
22433 MOVEI A,200000 ; GET BITS FOR FORK
\r
22434 CFORK ; MAKE AN IFERIOR FORK
\r
22435 FATAL CANT GET GC FORK
\r
22436 MOVEM A,GCFRK ; SAVE HANDLE
\r
22437 POP P,A ; RESTORE PAGE
\r
22438 PUSHJ P,%GETIP ; GET IT THERE
\r
22440 JRST %SHFNT ; AND FRONTIER
\r
22442 ; HERE TO GET A PAGE FOR THE INFERIOR
\r
22446 ; HERE TO SHARE WINDOW
\r
22448 %SHWND: TDZA 0,0 ; FLAG SAYING WINDOW
\r
22450 ; HERE TO SHARE FRONTIER
\r
22452 %SHFNT: MOVEI 0,1
\r
22456 MOVEI B,2*FRNP ; FRONTIER (REMEMBER TENEX PAGE SIZE)
\r
22458 MOVEI B,2*WNDP ; NO,WINDOW
\r
22460 ASH A,1 ; TIMES 2
\r
22462 MOVSI C,140000 ; READ AND WRITE ACCESS
\r
22468 ASH B,9. ; POINT TO PAGE
\r
22469 MOVES (B) ; CLOBBER TOP
\r
22470 MOVES -1(B) ; AND UNDER
\r
22476 ; HERE TO MAP INFERIOR BACK AND KILL SAME
\r
22483 MOVE D,A ; POINT TO PAGES
\r
22484 MOVE E,B ; FOR COPYING
\r
22485 PUSH P,A ; SAVE FOR TOUCHING
\r
22488 MOVSI C,120400 ; READ AND WRITE COPY
\r
22496 ; HERE TO TOUCH PAGES TO INSURE KEEPING THEM (KLUDGE)
\r
22498 POP P,E ; RESTORE MY FIRST PAGE #
\r
22499 MOVEI A,(E) ; COPY FOR LOOP
\r
22500 ASH A,9. ; TO WORD ADDR
\r
22501 MOVES (A) ; WRITE IT
\r
22502 AOBJN E,.-3 ; FOR ALL PAGES
\r
22511 ; HACK TO PRINT MESSAGE OF INTEREST TO USER
\r
22513 MESOUT: MOVSI A,(JFCL)
\r
22514 MOVEM A,MESSAG ; DO ONLY ONCE
\r
22516 MOVE B,[1,,ILLUUO]
\r
22517 MOVE C,[40,,UUOH]
\r
22519 SETZ SP, ; HACK TO AVOID LOSSAGE WITH GARBAGE IN SP FIRST TIME
\r
22521 PUSHJ P,PGINT ; INITIALIZE PAGE MAP
\r
22524 SKIPE NOTTY ; HAVE A TTY?
\r
22525 JRST RESNM ; NO, SKIP THIS STUFF
\r
22531 MOVE B,[70000,,200000]
\r
22536 MOVE D,B ; SAVE BYTE
\r
22554 -1,,[ASCIZ /DSK/]
\r
22555 -1,,[ASCIZ /VEZZA/]
\r
22556 -1,,[ASCIZ /MUDDLE/]
\r
22557 -1,,[ASCIZ /MESSAG/]
\r
22562 MUDINT: MOVSI 0,(JFCL) ; CLOBBER MUDDLE INIT SWITCH
\r
22565 GJINF ; GET INFO NEEDED
\r
22566 PUSHJ P,TMTNXS ; MAKE A TEMP STRING FOR TENEX INFO (POINTER LEFT IN E)
\r
22567 HRROI A,1(E) ; TNX STRING POINTER
\r
22569 FATAL ATTACHED DIR DOES NOT EXIST
\r
22570 MOVEI B,1(E) ; NOW HAVE BOUNDS OF STRING
\r
22571 SUBM P,E ; RELATIVIZE E
\r
22572 PUSHJ P,TNXSTR ; MAKE THE STRING
\r
22575 PUSH TP,IMQUOTE SNM
\r
22580 PUSH TP,CHQUOTE READ
\r
22582 PUSH TP,CHQUOTE MUDDLE.INIT
\r
22589 MOVEI B,INITSTR ; TELL USER WHAT'S HAPPENING
\r
22597 TMTNXS: POP P,D ; SAVE RET ADDR
\r
22598 MOVE E,P ; BUILD A STRING SPACE ON PSTACK
\r
22599 MOVEI 0,20. ; USE 20 WORDS (=100 CHARS)
\r
22606 TNXSTR: SUBI B,(P)
\r
22609 SUBI B,(A) ; WORDS TO B
\r
22610 IMULI B,5 ; TO CHARS
\r
22611 LDB 0,[360600,,A] ; GET BYTE POSITION
\r
22612 IDIVI 0,7 ; TO A REAL BYTE POSITION
\r
22615 SUBM 0,B ; FINAL LENGTH IN BYTES TO B
\r
22616 PUSH P,B ; SAVE IT
\r
22617 MOVEI A,4(B) ; TO WORDS
\r
22619 PUSHJ P,IBLOCK ; GET STRING
\r
22623 MOVE D,B ; COPY POINTER
\r
22624 MOVE 0,(C) ; GET A WORD
\r
22630 HRLI B,440700 ; MAKE INTO BYTER
\r
22638 SETZ [SIXBIT /MUDSTA/]
\r
22640 INITSTR: ASCIZ /MUDDLE INIT/
\r
22647 MESSDM: 30,,(SIXBIT /IPC/)
\r
22649 SIXBIT /MUDDLESTATIS/
\r
22654 MESSAG: PUSHJ P,MESOUT ; MESSAGE SWITCH
\r
22656 INITFL: PUSHJ P,MUDINT ; MUDDLE INIT SWITCH
\r
22662 TITLE SQUOZE TABLE HANDLER FOR MUDDLE
\r
22668 .GLOBAL SQUPNT,ATOSQ,SQUTOA
\r
22670 ; POINTER TO TABLE FILLED IN BY INITM
\r
22674 ; GIVEN LOCN OF SUBR RET SQUO NAME ARG AND VAL IN E
\r
22678 MOVE A,SQUPNT ; GET TABLE POINTER
\r
22688 ATOSQ1: MOVE E,(A)
\r
22692 ; BINARY SEARCH FOR SQUOZE SYMBOL ARG IN E
\r
22698 MOVE A,SQUPNT ; POINTER TO TABLE
\r
22701 HRLI B,(B) ; B IS CURRENT OFFSET
\r
22703 UP: ASH B,-1 ; HALVE TABLE
\r
22704 AND B,[-2,,-2] ; FORCE DIVIS BY 2
\r
22705 MOVE C,A ; COPY POINTER
\r
22706 JUMPLE B,LSTHLV ; CANT GET SMALLER
\r
22708 CAMLE E,(C) ; SKIP IF EITHER FOUND OR IN TOP
\r
22709 MOVE A,C ; POINT TO SECOND HALF
\r
22710 CAMN E,(C) ; SKIP IF NOT FOUND
\r
22712 CAML E,(C) ; SKIP IF IN TOP HALF
\r
22714 HLLZS C ; FIX UP OINTER
\r
22718 WON: MOVE E,1(C) ; RET VAL IN E
\r
22719 AOS -3(P) ; SKIP RET
\r
22725 LSTHLV: CAMN E,(C) ; LINEAR SERCH REST
\r
22729 JRST WON1 ; ALL GONE, LOSE
\r
22733 TITLE MODIFIED AFREE FOR MUDDLE
\r
22739 .GLOBAL CAFREE,CAFRET,PARNEW,AGC,PARBOT,CODTOP,CAFRE1
\r
22740 .GLOBAL STOGC,STOSTR,CAFRE,ISTOST,STOLST,SAT,ICONS,BYTDOP
\r
22741 .GLOBAL FLIST,STORIC
\r
22742 MFUNCTION FREEZE,SUBR
\r
22746 GETYP A,(AB) ; get type of it
\r
22747 PUSH TP,(AB) ; save a copy
\r
22749 PUSH P,[0] ; flag for tupel freeze
\r
22750 PUSHJ P,SAT ; to SAT
\r
22751 MOVEI B,0 ; final type
\r
22752 CAIN A,SNWORD ; check valid types
\r
22753 MOVSI B,TUVEC ; use UVECTOR
\r
22761 PUSH P,B ; save final type
\r
22762 CAME B,$TCHSTR ; special chars hack
\r
22764 HRR B,(AB) ; fixup count
\r
22767 MOVEI C,(TB) ; point to it
\r
22768 PUSHJ P,BYTDOP ; A==> points to dope word
\r
22770 SUBI A,1(B) ; A==> length of block
\r
22772 MOVEM B,1(TB) ; and save
\r
22776 OK.FR: HLRE A,1(TB) ; get length
\r
22780 PUSHJ P,CAFREE ; get storage
\r
22781 HRLZ B,1(TB) ; set up to BLT
\r
22784 ADDI C,(A) ; compute end
\r
22793 HRRZ E,STOLST+1(TVP)
\r
22795 PUSHJ P,ICONS ; get list element
\r
22796 PUSH TP,$TLIST ; and save
\r
22798 MOVE A,(P) ; restore length
\r
22799 ADDI A,2 ; 2 more for dope words
\r
22800 PUSHJ P,CAFREE ; get the core and dope words
\r
22801 POP P,B ; restore count
\r
22802 MOVNS B ; build AOBJN pointer
\r
22806 MOVEM B,1(C) ; save on list
\r
22807 MOVSI 0,TSTORA ; and type
\r
22809 HRRZM C,STOLST+1(TVP) ; and save as new list
\r
22816 HRROI B,(A) ; pointer to B
\r
22817 POP P,A ; length back
\r
22821 CAFREE: IRP AC,,[B,C,D,E]
\r
22824 SKIPG A ; make sure arg is a winner
\r
22825 FATAL BAD CALL TO CAFREE
\r
22826 MOVSI A,(A) ; count to left half for search
\r
22827 MOVEI B,FLIST ; get first pointer
\r
22828 HRRZ C,(B) ; c points to next block
\r
22829 CLOOP: CAMG A,(C) ; skip if not big enough
\r
22830 JRST CONLIS ; found one
\r
22831 MOVEI D,(B) ; save in case fall out
\r
22832 MOVEI B,(C) ; point to new previous
\r
22833 HRRZ C,(C) ; next block
\r
22834 JUMPN C,CLOOP ; go on through loop
\r
22835 HLRZ E,A ; count to E
\r
22836 CAMGE E,STORIC ; skip if a area or more
\r
22837 MOVE E,STORIC ; else use a whole area
\r
22838 MOVE C,PARBOT ; foun out if any funny space
\r
22839 SUB C,CODTOP ; amount around to C
\r
22840 CAMLE C,E ; skip if must GC
\r
22841 JRST CHAVIT ; already have it
\r
22842 SUBI E,-1(C) ; get needed from agc
\r
22843 MOVEM E,PARNEW ; funny arg to AGC
\r
22845 MOVE C,[7,,6] ; SET UP AGC INDICATORS
\r
22846 PUSHJ P,AGC ; collect that garbage
\r
22847 SETZM PARNEW ; dont do it again
\r
22848 AOJL A,GCLOS ; couldn't get core
\r
22851 ; Make sure pointers still good after GC
\r
22856 HRRZ E,(B) ; next pointer
\r
22857 JUMPE E,.+4 ; end of list ok
\r
22860 JRST .-4 ; look at next
\r
22862 CHAVIT: MOVE E,PARBOT ; find amount obtained
\r
22863 SUBI E,1 ; dont use a real pair
\r
22864 MOVEI C,(E) ; for reset of CODTOP
\r
22866 EXCH C,CODTOP ; store it back
\r
22867 CAIE B,(C) ; did we simply grow the last block?
\r
22868 JRST CSPLIC ; no, splice it in
\r
22869 HLRZ C,(B) ; length of old guy
\r
22870 ADDI C,(E) ; total length
\r
22871 ADDI B,(E) ; point to new last dope word
\r
22872 HRLZM C,(B) ; clobber final length in
\r
22873 HRRM B,(D) ; and splice into free list
\r
22874 MOVEI C,(B) ; reset acs for reentry into loop
\r
22878 ; Here to splice new core onto end of list.
\r
22880 CSPLIC: MOVE C,CODTOP ; point to end of new block
\r
22881 HRLZM E,(C) ; store length of new block in dope words
\r
22882 HRRM C,(D) ; D is old previous, link it up
\r
22883 MOVEI B,(D) ; and reset B for reentry into loop
\r
22886 ; here if an appropriate block is on the list
\r
22888 CONLIS: HLRZS A ; count back to a rh
\r
22889 HLRZ D,(C) ; length of proposed block to D
\r
22890 CAIN A,(D) ; skip if they are different
\r
22891 JRST CEASY ; just splice it out
\r
22892 MOVEI B,(C) ; point to block to be chopped up
\r
22893 SUBI B,-1(D) ; point to beginning of same
\r
22894 SUBI D,(A) ; amount of block to be left to D
\r
22895 HRLM D,(C) ; and fix up dope words
\r
22896 ADDI B,-1(A) ; point to end of same
\r
22898 HRRM B,(B) ; for GC benefit
\r
22900 CFREET: CAIE A,1 ; if more than 1
\r
22901 SETZM -1(B) ; make tasteful dope worda
\r
22904 IRP AC,,[E,D,C,B]
\r
22909 CEASY: MOVEI D,(C) ; point to block to return
\r
22910 HRRZ C,(C) ; point to next of same
\r
22911 HRRM C,(B) ; smash its previous
\r
22912 MOVEI B,(D) ; point to block with B
\r
22913 HRRM B,(B) ; for GC benefit
\r
22916 GCLOS: PUSH TP,$TATOM
\r
22917 PUSH TP,EQUOTE NO-MORE-STORAGE
\r
22920 CAFRET: HRROI B,(B) ; prepare to search list
\r
22921 TLC B,-1(A) ; by making an AOBJN pointer
\r
22922 HRRZ C,STOLST+1(TVP) ; start of list
\r
22923 MOVEI D,STOLST+1(TVP)
\r
22925 CAFRTL: JUMPE C,CPOPJ ; not founc
\r
22926 CAME B,1(C) ; this it?
\r
22928 HRRZ C,(C) ; yes splice it out
\r
22929 HRRM C,(D) ; smash it
\r
22930 CPOPJ: POPJ P, ; dont do anything now
\r
22932 CAFRT1: MOVEI D,(C)
\r
22936 ; Here from GC to collect all unused blocks into free list
\r
22938 STOGC: SETZB C,E ; zero current length and pointer
\r
22939 MOVE A,CODTOP ; get high end of free space
\r
22941 STOGCL: CAIG A,STOSTR ; end?
\r
22942 JRST STOGCE ; yes, cleanup and leave
\r
22944 HLRZ 0,(A) ; get length
\r
22946 SKIPGE (A) ; skip if a not used block
\r
22947 JRST STOGC1 ; jump if marked
\r
22949 JUMPE C,STOGC3 ; jump if no block under construction
\r
22950 ADD C,0 ; else add this length to current
\r
22953 STOGC3: MOVEI B,(A) ; save pointer
\r
22954 MOVE C,0 ; init length
\r
22956 STOGC4: SUB A,0 ; point to next block
\r
22959 STOGC1: ANDCAM D,(A) ; kill mark bit
\r
22960 JUMPE C,STOGC4 ; if no block under cons, dont fix
\r
22961 HRLM C,(B) ; store total block length
\r
22962 HRRM E,(B) ; next pointer hooked in
\r
22963 MOVEI E,(B) ; new next pointer
\r
22967 STOGCE: JUMPE C,STGCE1 ; jump if no current block
\r
22968 HRLM C,(B) ; smash in count
\r
22969 HRRM E,(B) ; smash in next pointer
\r
22970 MOVEI E,(B) ; and setup E
\r
22972 STGCE1: HRRZM E,FLIST+1 ; final link up
\r
22984 TITLE FLOATB--CONVERT FLOATING NUMBER TO ASCII STRING
\r
22992 IRP A,,[A,B,C,D,E,F,G,H,I,J]
\r
23012 MOVSI 0,440700 ; BUILD BYTEPNTR
\r
23013 HLRZ J,A ; POINT TO BUFFER
\r
23015 MOVE A,(A) ; GET NUMBER
\r
23017 SETZM (J) ; Clear counter
\r
23030 ; at this point we enter code abstracted from DDT.
\r
23031 NFLOT: JUMPG A,TFL1
\r
23042 TFLX: CAMGE A,FT01
\r
23047 FP3: SETZB C,TEM1 ; CLEAR DIGIT CNTR, C TO RECEIVE FRACTION
\r
23064 POPJ P, ; ONE return from OFLT here
\r
23068 FP4A: ADDI F,1(F)
\r
23083 FP7: SKIPE A ; AVOID AOSING TEM1, NOT SIGNIFICANT DIGIT
\r
23090 FP7A1: HLRZ D,(P)
\r
23100 CHRO: AOS (J) ; COUNT CHAR
\r
23101 IDPB A,0 ; STUFF CHAR
\r
23121 FCP: CAMLE A, FT0(C)
\r
23129 EXPUNGE A,B,C,D,E,F,G,H,I,J,TEM1,P
\r
23132 \fTITLE PRIMITIVE FUNCTIONS FOR THE MUDDLE SYSTEM
\r
23138 .GLOBAL TMA,TFA,CELL,IBLOCK,IBLOK1,ICELL2,VECTOP
\r
23139 .GLOBAL NWORDT,CHARGS,CHFRM,CHLOCI,IFALSE,IPUTP,IGETP,BYTDOP
\r
23140 .GLOBAL OUTRNG,IGETLO,CHFRAM,ISTRUC,TYPVEC,SAT,CHKAB,VAL,CELL2,MONCH,MONCH0
\r
23141 .GLOBAL RMONCH,RMONC0,LOCQ,LOCQQ,SMON,PURERR,APLQ,NAPT,TYPSEG,NXTLM
\r
23142 .GLOBAL MAKACT,ILLCHO,COMPER,CEMPTY,CIAT,CIEQUA,CILEGQ,CILNQ,CILNT,CIN,CINTH,CIREST
\r
23143 .GLOBAL CISTRU,CSETLO,CIPUT,CIGET,CIGETL,CIMEMQ,CIMEMB,CIMON,CITOP,CIBACK
\r
23144 .GLOBAL IGET,IGETL,IPUT,CIGETP,CIGTPR,CINEQU,IEQUAL,TD.LNT,TD.GET,TD.PUT,TD.PTY
\r
23145 .GLOBAL TMPLNT,ISTRCM
\r
23147 ; BUILD DISPATCH TABLE FOR PRIMITIVE FUNCTIONS USAGE
\r
23151 REPEAT NUMSAT,[0] ;INITIALIZE TABLE TO ZEROES
\r
23153 IRP A,,[2WORD,2NWORD,NWORD,ARGS,CHSTR,BYTE]
\r
23163 ; FUDGE FOR STRUCTURE LOCATIVES
\r
23165 IRP A,,[[LOCL,2WORD],[LOCV,2NWORD],[LOCU,NWORD],[LOCS,CHSTR],[LOCA,ARGS]
\r
23175 LOC PRMTYP+SSTORE ;SPECIAL HACK FOR AFREE STORAGE
\r
23178 LOC PRMTYP+NUMSAT+1
\r
23182 ; MACRO TO BUILD PRIMITIVE DISPATCH TABLES
\r
23184 DEFINE PRDISP NAME,DEFAULT,LIST
\r
23185 TBLDIS NAME,DEFAULT,[LIST]PNUM
\r
23189 ; SUBROUTINE TO RETURN PRIMITIVE TYPE AND PRINT ERROR IF ILLEGAL
\r
23191 PTYPE: GETYP A,(B) ;CALLE D WITH B POINTING TO PAIR
\r
23192 CAIN A,TILLEG ;LOSE IF ILLEGAL
\r
23195 PUSHJ P,SAT ;GET STORAGE ALLOC TYPE
\r
23197 CAIN A,SARGS ;SPECIAL HAIR FOR ARGS
\r
23203 PTYP1: MOVEI 0,(A) ; ALSO RETURN PRIMTYPE
\r
23204 CAILE A,NUMSAT ; SKIP IF NOT TEMPLATE
\r
23206 MOVE A,PRMTYP(A) ;GET PRIM TYPE,
\r
23209 ; COMPILERS CALL TO ABOVE (LESS CHECKING)
\r
23211 CPTYPE: PUSHJ P,SAT
\r
23219 MFUNCTION SUBSTRUC,SUBR
\r
23222 JUMPGE AB,TFA ;need at least one arg
\r
23223 CAMGE AB,[-10,,0] ;NO MORE THEN 4
\r
23226 PUSHJ P,PTYPE ;get primtype in A
\r
23230 RESSUB: CAMLE AB,[-2,,0] ;if only one arg skip rest
\r
23232 HLRZ B,(AB)2 ;GET TYPE
\r
23233 CAIE B,TFIX ;IF FIX OK
\r
23235 MOVE B,(AB)1 ;ptr to object of resting
\r
23236 MOVE C,(AB)3 ;# of times to rest
\r
23239 PUSHJ P,@MRSTBL(E)
\r
23241 PUSH TP,B ;put rested sturc on stack
\r
23244 PRDISP TYTBL,IWTYP1,[[P2WORD,RESSUB],[P2NWORD,RESSUB]
\r
23245 [PNWORD,RESSUB],[PCHSTR,RESSUB]]
\r
23247 PRDISP MRSTBL,IWTYP1,[[P2WORD,LREST],[P2NWORD,VREST]
\r
23248 [PNWORD,UREST],[PCHSTR,SREST]]
\r
23250 PRDISP COPYTB,IWTYP1,[[P2WORD,CPYLST],[P2NWORD,CPYVEC]
\r
23251 [PNWORD,CPYUVC],[PCHSTR,CPYSTR]]
\r
23253 PRDISP ALOCTB,IWTYP1,[[P2WORD,ALLIST],[P2NWORD,ALVEC]
\r
23254 [PNWORD,ALUVEC],[PCHSTR,ALSTR]]
\r
23256 ALOCFX: MOVE B,(TP) ;missing 3rd arg aloc for "rest" of struc
\r
23259 PUSH P,[377777,,-1]
\r
23260 PUSHJ P,@LENTBL(A) ;get length of rested struc
\r
23263 MOVE A,B ;# of elements needed
\r
23266 ALOCOK: CAML AB,[-4,,0] ;exactly 3 args
\r
23269 CAIE C,TFIX ;OK IF TYPE FIX
\r
23271 POP P,C ;C HAS PRIMTYYPE
\r
23272 MOVE A,(AB)5 ;# of elements needed
\r
23273 JRST @ALOCTB(C) ;DO ALLOCATION
\r
23276 CPYVEC: HLRE A,(AB)1 ;USE WHEN ONLY ONE ARG
\r
23278 ASH A,-1 ;# OF ELEMENTS FOR ALLOCATION
\r
23286 CAIL A,-1 ;CHK FOR OUT OF RANGE
\r
23288 CAMGE AB,[-6,,] ; SKIP IF WE GET VECTOR
\r
23289 JRST ALVEC2 ; USER SUPPLIED VECTOR
\r
23292 ALVEC1: MOVE A,(P) ;# OF WORDS TO ALLOCATE
\r
23293 MOVE C,B ; SAVE VECTOR POINTER
\r
23296 ADD A,B ;PTING TO FIRST DOPE WORD -ALLOCATED
\r
23299 SUBI A,1 ;ptr to last element of the block
\r
23300 HRL B,(TP) ;bleft-ptr to source , b right -ptr to allocated space
\r
23308 ALVEC2: GETYP 0,6(AB) ; CHECK IT IS A VECTOR
\r
23311 HLRE A,7(AB) ; CHECK SIZE
\r
23313 ASH A,-1 ; # OF ELEMENTS
\r
23314 CAMGE A,(P) ; SKIP IF BIG ENOUGH
\r
23316 MOVE B,7(AB) ; WINNER, JOIN COMMON CODE
\r
23319 CPYUVC: HLRE A,(AB)1 ;# OF ELEMENTS FOR ALLOCATION
\r
23326 ADD A,(TP) ;PTING TO DOPE WORD OF ORIG VEC
\r
23329 CAMGE AB,[-6,,] ; SKIP IF WE SUPPLY UVECTOR
\r
23333 ALUVE1: MOVE A,(P) ;# of owrds to allocate
\r
23335 ADD A,B ;LOCATION O FIRST ALLOCATED DOPE WORD
\r
23336 HLR D,(AB)1 ;# OF ELEMENTS IN UVECTOR
\r
23338 ADD D,(AB)1 ;LOCATION OF FIRST DOPE WORD FOR SOURCE
\r
23339 GETYP E,(D) ;GET UTYPE
\r
23340 CAML AB,[-6,,] ; SKIP IF USER SUPPLIED OUTPUT UVECTOR
\r
23341 HRLM E,(A) ;DUMP UTYPE INTO DOPE WORD OF ALLOC UVEC
\r
23343 CAIN 0,(E) ; 0 HAS USER UVEC UTYPE
\r
23348 MOVE C,B ; SAVE POINTER TO FINAL GUY
\r
23349 HRL C,(TP) ;Bleft- ptr to source, Bright-ptr to allocated space
\r
23355 ALUVE2: GETYP 0,6(AB) ; CHECK IT IS A VECTOR
\r
23358 HLRE A,7(AB) ; CHECK SIZE
\r
23360 CAMGE A,(P) ; SKIP IF BIG ENOUGH
\r
23362 MOVE B,7(AB) ; WINNER, JOIN COMMON CODE
\r
23365 GETYP 0,(A) ; GET UTYPE OF USER UVECTOR
\r
23368 CPYSTR: HRR A,(AB) ;#OF CHAR TO COPY
\r
23369 PUSH TP,(AB) ;ALSTR EXPECTS STRING IN TP
\r
23373 HRRZ 0,-1(TP) ;0 IS LENGTH OFF VECTOR
\r
23376 CAMGE AB,[-6,,] ; SKIP IF WE SUPPLY STRING
\r
23380 PUSHJ P,IBLOCK ;ALLOCATE SPACE
\r
23382 MOVE A,(P) ; # OF CHARS TO A
\r
23383 ALSTR1: PUSH P,B ;BYTE PTR TO ALOC SPACE
\r
23384 POP TP,C ;PTR TO ORIGINAL STR
\r
23385 POP TP,D ;USELESS
\r
23386 COPYST: ILDB D,C ;GET NEW CHAR
\r
23387 IDPB D,B ;DEPOSIT CHAR
\r
23388 SOJG A,COPYST ;FINISH TRANSFER?
\r
23390 CLOSTR: POP P,B ;BYTE PTR TO COPY
\r
23391 POP P,A ;# FO ELEMENTS
\r
23395 ALSTR2: GETYP 0,6(AB) ; CHECK IT IS A VECTOR
\r
23399 CAMGE A,(P) ; SKIP IF BIG ENOUGH
\r
23402 MOVE B,7(AB) ; WINNER, JOIN COMMON CODE
\r
23405 CPYLST: SKIPN 1(AB)
\r
23409 HRLI C,TLIST ;TP JUNK FOR GAR. COLLECTOR
\r
23411 PUSH TP,B ;VALUE -PTR TO NEW LIST
\r
23413 MOVE C,1(AB) ;PTR TO FIRST ELEMENT OF ORIG. LIST
\r
23414 REPLST: MOVE D,(C)
\r
23415 MOVE E,1(C) ;GET LIST ELEMENT INTO ALOC SPACE
\r
23417 MOVEM E,1(B) ;PUT INTO ALLOCATED SPACE
\r
23418 HRRZ C,(C) ;UPDATE PTR
\r
23419 JUMPE C,CLOSWL ;END OF LIST?
\r
23423 HRRM B,(D) ;LINK ALLOCATED LIST CELLS
\r
23426 CLOSWL: POP TP,B ;USELESS
\r
23427 POP TP,B ;PTR TO NEW LIST
\r
23433 ALLIST: CAMGE AB,[-6,,] ; SKIP IF WE BUILD THE LIST
\r
23438 POP P,A ;# OF ELEMENTS
\r
23439 PUSH P,B ;ptr to allocated list
\r
23440 POP TP,C ;ptr to orig list
\r
23444 HRRM B,-2(B) ;LINK ALOCATED LIST CELLS
\r
23445 ENTCOP: JUMPE C,OUTRNG
\r
23447 MOVE E,1(C) ;get list element into D+E
\r
23449 MOVEM E,1(B) ;put into allocated space
\r
23450 HRRZ C,(C) ;update ptrs
\r
23451 SOJG A,COPYL ;finish transfer?
\r
23453 CLOSEL: POP P,B ;PTR TO NEW LIST
\r
23457 ZEROLT: SUB TP,[1,,1] ;IF RESTED ALL OF LIST
\r
23463 CPYLS2: GETYP 0,6(AB)
\r
23466 MOVE B,7(AB) ; GET DEST LIST
\r
23470 CPYLS4: JUMPE B,OUTRNG
\r
23480 CPYLS3: MOVE B,7(AB)
\r
23485 ; PROCESS TYPE ILLEGAL
\r
23487 ILLCHO: HRRZ B,1(B) ;GET CLOBBERED TYPE
\r
23488 CAIN B,TARGS ;WAS IT ARGS?
\r
23490 CAIN B,TFRAME ;A FRAME?
\r
23492 CAIN B,TLOCD ;A LOCATIVE TO AN ID
\r
23495 LSH B,1 ;NONE OF ABOVE LOOK IN TABLE
\r
23496 ADDI B,TYPVEC+1(TVP)
\r
23498 PUSH TP,EQUOTE ILLEGAL
\r
23500 PUSH TP,(B) ;PUSH ATOMIC NAME
\r
23502 JRST CALER ;GO TO ERROR REPORTER
\r
23504 ; CHECK AN ARGS POINTER
\r
23506 CHARGS: PUSHJ P,ICHARG ; INTERNAL CHECK
\r
23509 ILLAR1: PUSH TP,$TATOM
\r
23510 PUSH TP,EQUOTE ILLEGAL-ARGUMENT-BLOCK
\r
23513 ICHARG: PUSH P,A ;SAVE SOME ACS
\r
23516 SKIPN C,1(B) ;GET POINTER
\r
23517 JRST ILLARG ; ZERO POINTER IS ILLEGAL
\r
23518 HLRE A,C ;FIND ASSOCIATED FRAME
\r
23519 SUBI C,(A) ;C POINTS TO FRAME OR FRAME POINTER
\r
23520 GETYP A,(C) ;GET TYPE OF NEXT GOODIE
\r
23523 CAIE A,TENTRY ;MUST BE EITHER ENTRY OR TINFO
\r
23525 JRST CHARG1 ;WINNER
\r
23528 CHARG1: CAIN A,TINFO ;POINTER TO FRAME?
\r
23529 ADD C,1(C) ;YES, GET IT
\r
23530 CAIE A,TINFO ;POINTS TO ENTRT?
\r
23531 MOVEI C,FRAMLN(C) ;YES POINT TO END OF FRAME
\r
23532 HLRZ C,OTBSAV(C) ;GET TIME FROM FRAME
\r
23533 HRRZ B,(B) ;AND ARGS TIME
\r
23534 CAIE B,(C) ;SAME?
\r
23535 ILLARG: SETZM -1(P) ; RETURN ZEROED B
\r
23539 POPJ P, ;GO GET PRIM TYPE
\r
23543 ; CHECK A FRAME POINTER
\r
23545 CHFRM: PUSHJ P,CHFRAM
\r
23548 ILFRAM: PUSH TP,$TATOM
\r
23549 PUSH TP,EQUOTE ILLEGAL-FRAME
\r
23552 CHFRAM: PUSH P,A ;SAVE SOME REGISTERS
\r
23555 HRRZ A,(B) ; GE PVP POINTER
\r
23556 HLRZ C,(A) ; GET LNTH
\r
23557 SUBI A,-1(C) ; POINT TO TOP
\r
23558 CAIN A,(PVP) ; SKIP IF NOT THIS PROCESS
\r
23559 MOVEM TP,TPSTO+1(A) ; MAKE CURRENT BE STORED
\r
23560 HRRZ A,TPSTO+1(A) ; GET TP FOR THIS PROC
\r
23561 HRRZ C,1(B) ;GET POINTER PART
\r
23562 CAILE C,1(A) ;STILL WITHIN STACK
\r
23564 HLRZ A,FSAV(C) ;CHECK STILL AN ENTRY BLOCK
\r
23569 HLRZ A,1(B) ;GET TIME FROM POINTER
\r
23570 HLRZ C,OTBSAV(C) ;AND FROM FRAME
\r
23571 CAIE A,(C) ;SAME?
\r
23572 BDFR: SETZM -1(P) ; RETURN 0 IN B
\r
23573 JRST POPBCJ ;YES, WIN
\r
23575 ; CHECK A LOCATIVE TO AN IDENTIFIER
\r
23577 CHLOCI: PUSHJ P,ICHLOC
\r
23580 ILLOC1: PUSH TP,$TATOM
\r
23581 PUSH TP,EQUOTE ILLEGAL-LOCATIVE
\r
23588 HRRZ A,(B) ;GET TIME FROM POINTER
\r
23589 JUMPE A,POPBCJ ;ZERO, GLOBAL VARIABLE NO TIME
\r
23590 HRRZ C,1(B) ;POINT TO STACK
\r
23593 HRRZ C,2(C) ; SHOULD BE DECL,,TIME
\r
23595 ILLOC: SETZM -1(P) ; RET 0 IN B
\r
23601 ; PREDICATE TO SEE IF AN OBJECT IS STRUCTURED
\r
23603 MFUNCTION %STRUC,SUBR,[STRUCTURED?]
\r
23607 GETYP A,(AB) ; GET TYPE
\r
23608 PUSHJ P,ISTRUC ; INTERNAL
\r
23613 ; PREDICATE TO CHECK THE LEGALITY OF A FRAME/ARGS TUPLE/IDENTIFIER LOCATIVE
\r
23615 MFUNCTION %LEGAL,SUBR,[LEGAL?]
\r
23619 MOVEI B,(AB) ; POINT TO ARG
\r
23624 ILEGQ: GETYP A,(B)
\r
23627 PUSHJ P,SAT ; GET STORG TYPE
\r
23628 CAIN A,SFRAME ; FRAME?
\r
23630 CAIN A,SARGS ; ARG TUPLE
\r
23632 CAIN A,SLOCID ; ID LOCATIVE
\r
23640 CILEGQ: PUSH TP,A
\r
23649 YES: MOVSI A,TATOM
\r
23654 NO: MOVSI A,TFALSE
\r
23660 \f;SUBRS TO DEFINE, GET, AND PUT BIT FIELDS
\r
23662 MFUNCTION BITS,SUBR
\r
23664 JUMPGE AB,TFA ;AT LEAST ONE ARG ?
\r
23668 SKIPLE C,(AB)+1 ;GET FIRST AND CHECK TO SEE IF POSITIVE
\r
23669 CAILE C,44 ;CHECK IF FIELD NOT GREATER THAN WORD SIZE
\r
23672 CAML AB,[-2,,0] ;ONLY ONE ARG ?
\r
23674 CAMGE AB,[-4,,0] ;MORE THAN TWO ARGS ?
\r
23675 JRST TMA ;YES, LOSE
\r
23679 SKIPGE B,(AB)+3 ;GET SECOND ARG AND CHECK TO SEE IF NON-NEGATIVE
\r
23681 ADD C,(AB)+3 ;CALCULATE LEFTMOST EXTENT OF THE FIELD
\r
23682 CAILE C,44 ;SHOULD BE LESS THAN WORD SIZE
\r
23685 ONEF: ADD B,(AB)+1
\r
23686 LSH B,30 ;FORM BYTE POINTER'S LEFT HALF
\r
23692 MFUNCTION GETBITS,SUBR
\r
23703 MOVEI A,(AB)+1 ;GET ADDRESS OF THE WORD
\r
23704 HLL A,(AB)+3 ;GET LEFT HALF OF BYTE POINTER
\r
23706 MOVSI A,TWORD ; ALWAYS RETURN WORD
\b\b\b\b____
\r
23710 MFUNCTION PUTBITS,SUBR
\r
23712 CAML AB,[-2,,0] ;AT LEAST TWO ARGS ?
\r
23713 JRST TFA ;NO, LOSE
\r
23721 MOVEI B,0 ;EMPTY THIRD ARG DEFAULT
\r
23722 CAML AB,[-4,,0] ;ONLY TWO ARGS ?
\r
23724 CAMGE AB,[-6,,0] ;MORE THAN THREE ARGS ?
\r
23725 JRST TMA ;YES, LOSE
\r
23731 TWOF: MOVEI A,(AB)+1 ;ADDRESS OF THE TARGET WORD
\r
23732 HLL A,(AB)+3 ;GET THE LEFT HALF OF THE BYTE POINTER
\r
23735 MOVE A,(AB) ;SAME TYPE AS FIRST ARG'S
\r
23739 ; FUNCTION TO GET THE LENGTH OF LISTS,VECTORS AND CHAR STRINGS
\r
23741 MFUNCTION LNTHQ,SUBR,[LENGTH?]
\r
23751 MFUNCTION LENGTH,SUBR
\r
23754 PUSH P,[377777777777]
\r
23755 LNTHER: MOVE B,AB ;POINT TO ARGS
\r
23756 PUSHJ P,PTYPE ;GET ITS PRIM TYPE
\r
23759 PUSHJ P,@LENTBL(A) ; CALL RIGTH ONE
\r
23760 JRST LFINIS ;OTHERWISE USE 0
\r
23762 PRDISP LENTBL,IWTYP1,[[P2WORD,LNLST],[P2NWORD,LNVEC],[PNWORD,LNUVEC]
\r
23763 [PARGS,LNVEC],[PCHSTR,LNCHAR],[PTMPLT,LNTMPL]]
\r
23765 LNLST: SKIPN C,B ; EMPTY?
\r
23766 JRST LNLST2 ; YUP, LEAVE
\r
23767 MOVEI B,1 ; INIT COUNTER
\r
23768 MOVSI A,TLIST ;WILL BECOME INTERRUPTABLE
\r
23769 HLLM A,CSTO(PVP) ;AND C WILL BE A LIST POINTER
\r
23770 LNLST1: INTGO ;IN CASE CIRCULAR LIST
\r
23774 JUMPE C,.+2 ;DONE, RETRUN LENGTH
\r
23775 AOJA B,LNLST1 ;COUNT AND GO
\r
23776 LNLST2: SETZM CSTO(PVP)
\r
23782 MOVSI A,TFIX ;LENGTH IS AN INTEGER
\r
23785 LNVEC: ASH B,-1 ;GENERAL VECTOR DIVIDE BY 2
\r
23786 LNUVEC: HLRES B ;GET LENGTH
\r
23787 MOVMS B ;MAKE POS
\r
23790 LNCHAR: HRRZ B,C ; GET COUNT
\r
23793 LNTMPL: GETYP A,(B) ; GET REAL SAT
\r
23795 HRLS A ; READY TO HIT TABLE
\r
23796 ADD A,TD.LNT+1(TVP)
\r
23798 MOVE C,B ; DATUM TO C
\r
23799 XCT (A) ; GET LENGTH
\r
23800 HLRZS C ; REST COUNTER
\r
23801 SUBI B,(C) ; FLUSH IT OFF
\r
23802 MOVEI B,(B) ; IN CASE FUNNY STUFF
\r
23806 ; COMPILERS ENTRIES
\r
23808 CILNT: SUBM M,(P)
\r
23809 PUSH P,[377777,,-1]
\r
23812 PUSHJ P,CPTYPE ; GET PRIMTYPE
\r
23814 PUSHJ P,@LENTBL(A) ; DISPATCH
\r
23817 MPOPJ: SUBM M,(P)
\r
23820 CILNQ: SUBM M,(P)
\r
23826 PUSHJ P,@LENTBL(A)
\r
23838 IDNT1: MOVE A,(AB) ;RETURN THE FIRST ARG
\r
23842 MFUNCTION QUOTE,FSUBR
\r
23847 CAIE A,TLIST ;ARG MUST BE A LIST
\r
23849 SKIPN B,1(AB) ;SHOULD HAVE A BODY
\r
23852 HLLZ A,(B) ; GET IT
\r
23857 MFUNCTION NEQ,SUBR,[N==?]
\r
23862 MFUNCTION EQ,SUBR,[==?]
\r
23867 GETYP A,(AB) ;GET 1ST TYPE
\r
23868 GETYP C,2(AB) ;AND 2D TYPE
\r
23870 CAIN A,(C) ;CHECK IT
\r
23875 ITRUTH: MOVSI A,TATOM ;RETURN TRUTH
\r
23879 IFALSE: MOVSI A,TFALSE ;RETURN FALSE
\r
23890 MFUNCTION EMPTY,SUBR,EMPTY?
\r
23895 PUSHJ P,PTYPE ;GET PRIMITIVE TYPE
\r
23899 SKIPN B,1(AB) ;GET THE ARG
\r
23902 CAIN A,PTMPLT ; TEMPLATE?
\r
23904 CAIE A,P2WORD ;A LIST?
\r
23905 JRST EMPT1 ;NO VECTOR OR CHSTR
\r
23906 JUMPE B,ITRUTH ;0 POINTER MEANS EMPTY LIST
\r
23910 EMPT1: CAIE A,PCHSTR ;CHAR STRING?
\r
23911 JRST EMPT2 ;NO, VECTOR
\r
23912 HRRZ B,(AB) ; GET COUNT
\r
23913 JUMPE B,ITRUTH ;0 STRING WINS
\r
23916 EMPT2: JUMPGE B,ITRUTH
\r
23919 EMPTPL: PUSHJ P,LNTMPL ; GET LENGTH
\r
23923 ; COMPILER'S ENTRY TO EMPTY
\r
23930 JUMPE B,YES ; ALWAYS EMPTY
\r
23939 TRNE 0,-1 ; STRING, SKIP ON ZERO LENGTH FIELD
\r
23943 CEMPTP: PUSHJ P,LNTMPL
\r
23947 MFUNCTION NEQUAL,SUBR,[N=?]
\r
23951 MFUNCTION EQUAL,SUBR,[=?]
\r
23955 MOVE C,AB ;SET UP TO CALL INTERNAL
\r
23957 ADD D,[2,,2] ;C POINTS TO FIRS, D TO SECOND
\r
23958 PUSHJ P,IEQUAL ;CALL INTERNAL
\r
23959 JRST EQFALS ;NO SKIP MEANS LOSE
\r
23967 ; COMPILER'S ENTRY TO =? AND N=?
\r
23969 CINEQU: PUSH P,[0]
\r
23972 CIEQUA: PUSH P,[1]
\r
23979 SUBM M,-1(P) ; MAY BECOME INTERRUPTABLE
\r
23983 SUB TP,[4,,4] ; FLUSH TEMPS
\r
23994 ; INTERNAL EQUAL SUBROUTINE
\r
23996 IEQUAL: MOVE B,C ;NOW CHECK THE ARGS
\r
24000 GETYP 0,(C) ;NOW CHECK FOR EQ
\r
24003 CAIN 0,(B) ;DONT SKIP IF POSSIBLE WINNER
\r
24004 CAME E,1(D) ;DEFINITE WINNER, SKIP
\r
24006 CPOPJ1: AOS (P) ;EQ, SKIP RETURN
\r
24010 IEQ1: CAIE 0,(B) ;SKIP IF POSSIBLE MATCH
\r
24011 CPOPJ: POPJ P, ;NOT POSSIBLE WINNERS
\r
24012 JRST @EQTBL(A) ;DISPATCH
\r
24014 PRDISP EQTBL,CPOPJ,[[P2WORD,EQLIST],[P2NWORD,EQVEC],[PNWORD,EQUVEC]
\r
24015 [PARGS,EQVEC],[PCHSTR,EQCHST],[PTMPLT,EQTMPL]]
\r
24018 EQLIST: PUSHJ P,PUSHCD ;PUT ARGS ON STACK
\r
24020 EQLST1: INTGO ;IN CASE OF CIRCULAR
\r
24021 HRRZ C,-2(TP) ;GET FIRST
\r
24022 HRRZ D,(TP) ;AND 2D
\r
24023 CAIN C,(D) ;EQUAL?
\r
24024 JRST EQLST2 ;YES, LEAVE
\r
24025 JUMPE C,EQLST3 ;NIL LOSES
\r
24027 GETYP 0,(C) ;CHECK DEFERMENT
\r
24029 HRRZ C,1(C) ;PICK UP POINTED TO CROCK
\r
24032 HRRZ D,1(D) ;POINT TO REAL GOODIE
\r
24033 PUSHJ P,IEQUAL ;CHECK THE CARS
\r
24034 JRST EQLST3 ;LOSE
\r
24035 HRRZ C,@-2(TP) ;CDR THE LISTS
\r
24037 HRRZM C,-2(TP) ;AND STORE
\r
24041 EQLST2: AOS (P) ;SKIP RETRUN
\r
24042 EQLST3: SUB TP,[4,,4] ;REMOVE CRUFT
\r
24045 ; HERE FOR HACKING TEMPLATE STRUCTURES
\r
24047 EQTMPL: PUSHJ P,PUSHCD ; SAVE GOODIES
\r
24049 MOVE C,1(C) ; CHECK REAL SATS
\r
24053 CAIE 0,(C) ; SKIP IF WINNERS
\r
24055 PUSH P,0 ; SAVE MAGIC OFFSET
\r
24057 PUSHJ P,TM.LN1 ; RET LENGTH IN B
\r
24058 MOVEI B,-1(B) ; FLUSH FUNNY
\r
24062 MOVE C,(TP) ; POINTER TO OTHER GUY
\r
24063 ADD A,TD.LNT+1(TVP)
\r
24064 XCT (A) ; OTHER LENGTH TO B
\r
24065 HLRZ 0,B ; REST OFFSETTER
\r
24073 EQTMP2: AOS C,(P)
\r
24075 JRST EQTMP3 ; WIN!!
\r
24077 MOVE B,-6(TP) ; POINTER
\r
24078 MOVE 0,-2(P) ; GET MAGIC OFFSET
\r
24079 PUSHJ P,TM.TOE ; GET OFFSET TO TEMPLATE
\r
24080 ADD A,TD.GET+1(TVP)
\r
24083 XCT (E) ; VAL TO A AND B
\r
24087 MOVE B,-4(TP) ; OTHER GUY
\r
24090 ADD A,TD.GET+1(TVP)
\r
24093 XCT (E) ; GET OTHER VALUE
\r
24098 PUSHJ P,IEQUAL ; RECURSE
\r
24099 JRST EQTMP1 ; LOSER
\r
24100 JRST EQTMP2 ; WINNER
\r
24102 EQTMP3: AOS -3(P) ; WIN RETURN
\r
24103 EQTMP1: SUB P,[3,,3] ; FLUSH JUNK
\r
24104 EQTMP4: SUB TP,[10,,10]
\r
24109 EQVEC: HLRE A,1(C) ;GET LENGTHS
\r
24111 CAIE B,(A) ;SKIP IF EQUAL LENGTHS
\r
24113 JUMPGE A,CPOPJ1 ;SKIP RETRUN WIN
\r
24114 PUSHJ P,PUSHCD ;SAVE ARGS
\r
24116 EQVEC1: INTGO ;IN CASE LONG VECTOR
\r
24118 MOVE D,-2(TP) ;ARGS TO C AND D
\r
24121 MOVE C,[2,,2] ;GET BUMPER
\r
24123 ADDB C,-2(TP) ;BUMP BOTH POINTERS
\r
24127 EQUVEC: HLRE A,1(C) ;GET LENGTHS
\r
24129 CAIE B,(A) ;SKIP IF EQUAL
\r
24132 HRRZ B,1(C) ;START COMPUTING DOPE WORD LOCN
\r
24133 SUB B,A ;B POINTS TO DOPE WORD
\r
24134 GETYP 0,(B) ;GET UNIFORM TYPE
\r
24135 HRRZ B,1(D) ;NOW FIND OTHER DOPE WORD
\r
24137 HLRZ B,(B) ;OTHER UNIFORM TYPE
\r
24138 CAIE 0,(B) ;TYPES THE SAME?
\r
24139 POPJ P, ;NO, LOSE
\r
24141 JUMPGE A,CPOPJ1 ;IF ZERO LENGTH ALREADY WON
\r
24143 HRLZI B,(B) ;TYPE TO LH
\r
24144 PUSH P,B ;AND SAVED
\r
24145 PUSHJ P,PUSHCD ;SAVE ARGS
\r
24147 EQUV1: MOVEI C,1(TP) ;POINT TO WHERE WILL GO
\r
24149 MOVE A,-3(TP) ;PUSH ONE OF THE VECTORS
\r
24150 PUSH TP,(A) ; PUSH ELEMENT
\r
24151 MOVEI D,1(TP) ;POINT TO 2D ARG
\r
24153 MOVE A,-3(TP) ;AND PUSH ITS POINTER
\r
24158 SUB TP,[4,,4] ;POP TP
\r
24160 ADDM A,(TP) ;BUMP POINTERS
\r
24162 JUMPL A,EQUV1 ;JUMP IF STILL MORE STUFF
\r
24163 SUB P,[1,,1] ;POP OFF TYPE
\r
24166 UNEQUV: SUB P,[1,,1]
\r
24172 EQCHST: HRRZ B,(C) ; GET LENGTHS
\r
24175 JRST EQCHS3 ;NO, LOSE
\r
24178 JUMPE A,EQCHS4 ;BOTH 0 LENGTH, WINS
\r
24181 ILDB 0,C ;GET NEXT CHARS
\r
24183 CAIE 0,(E) ; SKIP IF STILL WINNING
\r
24184 JRST EQCHS3 ; NOT =
\r
24190 PUSHCD: PUSH TP,(C)
\r
24197 ; REST/NTH/AT/PUT/GET
\r
24201 ARGS1: MOVE E,[JRST WTYP2] ; ERROR CONDITION FOR 2D ARG NOT FIXED
\r
24202 ARGS2: HLRE 0,AB ; CHECK NO. OF ARGS
\r
24203 ASH 0,-1 ; TO - NO. OF ARGS
\r
24204 AOJG 0,TFA ; 0--TOO FEW
\r
24205 AOJL 0,TMA ; MORE THAT 2-- TOO MANY
\r
24206 MOVEI C,1 ; DEFAULT ARG2
\r
24207 JUMPN 0,ARGS4 ; GET STRUCTURED ARG
\r
24208 ARGS3: GETYP A,2(AB)
\r
24209 CAIE A,TFIX ; SHOULD BE FIXED NUMBER
\r
24210 XCT E ; DO ERROR THING
\r
24211 SKIPGE C,3(AB) ; BETTER BE NON-NEGATIVE
\r
24213 ARGS4: MOVEI B,(AB) ; POINT TO STRUCTURED POINTER
\r
24214 PUSHJ P,PTYPE ; GET PRIM TYPE
\r
24215 MOVEI E,(A) ; DISPATCH CODE TO E
\r
24216 MOVE A,(AB) ; GET ARG 1
\r
24222 MFUNCTION REST,SUBR
\r
24225 PUSHJ P,ARGS1 ; GET AND CHECK ARGS
\r
24226 PUSHJ P,@RESTBL(E) ; DO IT BASED ON TYPE
\r
24227 MOVE C,A ; THE FOLLOWING IS TO MAKE STORAGE WORK
\r
24230 CAIN A,SSTORE ; SKIP IF NOT STORAGE
\r
24231 MOVSI C,TSTORA ; USE ITS PRIMTYPE
\r
24235 PRDISP RESTBL,IWTYP1,[[P2WORD,LREST],[PNWORD,UREST],[P2NWOR,VREST],[PARGS,AREST]
\r
24236 [PCHSTR,SREST],[PTMPLT,TMPRST]]
\r
24240 MFUNCTION AT,SUBR
\r
24245 PUSHJ P,@ATTBL(E)
\r
24248 PRDISP ATTBL,IWTYP1,[[P2WORD,LAT],[PNWORD,UAT],[P2NWORD,VAT],[PARGS,AAT]
\r
24249 [PCHSTR,STAT],[PTMPLT,TAT]]
\r
24254 MFUNCTION NTH,SUBR
\r
24260 PUSHJ P,@NTHTBL(E)
\r
24263 PRDISP NTHTBL,IWTYP1,[[P2WORD,LNTH],[PNWORD,UNTH],[P2NWOR,VNTH],[PARGS,ANTH]
\r
24264 [PCHSTR,SNTH],[PTMPLT,TMPLNT]]
\r
24268 MFUNCTION GET,SUBR
\r
24271 MOVE E,IIGETP ; MAKE ARG CHECKER FAIL INTO GETPROP
\r
24272 PUSHJ P,ARGS5 ; CHECK ARGS
\r
24274 SKIPN E,IGETBL(E) ; GET DISPATCH ADR
\r
24275 JRST IGETP ; REALLY PUTPROP
\r
24277 PUSHJ P,(E) ; DISPATCH
\r
24280 PRDISP IGETBL,0,[[P2WORD,LNTH],[PNWORD,UNTH],[P2NWORD,VNTH],[PARGS,ANTH]
\r
24281 [PCHSTR,SNTH],[PTMPLT,TMPLNT]]
\r
24285 MFUNCTION GETL,SUBR
\r
24288 MOVE E,IIGETL ; ERROR HACK
\r
24290 SOJL C,OUTRNG ; LOSER
\r
24291 SKIPN E,IGTLTB(E)
\r
24292 JRST IGETLO ; REALLY GETPL
\r
24294 PUSHJ P,(E) ; DISPATCH
\r
24297 IIGETL: JRST IGETLO
\r
24299 PRDISP IGTLTB,0,[[P2WORD,LAT],[PNWORD,UAT],[P2NWORD,VAT],[PARGS,AAT]
\r
24303 ; ARG CHECKER FOR PUT/GET/GETL
\r
24305 ARGS5: HLRE 0,AB ; -# OF ARGS
\r
24307 ADDI 0,2 ; 0 OR -1 WIN
\r
24309 AOJL 0,TMA ; MORE THAN 3
\r
24310 JRST ARGS3 ; GET ARGS
\r
24314 MFUNCTION PUT,SUBR
\r
24318 PUSHJ P,ARGS5 ; GET ARGS
\r
24319 SKIPN E,IPUTBL(E)
\r
24321 CAML AB,[-5,,] ; SKIP IF GOOD ARRGS
\r
24327 MOVE A,(AB) ; RET STRUCTURE
\r
24331 PRDISP IPUTBL,0,[[P2WORD,LPUT],[PNWORD,UPUT],[P2NWORD,VPUT],[PARGS,APUT]
\r
24332 [PCHSTR,SPUT],[PTMPLT,TMPPUT]]
\r
24336 MFUNCTION IN,SUBR
\r
24340 MOVEI B,(AB) ; POINT TO ARG
\r
24342 MOVS E,A ; REAL DISPATCH TO E
\r
24345 GETYP C,A ; IN CASE NEEDED
\r
24346 PUSHJ P,@INTBL(E)
\r
24349 PRDISP INTBL,OTHIN,[[P2WORD,LNTH1],[PNWORD,UIN],[P2NWORD,VIN],[PARGS,AIN]
\r
24350 [PCHSTR,SIN],[PTMPLT,TIN]]
\r
24352 OTHIN: CAIE C,TLOCN ; ASSOCIATION LOCATIVE
\r
24353 JRST OTHIN1 ; MAYBE LOCD
\r
24360 OTHIN1: CAIE C,TLOCD
\r
24367 MFUNCTION SETLOC,SUBR
\r
24371 MOVEI B,(AB) ; POINT TO ARG
\r
24372 PUSHJ P,PTYPE ; DO TYPE
\r
24373 MOVS E,A ; REAL TYPE
\r
24375 MOVE C,2(AB) ; PASS ARG
\r
24377 MOVE A,(AB) ; IN CASE
\r
24379 PUSHJ P,@SETTBL(E)
\r
24384 PRDISP SETTBL,OTHSET,[[P2WORD,LSTUF],[PNWORD,USTUF],[P2NWORD,VSTUF],[PARGS,ASTUF]
\r
24385 [PCHSTR,SSTUF],[PTMPLT,TSTUF]]
\r
24387 OTHSET: CAIE 0,TLOCN ; ASSOC?
\r
24389 HLLZ 0,VAL(B) ; GET MONITORS
\r
24395 OTHSE1: CAIE 0,TLOCD
\r
24399 ; LREST -- REST A LIST IN B BY AMOUNT IN C
\r
24401 LREST: MOVSI A,TLIST
\r
24403 MOVEM A,BSTO(PVP)
\r
24405 LREST2: INTGO ;CHECK INTERRUPTS
\r
24406 JUMPE B,OUTRNG ; CANT CDR NIL
\r
24407 HRRZ B,(B) ;CDR THE LIST
\r
24408 SOJG C,LREST2 ;COUNT DOWN
\r
24409 SETZM BSTO(PVP) ;RESET BSTO
\r
24413 ; VREST -- REST A VECTOR, AREST -- REST AN ARG BLOCK
\r
24415 VREST: SKIPA A,$TVEC ; FINAL TYPE
\r
24416 AREST: HRLI A,TARGS
\r
24417 ASH C,1 ; TIMES 2
\r
24420 ; UREST -- REST A UVECTOR
\r
24422 STORST: SKIPA A,$TSTORA
\r
24423 UREST: MOVSI A,TUVEC
\r
24424 UREST1: JUMPE C,CPOPJ
\r
24427 ADD B,C ; REST IT
\r
24428 CAILE B,-1 ; OUT OF RANGE ?
\r
24433 ; SREST -- REST A STRING
\r
24435 SREST: JUMPE C,SREST1
\r
24436 PUSH P,A ; SAVE TYPE WORD
\r
24437 PUSH P,C ; SAVE AMOUNT
\r
24438 MOVEI D,(A) ; GET LENGTH
\r
24439 CAILE C,(D) ; SKIP IF OK
\r
24441 LDB D,[366000,,B] ;POSITION FIELD OF BYTE POINTER
\r
24442 LDB A,[300600,,B] ;SIZE FIELD
\r
24443 PUSH P,A ;SAVE SIZE
\r
24444 IDIVI D,(A) ;COMPUT BYTES IN 1ST WORD
\r
24445 MOVEI 0,36. ;NOW COMPUTE BYTES PER WORD
\r
24446 IDIVI 0,(A) ;BYTES PER WORD IN 0
\r
24447 MOVE E,0 ;COPY OF BYTES PER WORD TO E
\r
24448 SUBI 0,(D) ;0 # OF UNSUED BYTES IN 1ST WORD
\r
24449 ADDB C,0 ;C AND 0 NO.OF CHARS FROM WORD BOUNDARY
\r
24450 IDIVI C,(E) ;C/ REL WORD D/ CHAR IN LAST
\r
24451 ADDI C,(B) ;POINTO WORD WITH C
\r
24452 POP P,A ;RESTORE BITS PER BYTE
\r
24453 IMULI A,(D) ;A/ BITS USED IN LAST WORD
\r
24455 SUBI 0,(A) ;0 HAS NEW POSITION FIELD
\r
24456 DPB 0,[360600,,B] ;INTO BYTE POINTER
\r
24457 HRRI B,(C) ;POINT TO RIGHT WORD
\r
24458 POP P,C ; RESTORE AMOUNT
\r
24460 SUBI A,(C) ; NEW LENGTH
\r
24461 SREST1: HRLI A,TCHSTR
\r
24464 ; TMPRST -- REST A TEMPLATE DATA STRUCTURE
\r
24466 TMPRST: PUSHJ P,TM.TOE ; CHECK ALL BOUNDS ETC.
\r
24469 MOVE B,C ; RET IN B
\r
24473 ; LAT -- GET A LOCATIVE TO A LIST
\r
24475 LAT: PUSHJ P,LREST ; GET POINTER
\r
24476 JUMPE B,OUTRNG ; YOU LOSE!
\r
24477 MOVSI A,TLOCL ; NEW TYPE
\r
24481 ; UAT -- GET A LOCATIVE TO A UVECTOR
\r
24483 UAT: PUSHJ P,UREST
\r
24487 ; VAT -- GET A LOCATIVE TO A VECTOR
\r
24489 VAT: PUSHJ P,VREST ; REST IT AND TYPE IT
\r
24493 ; AAT -- GET A LOCATIVE TO AN ARGS BLOCK
\r
24495 AAT: PUSHJ P,AREST
\r
24497 POPJL: JUMPGE B,OUTRNG ; LOST
\r
24500 ; STAT -- LOCATIVE TO A STRING
\r
24502 STAT: PUSHJ P,SREST
\r
24503 TRNN A,-1 ; SKIP IF ANY LEFT
\r
24505 HRLI A,TLOCS ; LOCATIVE
\r
24508 ; TAT -- LOCATIVE TO A TEMPLATE
\r
24510 TAT: PUSHJ P,TMPRST
\r
24513 GETYP A,(B) ; GET REAL SAT
\r
24515 HRLS A ; READY TO HIT TABLE
\r
24516 ADD A,TD.LNT+1(TVP)
\r
24518 MOVE C,B ; DATUM TO C
\r
24519 XCT (A) ; GET LENGTH
\r
24520 HLRZS C ; REST COUNTER
\r
24521 SUBI B,(C) ; FLUSH IT OFF
\r
24529 ; LNTH -- NTH OF LIST
\r
24531 LNTH: PUSHJ P,LAT
\r
24532 LNTH1: PUSHJ P,RMONC0 ; CHECK READ MONITORS
\r
24533 HLLZ A,(B) ; GET GOODIE
\r
24535 JSP E,CHKAB ; HACK DEFER
\r
24538 ; VNTH -- NTH A VECTOR, ANTH -- NTH AN ARGS BLOCK
\r
24540 ANTH: PUSHJ P,AAT
\r
24543 VNTH: PUSHJ P,VAT
\r
24545 VIN: PUSHJ P,RMONC0
\r
24550 ; UNTH -- NTH OF UVECTOR
\r
24552 UNTH: PUSHJ P,UAT
\r
24553 UIN: HLRE C,B ; FIND DW
\r
24555 HLLZ 0,(C) ; GET MONITORS
\r
24557 TLZ D,TYPMSK#<-1>
\r
24559 PUSHJ P,RMONCH ; CHECK EM
\r
24561 MOVE B,(B) ; AND VALUE
\r
24565 ; SNTH -- NTH A STRING
\r
24567 SNTH: PUSHJ P,STAT
\r
24569 PUSH TP,B ; SAVE POINT BYTER
\r
24570 MOVEI C,-1(TP) ; FIND DOPE WORD
\r
24572 HLLZ 0,-1(A) ; GET
\r
24576 ILDB B,B ; GET CHAR
\r
24580 ; TIN -- IN OF A TEMPLATE
\r
24584 ; TMPLNT -- NTH A TEMPLATE DATA STRUCTURE
\r
24587 PUSHJ P,TM.TOE ; GET POINTER TO INS IN E
\r
24588 ADD A,TD.GET+1(TVP) ; POINT TO GETTER
\r
24589 MOVE A,(A) ; GET VECTOR OF INS
\r
24590 ADDI E,-1(A) ; POINT TO INS
\r
24595 ; LPUT -- PUT ON A LIST
\r
24597 LPUT: PUSHJ P,LAT ; POSITION
\r
24601 ; LSTUF -- HERE TO STUFF A LIST ELEMENT
\r
24603 LSTUF: PUSHJ P,MONCH0 ; CHECK OUT MONITOR BITS
\r
24604 GETYP A,C ; ISOLATE TYPE
\r
24605 PUSHJ P,NWORDT ; NEED TO DEFER?
\r
24608 MOVEM D,1(B) ; AND VAL
\r
24611 DEFSTU: PUSH TP,$TLIST
\r
24615 PUSHJ P,CELL2 ; GET WORDS
\r
24621 HLLZ 0,(E) ; GET OLD MONITORS
\r
24622 TLZ 0,TYPMSK ; KILL TYPES
\r
24623 TLO 0,TDEFER ; MAKE DEFERRED
\r
24627 ; VPUT -- PUT ON A VECTOR , APUT -- PUT ON AN RG BLOCK
\r
24629 APUT: PUSHJ P,AAT
\r
24632 VPUT: PUSHJ P,VAT ; TREAT LIKE VECTOR
\r
24633 POP TP,D ; GET GOODIE BACK
\r
24636 ; AVSTUF -- CLOBBER ARGS AND VECTORS
\r
24639 VSTUF: PUSHJ P,MONCH0
\r
24647 ; UPUT -- CLOBBER A UVECTOR
\r
24649 UPUT: PUSHJ P,UAT ; GET IT RESTED
\r
24653 ; USTUF -- HERE TO CLOBBER A UVECTOR
\r
24656 SUBM B,E ; C POINTS TO DOPE
\r
24657 GETYP A,(E) ; GET UTYPE
\r
24659 CAIE 0,(A) ; CHECK SAMENESS
\r
24661 HLLZ 0,(E) ; MONITOR BITS IN DOPE WORD
\r
24664 MOVEM D,(B) ; SMASH
\r
24667 ; SPUT -- HERE TO PUT A STRING
\r
24669 SPUT: PUSHJ P,STAT ; REST IT
\r
24673 ; SSTUF -- STUFF A STRING
\r
24675 SSTUF: GETYP 0,C ; BETTER BE CHAR
\r
24680 MOVEI C,-1(TP) ; FIND D.W.
\r
24682 HLLZ 0,(A)-1 ; GET MONITORS
\r
24690 ; TSTUF -- SETLOC A TEMPLATE
\r
24696 ; PUTTMP -- TEMPLATE PUTTER
\r
24699 PUSHJ P,TM.TOE ; GET E POINTING TO SLOT #
\r
24700 ADD A,TD.PUT+1(TVP) ; POINT TO INS
\r
24701 MOVE A,(A) ; GET VECTOR OF INS
\r
24703 POP TP,B ; NEW VAL TO A AND B
\r
24710 TM.LN1: SUBI 0,NUMSAT+1
\r
24711 HRRZ A,0 ; RET FIXED OFFSET
\r
24713 ADD 0,TD.LNT+1(TVP) ; USE LENGTHERS FOR TEST
\r
24717 HRRZS 0 ; POINT TO TABLE ENTRY
\r
24724 TM.TBL: MOVEI E,(D) ; TENTATIVE WINNER IN E
\r
24725 TLNN B,-1 ; SKIP IF REST HAIR EXISTS
\r
24726 POPJ P, ; NO, WIN
\r
24728 PUSH P,A ; SAVE OFFSET
\r
24729 HRLS A ; A IS REL OFFSET TO INS TABLE
\r
24730 ADD A,TD.GET+1(TVP) ; GET ONEOF THE TABLES
\r
24731 MOVE A,(A) ; TABLE POINTER TO A
\r
24732 MOVSI 0,-1(D) ; START SEEING IF PAST TEMP SPEC
\r
24734 JUMPL 0,CPOPJA ; JUMP IF E STILL VALID
\r
24735 HLRZ E,B ; BASIC LENGTH TO E
\r
24736 HLRE 0,A ; LENGTH OF TEMPLATE TO 0
\r
24737 ADDI 0,(E) ; 0 ==> # ELEMENTS IN REPEATING SEQUENCE
\r
24739 SUBM D,E ; E ==> # PAST BASIC WANTED
\r
24741 IDIVI 0,(E) ; A ==> REL REST GUY WANTED
\r
24747 ; TM.TOE -- GET RIGHT TEMPLATE # IN E
\r
24748 ; C/ OBJECT #, B/ OBJECT POINTER
\r
24750 TM.TOE: GETYP 0,(B) ; GET REAL SAT
\r
24751 MOVEI D,(C) ; OBJ # TO D
\r
24752 HLRZ C,B ; REST COUNT
\r
24753 ADDI D,(C) ; FUDGE FOR REST COUNTER
\r
24754 MOVE C,B ; POINTER TO C
\r
24755 PUSHJ P,TM.LN1 ; GET LENGTH IN B (WATCH LH!)
\r
24756 CAILE D,(B) ; CHECK RANGE
\r
24757 JRST OUTRNG ; LOSER, QUIT
\r
24758 JRST TM.TBL ; GO COMPUTE TABLE OFFSET
\r
24760 \f; ROUTINE FOR COMPILER CALLS RETS CODE IN E GOODIE IN A AND B
\r
24771 ; COMPILER CALLS TO MANY OF THESE GUYS
\r
24773 CIREST: PUSHJ P,CPTYEE ; TYPE OF DISP TO E
\r
24777 PUSHJ P,@RESTBL(E)
\r
24780 CIRST1: PUSHJ P,STORST
\r
24783 CINTH: PUSHJ P,CPTYEE
\r
24784 SOJL C,OUTRNG ; CHECK BOUNDS
\r
24785 PUSHJ P,@NTHTBL(E)
\r
24788 CIAT: PUSHJ P,CPTYEE
\r
24790 PUSHJ P,@ATTBL(E)
\r
24793 CSETLO: PUSHJ P,CTYLOC
\r
24794 MOVSS E ; REAL DISPATCH
\r
24795 GETYP 0,A ; INCASE LOCAS OR LOCD
\r
24798 PUSHJ P,@SETTBL(E)
\r
24803 CIN: PUSHJ P,CTYLOC
\r
24804 MOVSS E ; REAL DISPATCH
\r
24806 PUSHJ P,@INTBL(E)
\r
24816 ; COMPILER'S PUT,GET AND GETL
\r
24818 CIGET: PUSH P,[0]
\r
24821 CIGETL: PUSH P,[1]
\r
24826 JUMPE E,CIGET1 ; REAL GET, NOT NTH
\r
24827 GETYP 0,C ; INDIC FIX?
\r
24830 POP P,E ; GET FLAG
\r
24831 AOS (P) ; ALWAYS SKIP
\r
24832 MOVE C,D ; # TO AN AC
\r
24837 CIGET1: POP P,E ; GET FLAG
\r
24838 JRST @GETTR(E) ; DO A REAL GET
\r
24843 CIPUT: SUBM M,(P)
\r
24848 PUSH TP,-1(TP) ; PAIN AND SUFFERING
\r
24854 CAIE 0,TFIX ; YES DO STRUCT
\r
24857 SOJL C,OUTRNG ; CHECK BOUNDS
\r
24858 PUSHJ P,@IPUTBL(E)
\r
24863 CIPUT1: PUSHJ P,IPUT
\r
24866 ; SMON -- SET MONITOR BITS
\r
24867 ; B/ <POINTER TO LOCATIVE>
\r
24868 ; D/ <IORM> OR <ANDCAM>
\r
24871 SMON: GETYP A,(B)
\r
24872 PUSHJ P,PTYPE ; TO PRIM TYPE
\r
24874 SKIPE A,SMONTB(A) ; DISPATCH?
\r
24877 ; COULD STILL BE LOCN OR LOCD
\r
24879 GETYP A,(B) ; TYPE BACK
\r
24881 JRST SMON2 ; COULD BE LOCD
\r
24882 MOVE C,1(B) ; POINT
\r
24883 HRRI D,VAL(C) ; MAKE INST POINT
\r
24886 SMON2: CAIE A,TLOCD
\r
24890 ; SET LIST/TUPLE/ID LOCATIVE
\r
24892 SMON4: HRR D,1(B) ; POINT TO TYPE WORD
\r
24898 SMON5: HRRZ C,1(B) ; POINT TO TOP OF UV
\r
24900 SUB C,0 ; POINT TO DOPE
\r
24901 HRRI D,(C) ; POINT IN INST
\r
24906 SMON6: MOVEI C,(B) ; FOR BYTDOP
\r
24907 PUSHJ P,BYTDOP ; POINT TO DOPE
\r
24911 PRDISP SMONTB,0,[[P2WORD,SMON4],[P2NWOR,SMON4],[PARGS,SMON4]
\r
24912 [PNWORD,SMON5],[PCHSTR,SMON6]]
\r
24915 ; COMPILER'S MONAD?
\r
24927 ; FUNCTION TO DECIDE IF FURTHER DECOMPOSITION POSSIBLE
\r
24929 MFUNCTION MONAD,SUBR,MONAD?
\r
24933 MOVE B,AB ; CHECK PRIM TYPE
\r
24935 JUMPE A,ITRUTH ;RETURN ARGUMENT
\r
24937 JRST @MONTBL(A) ;DISPATCH ON PTYPE
\r
24940 PRDISP MONTBL,IFALSE,[[P2NWORD,MON1],[PNWORD,MON1],[PARGS,MON1]
\r
24941 [PCHSTR,CHMON],[PTMPLT,TMPMON]]
\r
24943 MON1: JUMPGE B,ITRUTH ;EMPTY VECTOR
\r
24946 CHMON: HRRZ B,(AB)
\r
24950 TMPMON: PUSHJ P,LNTMPL
\r
24954 CISTRU: GETYP A,A ; COMPILER CALL
\r
24959 ISTRUC: PUSHJ P,SAT ; STORAGE TYPE
\r
24960 SKIPE A,PRMTYP(A)
\r
24961 AOS (P) ; SKIP IF WINS
\r
24964 ; SUBR TO CHECK FOR LOCATIVE
\r
24966 MFUNCTION %LOCA,SUBR,[LOCATIVE?]
\r
24974 ; SKIPS IF TYPE IN A IS A LOCATIVE
\r
24976 LOCQ: GETYP A,(B) ; GET TYPE
\r
24977 LOCQQ: PUSH P,A ; SAVE FOR LOCN/LOCD
\r
24986 LOCQ1: POP P,A ; RESTORE TYPE
\r
24993 ; MUDDLE SORT ROUTINE
\r
24995 ; P-STACK OFFSETS MUDDLE SORT ROUTINE
\r
24997 ; P-STACK OFFSETS FOR THIS PROGRAM
\r
24999 XCHNG==0 ; FLAG SAYING AN EXCHANGE HAS HAPPENED
\r
25000 PLACE==-1 ; WHERE WE ARE NOW
\r
25001 UTYP==-2 ; TYPE OF UNIFORM VECTOR
\r
25002 DELT==-3 ; DIST BETWEEN COMPARERS
\r
25004 MFUNCTION SORT,SUBR
\r
25008 HLRZ 0,AB ; CHECK FOR ENOUGH ARGS
\r
25011 GETYP A,(AB) ; 1ST MUST EITHER BE FALSE OR APPLICABLE
\r
25013 JRST SORT1 ; FALSE, OK
\r
25014 PUSHJ P,APLQ ; IS IT APPLICABLE
\r
25015 JRST NAPT ; NO, LOSER
\r
25018 ADD B,[2,,2] ; BUMP TO POINT TO MAIN ARRAY
\r
25019 SETZB D,E ; 0 # OF STUCS AND LNTH
\r
25021 SORT2: GETYP A,(B) ; GET ITS TYPE
\r
25022 PUSHJ P,PTYPE ; IS IT STRUCTURED?
\r
25023 MOVEI C,1 ; CHECK TYPE OF STRUC
\r
25024 CAIN A,PNWORD ; UVEC?
\r
25027 CAIN A,P2NWORD ; VECTOR
\r
25030 PUSH TP,(B) ; PUSH IT
\r
25032 ADD B,[2,,2] ; GO ON
\r
25033 MOVEI A,1 ; DEFAULT REC SIZE
\r
25034 PUSHJ P,NXFIX ; SIZE OF RECORD?
\r
25035 HLRZ 0,-2(TP) ; -LNTH OF STUC
\r
25036 HRRZ A,(TP) ; LENGTH OF REC
\r
25037 IDIVI 0,(A) ; DIV TO GET - # OF RECS
\r
25038 SKIPN D ; PREV LENGTH EXIST?
\r
25039 MOVE D,0 ; NO USE THIS
\r
25042 MOVEI A,0 ; DEF REC SIZE
\r
25043 PUSHJ P,NXFIX ; AND OFFSET OF KEY
\r
25045 JUMPL B,SORT2 ; GO ON
\r
25046 HRRM E,4(TB) ; SAVE THAT IN APPROPRIATE PLACE
\r
25049 CAMG 0,5(TB) ; CHECK FOR BAD OFFSET
\r
25052 ; NOW CHECK WHATEVER STUCTURE THIS IS IS UNIFORM AND HAS GOOD ELEMENTS
\r
25054 HLRE B,1(TB) ; COMP LENGTH
\r
25056 HRRZ C,2(TB) ; GET VEC/UVEC FLAG
\r
25058 ASH B,(C) ; FUDGE
\r
25059 JUMPE C,.+3 ; SKIP FOR UVEC
\r
25060 MOVE 0,[1,,1] ; ELSE FUDGE KEY OFFSET
\r
25062 HRRZ 0,3(TB) ; GET REC LENGTH
\r
25063 IDIV D,0 ; # OF RECS
\r
25065 CAIG D,1 ; MORE THAN 1?
\r
25066 JRST SORTD ; NO, DONE ALREADY
\r
25067 GETYP 0,(AB) ; TYPE OF COMPARER
\r
25068 CAIE 0,TFALSE ; IF FALSE, STRUCT MUST CONTAIN FIX,FLOAT,ATOM OR STRING
\r
25069 JRST SORT3 ; USER SUPPLIED COMPARER, LET HIM WORRY
\r
25071 ; NOW CHECK OUT ELEMENT TYPES
\r
25073 JUMPN C,SORT5 ; JUMP IF GENERAL
\r
25074 MOVEI D,1(B) ; FIND END OF VECTOR
\r
25075 ADD D,1(TB) ; D POINTS TO END
\r
25076 PUSHJ P,TYPCH1 ; GET TYPE AND CHECK IT
\r
25079 SORT5: MOVE D,1(TB) ; POINT TO VEC
\r
25080 ADD D,5(TB) ; INTO REC TO KEY
\r
25083 SAMELP: GETYP C,-1(D) ; GET TYPE
\r
25084 CAIE 0,(C) ; COMPARE TYPE
\r
25086 ADD D,3(TB) ; TO NEXT RECORD
\r
25089 SORT6: CAIE A,S1WORD ; 1 WORDS?
\r
25092 MOVSI A,400000 ; SET UP MASK
\r
25093 SORT9: PUSHJ P,ISORT
\r
25098 SORT7: CAIE A,SATOM ; ATOMS?
\r
25100 MOVE E,[-3,,ATMSRT] ; SET UP FOR ATOMS
\r
25101 MOVE A,[430140,,3(D)] ; BIT POINTER FOR ATOMS
\r
25104 SORT8: MOVE E,[1,,STRSRT] ; MUST BE STRING SORT
\r
25105 MOVE A,[430140,,(D)] ; BYTE POINTER FOR STRINGER
\r
25108 ; TABLES FOR RADIX SORT CHECKERS
\r
25114 TST1: PUSHJ P,I.TST1
\r
25118 TST2: PUSHJ P,I.TST2
\r
25134 ; INTEGER SORT SPECIFIC ROUTINES
\r
25136 I.TST1: JUMPL A,I.TST3
\r
25137 I.TST4: TDNE A,(D)
\r
25141 I.TST2: JUMPL A,I.TST4
\r
25142 I.TST3: TDNN A,(D)
\r
25146 ; ATOM SORT SPECIFIC ROUTINES
\r
25148 A.TST1: MOVE D,(D) ; GET AN ATOM
\r
25149 CAMG E,D ; SKIP IF NOT EXHAUSTED
\r
25151 TLZ A,40 ; TELL A BIT HAS HAPPENED
\r
25152 LDB D,A ; GET THE BIT
\r
25154 AOS (P) ; SKIP IF ON
\r
25157 A.TST2: PUSHJ P,A.TST1 ; USE OTHER ROUTINE
\r
25161 A.NXBI: TLNN A,770000 ; CHECK FOR WORD CHANGE
\r
25162 SUB E,[1,,0] ; FIX WORD CHECKER
\r
25166 A.PREB: ADD A,[10000,,] ; AH FOR A DECR BYTE POINTER
\r
25168 CAMG A,[437777,,-1] ; SKIP IF BACKED OVER WORD
\r
25170 TLZ A,770000 ; CLOBBER POSIT FIELD
\r
25171 SUBI A,1 ; DECR WORD POS FIELD
\r
25172 ADD E,[1,,0] ; AND FIX WORD HACKER
\r
25175 ; STRING SPECIFIC SORT ROUTINES
\r
25177 S.TST1: HRLZ 0,-1(D) ; LENGTH OF STRING
\r
25178 IMULI 0,7 ; IN BITS
\r
25179 HRRI 0,-1 ; MAKE SURE BIGGER RH
\r
25180 CAMG 0,E ; SKIP IF MORE BITS LEFT
\r
25181 POPJ P, ; DON TSKIP
\r
25182 TLZ A,40 ; BIT FOUND
\r
25183 HLRZ 0,(D) ; CHECK FOR SIMPLE CASE
\r
25184 HRRZ D,(D) ; POINT TO STRING
\r
25185 CAIN 0,440700 ; SKIP IF HAIRY
\r
25188 PUSH P,A ; SAVE BYTER
\r
25189 MOVEI A,440700 ; COMPUTE BITS NOT USED 1ST WORD
\r
25191 HLRZ 0,(P) ; GET BIT POINTER
\r
25192 SUBI 0,(A) ; UPDATE POS FIELD
\r
25193 JUMPGE 0,.+2 ; NO NEED FOR NEXT WORD
\r
25194 ADD 0,[1,,440000]
\r
25196 HRRZ A,(P) ; REBUILD BYTE POINTER
\r
25198 LDB 0,0 ; GET THE DAMN BYTE
\r
25202 S.TST3: LDB 0,A ; GET BYTE FOR EASY CASE
\r
25207 S.TST2: PUSHJ P,S.TST1
\r
25211 S.NXBI: IBP A ; BUMP BYTER
\r
25212 TLNN A,770000 ; SKIP IF NOT END BIT
\r
25213 IBP A ; SKIP END BIT (NOT USED IN ASCII STRINGS)
\r
25214 ADD E,[1,,0] ; COUNT BIT
\r
25217 S.PREB: SUB E,[1,,0] ; DECR CHAR COUNT
\r
25218 ADD A,[10000,,0] ; PLEASE GIVE ME A DECRBYTEPNTR
\r
25220 CAMG A,[437777,,-1]
\r
25222 TLC A,450000 ; POINT TO LAST USED BIT IN WORD
\r
25226 ; SIMPLE RADIX EXCHANGE
\r
25228 ISORT: MOVE B,1(TB) ; START OF VECTOR
\r
25229 HLRE D,B ; COMPUTE POINTER TO END OF IT
\r
25230 SUBM B,D ; FIND END
\r
25233 ISORT1: PUSH TP,(TB)
\r
25235 MOVE 0,C ; SEE IF HAVE MET AT MIDDLE
\r
25239 JRST ISORT7 ; HAVE MET, LEAVE
\r
25240 PUSH TP,(TB) ; SAVE OTHER POINTER
\r
25244 MOVE B,(TP) ; IN CASE MOVED
\r
25247 ISORT3: HRRZ D,5(TB) ; OFFSET TO KEY
\r
25248 ADDI D,(B) ; POINT TO KEY
\r
25249 XCT TST1(E) ; CHECK FOR LOSER
\r
25251 SUB C,3(TB) ; IS THERE ONE TO EXCHANGE WITH
\r
25254 XCT TST2(E) ; SKIP IF A POSSIBLE EXCHANGE
\r
25255 JRST ISORT2 ; NO EXCH, KEEP LOOKING
\r
25257 PUSHJ P,EXCHM ; DO THE EXCHANGE
\r
25259 ISORT4: ADD B,3(TB) ; HAVE EXCHANGED, MOVE ON
\r
25260 ISORT2: CAME B,C ; MET?
\r
25261 JRST ISORT3 ; MORE TO CHECK
\r
25262 XCT NXBIT(E) ; NEXT BIT
\r
25263 MOVE B,(TP) ; RESTORE TOP POINTER
\r
25264 SUB TP,[2,,2] ; FLUSH IT
\r
25267 PUSHJ P,ISORT1 ; SORT SUB AREA
\r
25268 MOVE C,(TP) ; AND OTHER SUB AREA
\r
25270 ISORT6: XCT PREBIT(E)
\r
25271 ISORT7: MOVE B,(TP)
\r
25275 ; SCHELL SORT FOR USER SUPPLIED COMPARER
\r
25278 ASH D,-1 ; COMPUTE INITIAL D
\r
25279 PUSH P,D ; AND SAVE IT
\r
25280 PUSH P,[0] ; MAY HOLD UTYPE OF VECTOR
\r
25281 HRRZ 0,(TB) ; 0 NON ZERO MEANS GEN VECT
\r
25282 JUMPN 0,SSORT1 ; DONT COMPUTE UTYPE
\r
25284 HRRZ D,1(TB) ; FIND TYPE
\r
25287 MOVSM D,(P) ; AND SAVE
\r
25288 SSORT1: PUSH P,[0] ; CURRENT PLACE IN VECTOR
\r
25289 PUSH P,[0] ; EXCHANGE FLAG
\r
25293 ; OUTER LOOP STARTS HERE
\r
25295 OUTRLP: SETZM XCHNG(P) ; NO EXHCANGE YET
\r
25298 INRLP: PUSH TP,(AB) ; PUSH USER COMPARE FCN
\r
25300 MOVE C,PLACE(P) ; GET CURRENT PLACE
\r
25301 ADD C,1(TB) ; ADD POINTER TO VEC IN
\r
25302 ADD C,5(TB) ; OFFSET TO KEY
\r
25305 IMUL D,DELT(P) ; TIMES WORDS PER REC
\r
25308 MCALL 3,APPLY ; APPLY IT
\r
25309 GETYP 0,A ; TYPE OF RETURN
\r
25310 CAIN 0,TFALSE ; SKIP IF MUST CHANGE
\r
25313 MOVE C,1(TB) ; POINT TO START
\r
25318 PUSHJ P,EXCHM ; EXCHANGE THEM
\r
25319 SETOM XCHNG(P) ; SAY AN EXCHANGE TOOK PLACE
\r
25321 INRLP1: MOVE C,3(TB) ; GET OFFSET
\r
25325 ADD C,D ; CHECK FOR OVERFLOW
\r
25328 SKIPE XCHNG(P) ; ANY EXCHANGES?
\r
25329 JRST OUTRLP ; YES, RESET PLACE AND GO
\r
25330 SOSG D,DELT(P) ; SKIP IF DIST WAS 1
\r
25332 ADDI D,2 ; COMPUTE NEW DIST
\r
25337 SORTD: MOVE A,2(AB) ; DONE, RET 1ST STRUC
\r
25341 ; ROUTINE TO GET NEXT ARG IF ITS FIX
\r
25343 NXFIX: JUMPGE B,NXFIX1 ; NONE LEFT, USE DEFAULT
\r
25344 GETYP 0,(B) ; TYPE
\r
25345 CAIE 0,TFIX ; FIXED?
\r
25346 JRST NXFIX1 ; NO, USE DEFAULT
\r
25347 MOVE A,1(B) ; GET THE NUMBER
\r
25348 ADD B,[2,,2] ; BUMP TO NEXT ARG
\r
25349 NXFIX1: HRLI C,TFIX
\r
25350 TRNE C,-1 ; SKIP IF UV
\r
25351 ASH A,1 ; FUDGE FOR VEC/UVEC
\r
25357 GETELM: SKIPN A,UTYP-1(P) ; SKIP IF UVECT
\r
25358 MOVE A,-1(C) ; GGET GEN TYPE
\r
25363 TYPCH1: GETYP A,-1(D) ; GET TYPE
\r
25364 MOVEI 0,(A) ; SAVE IN 0
\r
25365 PUSHJ P,SAT ; AND SAT
\r
25366 CAIE A,SCHSTR ; STRING
\r
25369 CAIN A,S1WORD ; 1-WORD GOODIE
\r
25373 ; HERE TO DO EXCHANGE
\r
25376 PUSH P,A ; SAVE VITAL ACS
\r
25379 SUB B,1(TB) ; COMPUTE RECORD #
\r
25381 HRRZ 0,3(TB) ; GET REC LENGTH
\r
25382 IDIV B,0 ; DIV BY REC LENGTH
\r
25384 SUB C,1(TB) ; SAME FOR C
\r
25386 IDIV C,0 ; NOW HAVE OTHER RECORD
\r
25388 HRRE D,4(TB) ; - # OF STUCS
\r
25389 MOVSI D,(D) ; MAKE AN AOBJN POINTER
\r
25390 HRRI D,(TB) ; TO TEMPPS
\r
25392 RECLP: HRRZ 0,3(D) ; GET REC LENGTH
\r
25393 MOVN E,3(D) ; NOW AOBJN TO REC
\r
25396 MOVEI A,(C) ; COMP START OF REC
\r
25397 IMUL A,0 ; TIMES REC LENGTH
\r
25401 ADD A,1(D) ; POINT TO OTHER RECORD
\r
25403 EXCHLP: EXCH 0,(A)
\r
25409 ADD D,[1,,6] ; TO NEXT STRUC
\r
25410 JUMPL D,RECLP ; IF MORE
\r
25418 ; FUNCTION TO DETERMINE MEMBERSHIP IN LISTS AND VECTORS
\r
25420 MFUNCTION MEMBER,SUBR
\r
25422 MOVE E,[PUSHJ P,EQLTST] ;TEST ROUTINE IN E
\r
25425 MFUNCTION MEMQ,SUBR
\r
25427 MOVE E,[PUSHJ P,EQTST] ;EQ TESTER
\r
25430 MOVE B,AB ;POINT TO FIRST ARG
\r
25431 PUSHJ P,PTYPE ;CHECK PRIM TYPE
\r
25432 ADD B,[2,,2] ;POINT TO 2ND ARG
\r
25434 JUMPE A,WTYP2 ;2ND WRONG TYPE
\r
25437 MOVE C,2(AB) ; FOR TUPLE CASE
\r
25438 SKIPE B,3(AB) ;GOBBLE LIST VECTOR ETC. POINTER
\r
25439 PUSHJ P,@MEMTBL(A) ;DISPATCH
\r
25440 JRST IFALSE ;OR REPORT LOSSAGE
\r
25443 PRDISP MEMTBL,IWTYP2,[[P2WORD,MEMLST],[PNWORD,MUVEC],[P2NWORD,MEMVEC]
\r
25444 [PARGS,MEMTUP],[PCHSTR,MEMCH],[PTMPLT,MEMTMP]]
\r
25448 MEMLST: MOVSI 0,TLIST ;SET B'S TYPE TO LIST
\r
25449 MOVEM 0,BSTO(PVP)
\r
25450 JUMPE B,MEMLS6 ; EMPTY LIST LOSE IMMEDIATE
\r
25452 MEMLS1: INTGO ;CHECK INTERRUPTS
\r
25453 MOVEI C,(B) ;COPY POINTER
\r
25454 GETYP D,(C) ;GET TYPE
\r
25455 MOVSI A,(D) ;COPY
\r
25456 CAIE D,TDEFER ;DEFERRED?
\r
25458 MOVE C,1(C) ;GET DEFERRED DATUM
\r
25459 GETYPF A,(C) ;GET FULL TYPE WORD
\r
25460 MEMLS2: MOVE C,1(C) ;GET DATUM
\r
25461 XCT E ;DO THE COMPARISON
\r
25462 JRST MEMLS3 ;NO MATCH
\r
25465 MEMLS6: SETZM BSTO(PVP) ;RESET B'S TYPE
\r
25468 MEMLS3: HRRZ B,(B) ;STEP THROGH
\r
25469 JUMPN B,MEMLS1 ;STILL MORE TO DO
\r
25470 MEMLS4: MOVSI A,TFALSE ;RETURN FALSE
\r
25471 JRST MEMLS6 ;RETURN 0
\r
25475 MEMVEC: MOVSI A,TVEC ;CLOBBER B'S TYPE TO VECTOR
\r
25476 JUMPGE B,MEMLS4 ;EMPTY VECTOR
\r
25477 MOVEM A,BSTO(PVP)
\r
25479 MEMV1: INTGO ;CHECK FOR INTS
\r
25480 GETYPF A,(B) ;GET FULL TYPE
\r
25481 MOVE C,1(B) ;AND DATA
\r
25482 XCT E ;DO COMPARISON INS
\r
25483 JRST MEMV2 ;NOT EQUAL
\r
25485 JRST MEMLS5 ;RETURN WITH POINTER
\r
25487 MEMV2: ADD B,[2,,2] ;INCREMENT AND GO
\r
25488 JUMPL B,MEMV1 ;STILL WINNING
\r
25490 JRST MEMLS4 ;AND RETURN FALSE
\r
25492 MUVEC: JUMPGE B,MEMLS4
\r
25493 GETYP A,-1(TP) ;GET TYPE OF GODIE
\r
25494 HLRE C,B ;LOOK FOR UNIFORM TYPE
\r
25495 SUBM B,C ;DOPE POINTER TO C
\r
25496 GETYP C,(C) ;GET THE TYPE
\r
25497 CAIE A,(C) ;ARE THEY THE SAME?
\r
25498 JRST MEMLS4 ;NO, LOSE
\r
25503 MOVEM A,BSTO(PVP)
\r
25504 MOVSI A,(C) ;TYPE TO LH
\r
25505 PUSH P,A ; SAVE FOR EACH TEST
\r
25507 MUVEC1: INTGO ;CHECK OUT INTS
\r
25508 MOVE C,(B) ;GET DATUM
\r
25509 MOVE A,(P) ; GET TYPE
\r
25511 AOBJN B,MUVEC1 ;LOOP TO WINNAGE
\r
25514 JUMPGE B,MEMV3 ;LOSE RETURN
\r
25516 MUVEC2: JRST MEMLS5
\r
25519 MEMCH: GETYP A,-1(TP) ;IS ARG A SINGLE CHAR
\r
25520 CAIE A,TCHRS ;SKIP IF POSSIBLE WINNER
\r
25523 MOVE D,(TP) ; AND CHAR
\r
25525 MEMCH1: SOJL 0,MEMV3
\r
25528 CAIE A,(D) ;CHECK IT
\r
25535 MEMSTR: CAME E,[PUSHJ P,EQLTST]
\r
25538 CAIE A, TCHSTR ; A SHOULD HAVE TCHSTR IN RIGHT HALF
\r
25540 MOVEI 0,(C) ; GET # OF CHAR INTO 0
\r
25542 PUSH P,D ; PUTS 1ST CHAR OF 1ST ARG ONTO STACK
\r
25544 MEMST1: SOJL 0,MEMLS ; HUNTS FOR FIRST MATCHING CHAR
\r
25548 SOJA C,MEMST1 ; MATCH FAILS TRY NEXT
\r
25554 MOVE E,(TP) ; MATCH WINS SAVE OLD VALUES FOR FAILING LOOP
\r
25555 HRRZ C,-1(TP) ; LENGTH OF 1ARG
\r
25556 MEMST2: SOJE C,MEMWN ; WON -RAN OUT OF 1ARG FIRST-
\r
25557 SOJL MEMLSR ; LOST -RAN OUT OF 2ARG-
\r
25560 CAIN A,(D) ; SKP IF POSSIBLY LOST -BACK TO MEMST1-
\r
25569 MEMWN: MOVE B,-2(P) ; SETS UP ARGS LIKE MEMCH2 - HAVE WON
\r
25574 MEMLSR: SUB P,[5,,5]
\r
25577 MEMLS: SUB P,[1,,1]
\r
25580 ; MEMBERSHIP FOR TEMPLATE HACKER
\r
25582 MEMTMP: GETYP 0,(B) ; GET REAL SAT
\r
25586 PUSH TP,B ; SAVE GOOEIE
\r
25587 PUSHJ P,TM.LN1 ; GET LENGTH
\r
25589 HLRZ A,(TP) ; FUDGE FOR REST
\r
25591 PUSH P,B ; SAVE LENGTH
\r
25595 MOVEM A,BSTO+1(PVP)
\r
25597 MEMTM1: SETZM BSTO(PVP)
\r
25602 PUSHJ P,TMPLNT ; GET ITEM
\r
25603 EXCH C,B ; VALUE TO C, POINTER BACK TO B
\r
25606 MOVEM 0,BSTO(PVP)
\r
25610 HRL B,(P) ; DO APPROPRIATE REST
\r
25612 MEMTM2: SUB P,[4,,4]
\r
25619 CAMN C,(TP) ;CHECK VALUE
\r
25620 CAIE 0,(A) ;AND TYPE
\r
25624 EQLTST: PUSH TP,BSTO(PVP)
\r
25629 PUSH P,E ;SAVE INS
\r
25630 MOVEI C,-5(TP) ;SET UP CALL TO IEQUAL
\r
25632 AOS -1(P) ;ASSUME SKIP
\r
25633 PUSHJ P,IEQUAL ;GO INO EQUAL
\r
25634 SOS -1(P) ;UNDO SKIP
\r
25635 SUB TP,[2,,2] ;AND POOP OF CRAP
\r
25641 ; COMPILER MEMQ AND MEMBER
\r
25643 CIMEMB: SKIPA E,[PUSHJ P,EQLTST]
\r
25645 CIMEMQ: MOVE E,[PUSHJ P,EQTST]
\r
25652 MOVE B,D ; STRUCT TO B
\r
25653 PUSHJ P,@MEMTBL(A)
\r
25654 TDZA 0,0 ; FLAG NO SKIP
\r
25655 MOVEI 0,1 ; FLAG SKIP
\r
25658 SOS (P) ; SKIP RETURN
\r
25662 ; FUNCTION TO RETURN THE TOP OF A VECTOR , CSTRING OR UNIFORM VECTOR
\r
25664 MFUNCTION TOP,SUBR
\r
25668 MOVE B,AB ;CHECK ARG
\r
25673 PUSHJ P,@TOPTBL(E) ;DISPATCH
\r
25676 PRDISP TOPTBL,IWTYP1,[[PNWORD,UVTOP],[P2NWORD,VTOP],[PCHSTR,CHTOP],[PARGS,ATOP]
\r
25679 BCKTOP: MOVEI B,(B) ; FIX UP POINTER
\r
25683 UVTOP: SKIPA A,$TUVEC
\r
25684 VTOP: MOVSI A,TVEC
\r
25687 HLRE C,B ;AND -LENGTH
\r
25689 SUB B,C ;POINT TO DOPE WORD
\r
25690 HLRZ D,1(B) ;TOTAL LENGTH
\r
25691 SUBI B,-2(D) ;POINT TO TOP
\r
25692 MOVNI D,-2(D) ;-LENGTH
\r
25693 HRLI B,(D) ;B NOW POINTS TO TOP
\r
25698 LDB 0,[360600,,(TP)] ; POSITION FIELD
\r
25699 LDB E,[300600,,(TP)] ; AND SIZE FILED
\r
25700 IDIVI 0,(E) ; 0/ BYTES IN 1ST WORD
\r
25701 MOVEI C,36. ; BITS PER WORD
\r
25702 IDIVI C,(E) ; BYTES PER WORD
\r
25704 SUBM C,0 ; UNUSED BYTES I 1ST WORD
\r
25705 ADD 0,-1(TP) ; LENGTH OF WORD BOUNDARIED STRING
\r
25706 MOVEI C,-1(TP) ; GET DOPE WORD
\r
25708 HLRZ C,(A) ; GET LENGTH
\r
25709 SUBI A,-1(C) ; START +1
\r
25710 MOVEI B,(A) ; SETUP BYTER
\r
25712 SUB A,(TP) ; WORDS DIFFERENT
\r
25713 IMUL A,(P) ; CHARS EXTRA
\r
25714 SUBM 0,A ; FINAL TOTAL TO A
\r
25717 DPB E,[300600,,B]
\r
25725 GETATO: HLRE C,B ;GET -LENGTH
\r
25727 SUB B,C ;POINT PAST
\r
25728 GETYP 0,(B) ;GET NEXT TYPE (ASSURED OF BEING EITHER TINFO OR TENTRY)
\r
25729 CAIN 0,TENTRY ;IF ENTRY
\r
25730 JRST EASYTP ;WANT UNEVALUATED ARGS
\r
25731 HRRE C,(B) ;ELSE-- GET NO. OF ARGS (*-2)
\r
25732 SUBI B,(C) ;GO TO TOP
\r
25733 TLCA B,-1(C) ;STORE NUMBER IN TOP POINTER
\r
25734 EASYTP: MOVE B,FRAMLN+ABSAV(B) ;GET ARG POINTER
\r
25738 ; COMPILERS ENTRY TO TOP
\r
25740 CITOP: PUSHJ P,CPTYEE
\r
25741 CAIN E,P2WORD ; LIST?
\r
25743 PUSHJ P,@TOPTBL(E)
\r
25746 ; FUNCTION TO CLOBBER THE CDR OF A LIST
\r
25748 MFUNCTION PUTREST,SUBR,[PUTREST]
\r
25751 MOVE B,AB ;COPY ARG POINTER
\r
25752 PUSHJ P,PTYPE ;CHECK IT
\r
25753 CAIE A,P2WORD ;LIST?
\r
25754 JRST WTYP1 ;NO, LOSE
\r
25755 ADD B,[2,,2] ;AND NEXT ONE
\r
25758 JRST WTYP2 ;NOT LIST, LOSE
\r
25759 HRRZ B,1(AB) ;GET FIRST
\r
25760 MOVE D,3(AB) ;AND 2D LIST
\r
25763 HRRM D,(B) ;CLOBBER
\r
25764 MOVE A,(AB) ;RETURN CALLED TYPE
\r
25769 ; FUNCTION TO BACK UP A VECTOR, UVECTOR OR CHAR STRING
\r
25771 MFUNCTION BACK,SUBR
\r
25775 MOVEI C,1 ;ASSUME BACKING UP ONE
\r
25776 JUMPGE AB,TFA ;NO ARGS IS TOO FEW
\r
25777 CAML AB,[-2,,0] ;SKIP IF MORE THAN 2 ARGS
\r
25778 JRST BACK1 ;ONLY ONE ARG
\r
25779 GETYP A,2(AB) ;GET TYPE
\r
25780 CAIE A,TFIX ;MUST BE FIXED
\r
25782 SKIPGE C,3(AB) ;GET NUMBER
\r
25784 CAMGE AB,[-4,,0] ;SKIP IF WINNING NUMBER OF ARGS
\r
25786 BACK1: MOVE B,AB ;SET UP TO FIND TYPE
\r
25787 PUSHJ P,PTYPE ;GET PRIM TYPE
\r
25790 MOVE B,1(AB) ;GET DATUM
\r
25791 PUSHJ P,@BCKTBL(E)
\r
25794 PRDISP BCKTBL,IWTYP2,[[PNWORD,BACKU],[P2NWORD,BACKV],[PCHSTR,BACKC],[PARGS,BACKA]
\r
25797 BACKV: LSH C,1 ;GENERAL, DOUBLE AMOUNT
\r
25799 BACKU: MOVSI A,TUVEC
\r
25802 HRLI C,(C) ;TO BOTH HALVES
\r
25803 SUB B,C ;BACK UP VECTOR POINTER
\r
25804 HLRE C,B ;FIND OUT IF OVERFLOW
\r
25805 SUBM B,C ;DOPE POINTER TO C
\r
25806 HLRZ D,1(C) ;GET LENGTH
\r
25807 SUBI C,-2(D) ;POINT TO TOP
\r
25809 CAILE C,(B) ;SKIP IF A WINNER
\r
25810 JRST OUTRNG ;COMPLAIN
\r
25813 BCKTMP: MOVSI C,(C)
\r
25814 SUB B,C ; FIX UP POINTER
\r
25821 ADDI A,(C) ; NEW LENGTH
\r
25823 PUSH P,A ; SAVE COUNT
\r
25824 LDB E,[300600,,B] ;BYTE SIZE
\r
25825 MOVEI 0,36. ;BITS PER WORD
\r
25826 IDIVI 0,(E) ;DIVIDE TO FIND BYTES/WORD
\r
25827 IDIV C,0 ;C/ WORDS BACK, D/BYTES BACK
\r
25828 SUBI B,(C) ;BACK WORDS UP
\r
25829 JUMPE D,CHBOUN ;CHECK BOUNDS
\r
25831 IMULI 0,(E) ;0/ BITS OCCUPIED BY FULL WORD
\r
25832 LDB A,[360600,,B] ;GET POSITION FILED
\r
25833 BACKC2: ADDI A,(E) ;BUMP
\r
25835 JRST BACKC1 ;O.K.
\r
25837 SUBI B,1 ;DECREMENT POINTER PART
\r
25838 BACKC1: SOJG D,BACKC2 ;DO FOR ALL BYTES
\r
25842 DPB A,[360600,,B] ;FIX UP POINT BYTER
\r
25843 CHBOUN: MOVEI C,-1(TP)
\r
25844 PUSHJ P,BYTDOP ; FIND DOPE WORD
\r
25846 SUBI A,-1(C) ; POINT TO TOP
\r
25847 MOVE C,B ; COPY BYTER
\r
25849 CAILE A,(C) ; SKIP IF OK
\r
25851 POP P,A ; RESTORE COUNT
\r
25856 BACKA: LSH C,1 ;NUMBER TIMES 2
\r
25857 HRLI C,(C) ;TO BOTH HALVES
\r
25858 SUB B,C ;FIX POINTER
\r
25859 MOVE E,B ;AND SAVE
\r
25860 PUSHJ P,GETATO ;LOOK A T TOP
\r
25861 CAMLE B,E ;COMPARE
\r
25866 ; COMPILER'S BACK
\r
25868 CIBACK: PUSHJ P,CPTYEE
\r
25872 PUSHJ P,@BCKTBL(E)
\r
25875 MFUNCTION STRCOMP,SUBR
\r
25886 ISTRCM: GETYP 0,A
\r
25888 JRST ATMCMP ; MAYBE ATOMS
\r
25894 MOVEI A,(A) ; ISOLATR LENGHTS
\r
25897 STRCO2: SOJL A,CHOTHE ; ONE STRING EXHAUSTED, CHECK OTHER
\r
25898 SOJL C,1BIG ; 1ST IS BIGGER
\r
25901 CAIN 0,(E) ; SKIP IF DIFFERENT
\r
25903 CAIL 0,(E) ; SKIP IF 2D BIGGER THAN 1ST
\r
25908 CHOTHE: JUMPN C,2BIG ; 2 IS BIGGER
\r
25909 SM.CMP: TDZA B,B ; RETURN 0
\r
25911 RETFIX: MOVSI A,TFIX
\r
25914 ATMCMP: CAIE 0,TATOM ; COULD BE ATOM
\r
25915 JRST WTYP1 ; NO, QUIT
\r
25920 CAMN B,D ; SAME ATOM?
\r
25922 ADD B,[3,,3] ; SKIP VAL CELL ETC.
\r
25925 ATMCM1: MOVE 0,(B) ; GET A WORD OF CHARS
\r
25926 CAME 0,(D) ; SAME?
\r
25927 JRST ATMCM3 ; NO, GET DIF
\r
25929 AOBJN D,ATMCM1 ; MORE TO COMPARE
\r
25930 JRST 1BIG ; 1ST IS BIGGER
\r
25933 ATMCM2: AOBJP D,SM.CMP ; EQUAL
\r
25936 ATMCM3: LSH 0,-1 ; AVOID SIGN LOSSAGE
\r
25943 \f;ERROR COMMENTS FOR SOME PRIMITIVES
\r
25945 OUTRNG: PUSH TP,$TATOM
\r
25946 PUSH TP,EQUOTE OUT-OF-BOUNDS
\r
25949 WRNGUT: PUSH TP,$TATOM
\r
25950 PUSH TP,EQUOTE UNIFORM-VECTORS-TYPE-DIFFERS
\r
25953 SLOSE0: PUSH TP,$TATOM
\r
25954 PUSH TP,EQUOTE VECTOR-LENGTHS-DIFFER
\r
25957 SLOSE1: PUSH TP,$TATOM
\r
25958 PUSH TP,EQUOTE KEYS-WRONG-TYPE
\r
25961 SLOSE2: PUSH TP,$TATOM
\r
25962 PUSH TP,EQUOTE KEY-TYPES-DIFFER
\r
25965 SLOSE3: PUSH TP,$TATOM
\r
25966 PUSH TP,EQUOTE KEY-OFFSET-OUTSIDE-RECORD
\r
25969 SLOSE4: PUSH TP,$TATOM
\r
25970 PUSH TP,EQUOTE NON-INTEGER-NO.-OF-RECORDS
\r
25973 IIGETP: JRST IGETP ;FUDGE FOR MIDAS/STINK LOSSAGE
\r
25974 IIPUTP: JRST IPUTP
\r
25976 \f;SUPER USEFUL ERROR MESSAGES (USED BY WHOLE WORLD)
\r
25978 WNA: PUSH TP,$TATOM
\r
25979 PUSH TP,EQUOTE WRONG-NUMBER-OF-ARGUMENTS
\r
25982 TFA: PUSH TP,$TATOM
\r
25983 PUSH TP,EQUOTE TOO-FEW-ARGUMENTS-SUPPLIED
\r
25986 TMA: PUSH TP,$TATOM
\r
25987 PUSH TP,EQUOTE TOO-MANY-ARGUMENTS-SUPPLIED
\r
25991 WTYP: PUSH TP,$TATOM
\r
25992 PUSH TP,EQUOTE ARG-WRONG-TYPE
\r
25996 WTYP1: PUSH TP,$TATOM
\r
25997 PUSH TP,EQUOTE FIRST-ARG-WRONG-TYPE
\r
26001 WTYP2: PUSH TP,$TATOM
\r
26002 PUSH TP,EQUOTE SECOND-ARG-WRONG-TYPE
\r
26005 BADTPL: PUSH TP,$TATOM
\r
26006 PUSH TP,EQUOTE BAD-TEMPLATE-DATA
\r
26009 BADPUT: PUSH TP,$TATOM
\r
26010 PUSH TP,EQUOTE TEMPLATE-TYPE-VIOLATION
\r
26013 WTYP3: PUSH TP,$TATOM
\r
26014 PUSH TP,EQUOTE THIRD-ARG-WRONG-TYPE
\r
26017 CALER1: MOVEI A,1
\r
26018 CALER: HRRZ C,FSAV(TB)
\r
26022 SKIPA C,@-1(C) ; SUBRS AND FSUBRS
\r
26023 MOVE C,3(C) ; FOR RSUBRS
\r
26030 GETWNA: HLRZ B,(E)-2 ;GET LOSING COMPARE INSTRUCTION
\r
26031 CAIE B,(CAIE A,) ;AS EXPECTED ?
\r
26033 HRRE B,(E)-2 ;GET DESIRED NUMBER OF ARGS
\r
26034 HLRE A,AB ;GET ACTUAL NUMBER OF ARGS
\r
26040 \fTITLE PRINTER ROUTINE FOR MUDDLE
\r
26044 .INSRT DSK:MUDDLE >
\r
26046 .GLOBAL IPNAME,MTYO,FLOATB,RLOOKU,RADX,INAME,INTFCN,LINLN,DOIOTO,BFCLS1,ATOSQ,IGVAL
\r
26047 .GLOBAL BYTPNT,OPNCHN,CHRWRD,IDVAL,CHARGS,CHFRM,CHLOCI,PRNTYP,PRTYPE,IBLOCK,WXCT
\r
26048 .GLOBAL VECBOT,VAL,ITEM,INDIC,IOINS,DIRECT,TYPVEC,CHRPOS,LINPOS,ACCESS,PAGLN,ROOT,PROCID
\r
26049 .GLOBAL BADCHN,WRONGD,CHNCLS,IGET,FNFFL,ILLCHO,BUFSTR,BYTDOP,6TOCHS,PURVEC,STBL,RXCT
\r
26050 .GLOBAL TMPLNT,TD.LNT,MPOPJ,SSPEC1
\r
26051 .GLOBAL CIPRIN,CIPRNC,CIPRN1,CPATM,CP1ATM,CPCATM,CPSTR,CP1STR,CPCSTR
\r
26052 .GLOBAL CIFLTZ,CITERP,CIUPRS,CPCH
\r
26054 BUFLNT==100 ; BUFFER LENGTH IN WORDS
\r
26056 FLAGS==0 ;REGISTER USED TO STORE FLAGS
\r
26057 CARRET==15 ;CARRIAGE RETURN CHARACTER
\r
26058 ESCHAR=="\ ;ESCAPE CHARACTER
\r
26059 SPACE==40 ;SPACE CHARACTER
\r
26060 ATMBIT==200000 ;BIT SWITCH FOR ATOM-NAME PRINT
\r
26061 NOQBIT==020000 ;SWITCH FOR NO ESCAPING OF OUTPUT (PRINC)
\r
26062 SEGBIT==010000 ;SWITCH TO INDICATE PRINTING A SEGMENT
\r
26063 SPCBIT==004000 ;SWITCH TO INDICATE "PRINT" CALL (PUT A SPACE AFTER)
\r
26064 FLTBIT==002000 ;SWITCH TO INDICATE "FLATSIZE" CALL
\r
26065 HSHBIT==001000 ;SWITCH TO INDICATE "PHASH" CALL
\r
26066 TERBIT==000400 ;SWITCH TO INDICATE "TERPRI" CALL
\r
26067 UNPRSE==000200 ;SWITCH TO INDICATE "UNPARSE" CALL
\r
26068 ASCBIT==000100 ;SWITCH TO INDICATE USING A "PRINT" CHANNEL
\r
26069 BINBIT==000040 ;SWITCH TO INDICATE USING A "PRINTB" CHANNEL
\r
26078 \fMFUNCTION FLATSIZE,SUBR
\r
26083 ;FLATSIZE TAKES TWO OR THREE ARGUMENTS: THE FIRST IS AN OBJECT THE SECOND
\r
26084 ;IS THE MAXIMUM SIZE BEFORE IT GIVES UP AN RETURNS FALSE
\r
26085 ;THE THIRD (OPTIONAL) ARGUMENT IS A RADIX
\r
26087 CAMG AB,[-2,,0] ;CHECK NUMBER OF ARGS
\r
26094 JRST WTYP2 ;SECOND ARG NOT FIX THEN LOSE
\r
26096 CAMG AB,[-4,,0] ;SEE IF THERE IS A RADIX ARGUMENT
\r
26097 JRST .+3 ; RADIX SUPPLIED
\r
26098 PUSHJ P,GTRADX ; GET THE RADIX FROM OUTCHAN
\r
26100 GETYP A,4(AB) ;CHECK TO SEE THAT RADIX IS FIX
\r
26102 JRST WTYP ;ERROR THIRD ARGUMENT WRONG TYPE
\r
26104 PUSHJ P,GETARG ; GET ARGS INTO A AND B
\r
26105 FLTGO: POP P,D ; RESTORE FLATSIZE MAXIMUM
\r
26112 MFUNCTION UNPARSE,SUBR
\r
26119 MOVE E,TP ;SAVE TP POINTER
\r
26123 ;TURN ON FLTBIT TO AVOID PRINTING LOSSAGE
\r
26124 ;TURN ON UNPRSE TO CAUSE CHARS TO BE STASHED
\r
26125 CAMG AB,[-2,,0] ;SKIP IF RADIX SUPPLIED
\r
26127 PUSHJ P,GTRADX ;GET THE RADIX FROM OUTCHAN
\r
26129 CAMGE AB,[-5,,0] ;CHECK FOR TOO MANY
\r
26132 CAIE 0,TFIX ;SEE IF RADIX IS FIXED
\r
26134 MOVE C,3(AB) ;GET RADIX
\r
26135 PUSHJ P,GETARG ;GET ARGS INTO A AND B
\r
26136 UNPRGO: PUSHJ P,CIUPRS
\r
26141 GTRADX: MOVE B,IMQUOTE OUTCHAN
\r
26142 PUSH P,0 ;SAVE FLAGS
\r
26143 PUSHJ P,IDVAL ;GET VALUE FOR OUTCHAN
\r
26145 GETYP A,A ;CHECK TYPE OF CHANNEL
\r
26147 JRST FUNCH1-1 ;IT IS A TP-POINTER
\r
26148 MOVE C,RADX(B) ;GET RADIX FROM OUTCHAN
\r
26150 MOVE C,(B)+6 ;GET RADIX FROM STACK
\r
26152 FUNCH1: CAIG C,1 ;CHECK FOR STRANGE RADIX
\r
26153 MOVEI C,10. ;DEFAULT IF THIS IS THE CASE
\r
26154 GETARG: MOVE A,(AB)
\r
26159 MFUNCTION PRINT,SUBR
\r
26161 PUSHJ P,AGET ; GET ARGS
\r
26165 MFUNCTION PRINC,SUBR
\r
26167 PUSHJ P,AGET ; GET ARGS
\r
26171 MFUNCTION PRIN1,SUBR
\r
26176 JRST PRIN01 ;CALL IPRINT AFTER SAVING STUFF
\r
26179 MFUNCTION TERPRI,SUBR
\r
26186 CITERP: SUBM M,(P)
\r
26187 MOVSI 0,TERBIT+SPCBIT ; SET UP FLAGS
\r
26188 PUSHJ P,TESTR ; TEST FOR GOOD CHANNEL
\r
26189 MOVEI A,CARRET ; MOVE IN CARRIAGE-RETURN
\r
26190 PUSHJ P,PITYO ; PRINT IT OUT
\r
26191 MOVEI A,12 ; LINE-FEED
\r
26193 MOVSI A,TFALSE ; RETURN A FALSE
\r
26195 JRST MPOPJ ; RETURN
\r
26199 CAIN E,TCHAN ; CHANNEL?
\r
26200 JRST TESTR1 ; OK?
\r
26204 IOR 0,A ; RESTORE FLAGS
\r
26207 TESTR1: HRRZ E,-4(B) ; GET IN FLAGS FROM CHANNEL
\r
26208 TRC E,C.PRIN+C.OPN ; CHECK TO SEE THAT CHANNEL IS GOOD
\r
26209 TRNE E,C.PRIN+C.OPN
\r
26210 JRST BADCHN ; ITS A LOSER
\r
26212 JRST PSHNDL ; DON'T HANDLE BINARY
\r
26213 TLO ASCBIT ; ITS ASCII
\r
26214 POPJ P, ; ITS A WINNER
\r
26216 PSHNDL: PUSH TP,C ; SAVE ARGS
\r
26218 PUSH TP,A ; PUSH CHANNEL ONTO STACK
\r
26220 PUSHJ P,BPRINT ; CHECK BUFFER
\r
26228 \f;CIUPRS NEEDS A RADIX IN C AND A TYPE-OBJECT PAIR IN A,B
\r
26230 CIUPRS: SUBM M,(P) ; MODIFY M-POINTER
\r
26231 MOVE E,TP ; SAVE TP-POINTER
\r
26232 PUSH TP,[0] ; SLOT FOR FIRST STRING COPY
\r
26234 PUSH TP,[0] ; AND SECOND STRING
\r
26236 PUSH TP,A ; SAVE OBJECTS
\r
26238 PUSH TP,$TTP ; SAVE TP POINTER
\r
26241 MOVE D,[377777,,-1] ; MOVE IN MAXIMUM NUMBER FOR FLATSIZE
\r
26242 PUSHJ P,CIFLTZ ; FIND LENGTH OF STRING
\r
26243 FATAL UNPARSE BLEW IT
\r
26244 PUSH TP,$TFIX ; MOVE IN ARGUMENT FOR ISTRING
\r
26247 POP TP,E ; RESTORE TP-POINTER
\r
26248 SUB TP,[1,,1] ;GET RID OF TYPE WORD
\r
26249 MOVEM A,1(E) ; SAVE RESULTS
\r
26253 POP TP,B ; RESTORE THE WORLD
\r
26256 MOVSI 0,FLTBIT+UNPRSE ; SET UP FLAGS
\r
26258 JRST MPOPJ ; RETURN
\r
26262 ; FOR CIFLTZ C CONTAINS THE RADIX, D THE MAXIMUM NUMBER OF CHARACTERS,
\r
26263 ; A,B THE TYPE-OBJECT PAIR
\r
26265 CIFLTZ: SUBM M,(P)
\r
26266 MOVE E,TP ; SAVE POINTER
\r
26267 PUSH TP,$TFIX ; PUSH ON FLATSIZE COUNT
\r
26269 PUSH TP,$TFIX ; PUSH ON FLATSIZE MAXIMUM
\r
26271 MOVSI 0,FLTBIT ; MOVE ON FLATSIZE FLAG
\r
26272 PUSHJ P,CUSET ; CONTINUE
\r
26274 SOS (P) ; SKIP RETURN
\r
26275 JRST MPOPJ ; RETURN
\r
26277 ; CUSET IS THE ROUTINE USED BY FLATSIZE AND UNPARSE TO DO THE PUSHING,POPING AND CALLING
\r
26278 ; NEEDED TO GET A RESULT.
\r
26280 CUSET: PUSH TP,$TFIX ; PUSH ON RADIX
\r
26283 PUSH TP,P ; PUSH ON RETURN POINTER IN CASE FLATSIZE GETS A FALSE
\r
26284 PUSH TP,A ; SAVE OBJECTS
\r
26286 MOVSI C,TTP ; CONSTRUCT TP-POINTER
\r
26287 HLR C,FLAGS ; SAVE FLAGS IN TP-POINTER
\r
26289 PUSH TP,C ; PUSH ON CHANNEL
\r
26291 PUSHJ P,IPRINT ; GO TO INTERNAL PRINTER
\r
26292 POP TP,B ; GET IN TP POINTER
\r
26293 MOVE TP,B ; RESTORE POINTER
\r
26294 TLNN FLAGS,UNPRSE ; SEE IF UNPARSE CALL
\r
26295 JRST FLTGEN ; ITS A FLATSIZE
\r
26296 MOVE A,UPB+3 ; RETURN STRING
\r
26299 FLTGEN: MOVE A,FLTSIZ-1 ; GET IN COUNT
\r
26305 ; CIPRIN,CIPRNC,CIPRN1,CPATM,CP1ATM,CPCATM,CPSTR,CP1STR,CPCSTR ALL ASSUME
\r
26306 ; THAT C,D CONTAIN THE OBJECT AND A AND B CONTAIN THE CHANNEL
\r
26308 CIPRIN: SUBM M,(P)
\r
26309 MOVSI 0,SPCBIT ; SET UP FLAGS
\r
26310 PUSHJ P,TPRT ; PRINT INITIALIZATION
\r
26312 JRST TPRTE ; EXIT
\r
26314 CIPRN1: SUBM M,(P)
\r
26315 MOVEI FLAGS,0 ; SET UP FLAGS
\r
26316 PUSHJ P,TPR1 ; INITIALIZATION
\r
26317 PUSHJ P,IPRINT ; PRINT IT OUT
\r
26318 JRST TPR1E ; EXIT
\r
26320 CIPRNC: SUBM M,(P)
\r
26321 MOVSI FLAGS,NOQBIT ; SET UP FLAGS
\r
26322 PUSHJ P,TPR1 ; INITIALIZATION
\r
26324 JRST TPR1E ; EXIT
\r
26326 ; INITIALIZATION FOR PRINT ROUTINES
\r
26328 TPRT: PUSHJ P,TESTR ; SEE IF CHANNEL IS OK
\r
26329 PUSH TP,C ; SAVE ARGUMENTS
\r
26331 PUSH TP,A ; SAVE CHANNEL
\r
26333 MOVEI A,CARRET ; PRINT CARRIAGE RETURN
\r
26335 MOVEI A,12 ; AND LF
\r
26337 MOVE A,-3(TP) ; MOVE IN ARGS
\r
26341 ; EXIT FOR PRINT ROUTINES
\r
26343 TPRTE: POP TP,B ; RESTORE CHANNEL
\r
26344 MOVEI A,SPACE ; PRINT TRAILING SPACE
\r
26346 SUB TP,[1,,1] ; GET RID OF CHANNEL TYPE-WORD
\r
26347 POP TP,B ; RETURN WHAT WAS PASSED
\r
26349 JRST MPOPJ ; EXIT
\r
26351 ; INITIALIZATION FOR PRIN1 AND PRINC ROUTINES
\r
26353 TPR1: PUSHJ P,TESTR ; SEE IF CHANNEL IS OK
\r
26354 PUSH TP,C ; SAVE ARGS
\r
26356 PUSH TP,A ; SAVE CHANNEL
\r
26358 MOVE A,-3(TP) ; GET ARGS
\r
26362 ; EXIT FOR PRIN1 AND PRINC ROUTINES
\r
26364 TPR1E: SUB TP,[2,,2] ; REMOVE CHANNEL
\r
26365 POP TP,B ; RETURN ARGUMENTS THAT WERE GIVEN
\r
26367 JRST MPOPJ ; EXIT
\r
26371 CPATM: SUBM M,(P)
\r
26372 MOVSI C,TATOM ; GET TYPE FOR BINARY
\r
26373 MOVE 0,$SPCBIT ; SET UP FLAGS
\r
26374 PUSHJ P,TPRT ; PRINT INITIALIZATION
\r
26375 PUSHJ P,CPATOM ; PRINT IT OUT
\r
26376 JRST TPRTE ; EXIT
\r
26378 CP1ATM: SUBM M,(P)
\r
26380 MOVEI FLAGS,0 ; SET UP FLAGS
\r
26381 PUSHJ P,TPR1 ; INITIALIZATION
\r
26382 PUSHJ P,CPATOM ; PRINT IT OUT
\r
26383 JRST TPR1E ; EXIT
\r
26385 CPCATM: SUBM M,(P)
\r
26387 MOVSI FLAGS,NOQBIT ; SET UP FLAGS
\r
26388 PUSHJ P,TPR1 ; INITIALIZATION
\r
26389 PUSHJ P,CPATOM ; PRINT IT OUT
\r
26390 JRST TPR1E ; EXIT
\r
26393 ; THIS ROUTINE IS USD TO PRINT ONE CHARACTER. THE CHANNEL IS IN A AND B THE
\r
26394 ; CHARACTER IS IN C.
\r
26396 MOVSI FLAGS,NOQBIT
\r
26398 PUSHJ P,TESTR ; SEE IF CHANNEL IS GOOD
\r
26400 MOVE A,D ; MOVE IN CHARACTER FOR PITYO
\r
26402 MOVE A,$TCHRST ; RETURN THE CHARACTER
\r
26409 CPSTR: SUBM M,(P)
\r
26411 MOVSI 0,SPCBIT ; SET UP FLAGS
\r
26412 PUSHJ P,TPRT ; PRINT INITIALIZATION
\r
26413 PUSHJ P,CPCHST ; PRINT IT OUT
\r
26414 JRST TPRTE ; EXIT
\r
26416 CP1STR: SUBM M,(P)
\r
26418 MOVEI FLAGS,0 ; SET UP FLAGS
\r
26419 PUSHJ P,TPR1 ; INITIALIZATION
\r
26420 PUSHJ P,CPCHST ; PRINT IT OUT
\r
26421 JRST TPR1E ; EXIT
\r
26423 CPCSTR: SUBM M,(P)
\r
26425 MOVSI FLAGS,NOQBIT ; SET UP FLAGS
\r
26426 PUSHJ P,TPR1 ; INITIALIZATION
\r
26427 PUSHJ P,CPCHST ; PRINT IT OUT
\r
26428 JRST TPR1E ; EXIT
\r
26431 CPATOM: PUSH TP,A ; COPY ARGS FOR INTERNAL SAKE
\r
26433 PUSH P,0 ; ATOM CALLER ROUTINE
\r
26437 CPCHST: PUSH TP,A ; COPY ARGS FOR INTERNAL SAKE
\r
26439 PUSH P,0 ; STRING CALLER ROUTINE
\r
26445 AGET: MOVEI FLAGS,0
\r
26446 SKIPL E,AB ; COPY ARG POINTER
\r
26447 JRST TFA ;NO ARGS IS AN ERROR
\r
26448 ADD E,[2,,2] ;POINT AT POSSIBLE CHANNEL
\r
26450 AGET1: MOVE E,AB ; GET COPY OF AB
\r
26451 MOVSI FLAGS,TERBIT
\r
26453 COMPT: PUSH TP,$TFIX ;LEAVE ROOM ON STACK FOR ONE CHANNEL
\r
26455 JUMPGE E,DEFCHN ;IF NO CHANNEL ARGUMENT, USE CURRENT BINDING
\r
26456 CAMG E,[-2,,0] ;IF MORE ARGS THEN ERROR
\r
26458 MOVE A,(E) ;GET CHANNEL
\r
26462 DEFCHN: MOVE B,IMQUOTE OUTCHAN
\r
26464 PUSH P,FLAGS ;SAVE FLAGS
\r
26465 PUSHJ P,IDVAL ;GET VALUE OF OUTCHAN
\r
26468 NEWCHN: TLNE FLAGS,TERBIT ; SEE IF TERPRI
\r
26470 MOVE C,(AB) ; GET ARGS
\r
26474 ; HERE IF USING A PRINTB CHANNEL
\r
26476 BPRINT: TLO FLAGS,BINBIT
\r
26477 SKIPE BUFSTR(B) ; ANY OUTPUT BUFFER?
\r
26480 ; HERE TO GENERATE A STRING BUFFER
\r
26483 MOVEI A,BUFLNT ; GET BUFFER LENGTH
\r
26484 PUSHJ P,IBLOCK ; MAKE A BUFFER
\r
26485 MOVSI 0,TWORD+.VECT. ; CLOBBER U TYPE
\r
26486 MOVEM 0,BUFLNT(B)
\r
26487 SETOM (B)) ; -1 THE BUFFER
\r
26490 BLT C,BUFLNT-1(B)
\r
26493 MOVEM B,BUFSTR(C) ; STOR BYTE POINTER
\r
26494 MOVE 0,[TCHSTR,,BUFLNT*5]
\r
26495 MOVEM 0,BUFSTR-1(C)
\r
26502 IPRINT: PUSH P,C ; SAVE C
\r
26503 PUSH P,FLAGS ;SAVE PREVIOUS FLAGS
\r
26504 PUSH TP,A ;SAVE ARGUMENT ON TP-STACK
\r
26507 INTGO ;ALLOW INTERRUPTS HERE
\r
26509 GETYP A,-1(TP) ;GET THE TYPE CODE OF THE ITEM
\r
26510 SKIPE C,PRNTYP+1(TVP) ; USER TYPE TABLE?
\r
26512 NORMAL: CAIG A,NUMPRI ;PRIMITIVE?
\r
26513 JRST @PRTYPE(A) ;YES-DISPATCH
\r
26514 JRST PUNK ;JUMP TO ERROR ROUTINE IF CODE TOO GREAT
\r
26516 ; HERE FOR USER PRINT DISPATCH
\r
26518 PRDISP: ADDI C,(A) ; POINT TO SLOT
\r
26520 SKIPE (C) ; SKIP EITHER A LOSER OR JRST DISP
\r
26521 JRST PRDIS1 ; APPLY EVALUATOR
\r
26522 SKIPN C,1(C) ; GET ADDR OR GO TO PURE DISP
\r
26526 PRDIS1: PUSH P,C ; SAVE C
\r
26527 PUSH TP,[TATOM,,-1] ; PUSH ON OUTCHAN FOR SPECBIND
\r
26528 PUSH TP,IMQUOTE OUTCHAN
\r
26534 POP P,C ; RESTORE C
\r
26535 PUSH TP,(C) ; PUSH ARGS FOR APPLY
\r
26539 MCALL 2,APPLY ; APPLY HACKER TO OBJECT
\r
26541 PUSHJ P,SSPEC1 ;UNBIND OUTCHAN
\r
26542 SUB TP,[6,,6] ; POP OFF STACK
\r
26545 ; PRINT DISPATCH TABLE
\r
26547 DISTBL PRTYPE,PUNK,[[TATOM,PATOM],[TFORM,PFORM],[TSEG,PSEG],[TFIX,PFIX]
\r
26548 [TFLOAT,PFLOAT],[TLIST,PLIST],[TVEC,PVEC],[TCHRS,PCHRS],[TCHSTR,PCHSTR]
\r
26549 [TARGS,PARGS],[TUVEC,PUVEC],[TDEFER,PDEFER],[TINTH,PINTH],[THAND,PHAND]
\r
26550 [TILLEG,ILLCH],[TRSUBR,PRSUBR],[TENTER,PENTRY],[TPCODE,PPCODE],[TTYPEW,PTYPEW]
\r
26551 [TTYPEC,PTYPEC],[TTMPLT,TMPRNT],[TLOCD,LOCPT1]]
\r
26553 PUNK: MOVE C,TYPVEC+1(TVP) ; GET AOBJN-POINTER TO VECTOR OF TYPE ATOMS
\r
26554 GETYP B,-1(TP) ; GET THE TYPE CODE INTO REG B
\r
26555 LSH B,1 ; MULTIPLY BY TWO
\r
26556 HRL B,B ; DUPLICATE IT IN THE LEFT HALF
\r
26557 ADD C,B ; INCREMENT THE AOBJN-POINTER
\r
26558 JUMPGE C,PRERR ; IF POSITIVE, INDEX > VECTOR SIZE
\r
26560 MOVE B,-2(TP) ; MOVE IN CHANNEL
\r
26561 PUSHJ P,RETIF1 ; START NEW LINE IF NO ROOM
\r
26562 MOVEI A,"# ; INDICATE TYPE-NAME FOLLOWS
\r
26564 MOVE A,(C) ; GET TYPE-ATOM
\r
26566 PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT
\r
26568 PUSHJ P,IPRINT ; PRINT ATOM-NAME
\r
26569 SUB TP,[2,,2] ; POP STACK
\r
26570 MOVE B,-2(TP) ; MOVE IN CHANNEL
\r
26571 PUSHJ P,SPACEQ ; MAYBE SPACE
\r
26572 MOVE B,(B) ; RESET THE REAL ARGUMENT POINTER
\r
26573 HRRZ A,(C) ; GET THE STORAGE-TYPE
\r
26575 CAIG A,NUMSAT ; SKIP IF TEMPLATE
\r
26576 JRST @UKTBL(A) ; USE DISPATCH TABLE ON STORAGE TYPE
\r
26577 JRST TMPRNT ; PRINT TEMPLATED DATA STRUCTURE
\r
26579 DISTBS UKTBL,POCTAL,[[S2WORD,PLIST],[S2NWORD,PVEC],[SNWORD,PUVEC],[SATOM,PATOM]
\r
26580 [SCHSTR,PCHSTR],[SFRAME,PFRAME],[SARGS,PARGS],[SPVP,PPVP],[SLOCID,LOCPT],[SLOCA,LOCP]
\r
26581 [SLOCV,LOCP],[SLOCU,LOCP],[SLOCS,LOCP],[SLOCL,LOCP],[SLOCN,LOCP],[SASOC,ASSPNT]
\r
26584 ; SELECK AN ILLEGAL
\r
26586 ILLCH: MOVEI B,-1(TP)
\r
26589 \f; PRINT INTERRUPT HANDLER
\r
26591 PHAND: MOVE B,-2(TP) ; MOVE CHANNEL INTO B
\r
26594 PUSHJ P,PITYO ; SAY "FUNNY TYPE"
\r
26596 MOVE B,MQUOTE HANDLER
\r
26597 PUSH TP,-3(TP) ; PUSH CHANNEL ON FOR IPRINT
\r
26599 PUSHJ P,IPRINT ; PRINT THE TYPE NAME
\r
26600 SUB TP,[2,,2] ; POP CHANNEL OFF STACK
\r
26601 MOVE B,-2(TP) ; GET CHANNEL
\r
26602 PUSHJ P,SPACEQ ; SPACE MAYBE
\r
26603 SKIPN B,(TP) ; GET ARG BACK
\r
26605 MOVE A,INTFCN(B) ; PRINT FUNCTION FOR NOW
\r
26606 MOVE B,INTFCN+1(B)
\r
26607 PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT
\r
26609 PUSHJ P,IPRINT ; PRINT THE INT FUNCTION
\r
26610 SUB TP,[2,,2] ; POP CHANNEL OFF
\r
26613 ; PRINT INT HEADER
\r
26615 PINTH: MOVE B,-2(TP) ; GET CHANNEL INTO B
\r
26619 MOVSI A,TATOM ; AND NAME
\r
26620 MOVE B,MQUOTE IHEADER
\r
26621 PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT
\r
26624 MOVE B,-4(TP) ; GET CHANNEL INTO B
\r
26625 PUSHJ P,SPACEQ ; MAYBE SPACE
\r
26626 SKIPN B,-2(TP) ; INT HEADER BACK
\r
26628 MOVE A,INAME(B) ; GET NAME
\r
26629 MOVE B,INAME+1(B)
\r
26631 SUB TP,[2,,2] ; CLEAN OFF STACK
\r
26635 ; PRINT ASSOCIATION BLOCK
\r
26637 ASSPNT: MOVEI A,"( ; MAKE IT BE (ITEN INDIC VAL)
\r
26638 MOVE B,-2(TP) ; GET CHANNEL INTO B
\r
26639 PUSHJ P,PRETIF ; MAKE ROOM AND PRINT
\r
26640 SKIPA C,[-3,,0] ; # OF FIELDS
\r
26641 ASSLP: PUSHJ P,SPACEQ
\r
26642 MOVE D,(TP) ; RESTORE GOODIE
\r
26643 ADD D,ASSOFF(C) ; POINT TO FIELD
\r
26644 MOVE A,(D) ; GET IT
\r
26646 PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT
\r
26648 PUSHJ P,IPRINT ; AND PRINT IT
\r
26649 SUB TP,[2,,2] ; POP OFF CHANNEL
\r
26653 MOVE B,-2(TP) ; GET CHANNEL INTO B
\r
26654 PUSHJ P,PRETIF ; CLOSE IT
\r
26660 \f; PRINT TYPE-C AND TYPE-W
\r
26662 PTYPEW: HRRZ A,(TP) ; POSSIBLE RH
\r
26664 MOVE C,MQUOTE TYPE-W
\r
26667 PTYPEC: HRRZ B,(TP)
\r
26669 MOVE C,MQUOTE TYPE-C
\r
26676 MOVE B,-4(TP) ; GET CHANNEL INTO B
\r
26677 PUSHJ P,RETIF ; ROOM TO START?
\r
26682 POP TP,B ; GET NAME
\r
26684 PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT
\r
26686 PUSHJ P,IPRINT ; AND PRINT IT AS 1ST ELEMENT
\r
26687 SUB TP,[2,,2] ; POP OFF CHANNEL
\r
26688 MOVE B,-2(TP) ; GET CHANNEL INTO B
\r
26689 PUSHJ P,SPACEQ ; MAYBE SPACE
\r
26690 MOVE A,-1(P) ; TYPE CODE
\r
26692 HRLI A,(A) ; MAKE SURE WINS
\r
26693 ADD A,TYPVEC+1(TVP)
\r
26694 JUMPL A,PTYPX1 ; JUMP FOR A WINNER
\r
26696 PUSH TP,EQUOTE BAD-TYPE-CODE
\r
26699 PTYPX1: MOVE B,1(A) ; GET TYPE NAME
\r
26700 HRRZ A,(A) ; AND SAT
\r
26702 MOVEM A,-1(P) ; AND SAVE IT
\r
26704 PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT
\r
26706 PUSHJ P,IPRINT ; OUT IT GOES
\r
26707 SUB TP,[2,,2] ; POP OFF CHANNEL
\r
26708 MOVE B,-2(TP) ; GET CHANNEL INTO B
\r
26709 PUSHJ P,SPACEQ ; MAYBE SPACE
\r
26710 MOVE A,-1(P) ; GET SAT BACK
\r
26712 MOVSI A,TATOM ; AND PRINT IT
\r
26713 PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT
\r
26716 SUB TP,[2,,2] ; POP OFF STACK
\r
26717 SKIPN B,(P) ; ANY EXTRA CRAP?
\r
26720 MOVE B,-2(TP) ; GET CHANNEL INTO B
\r
26724 PUSH TP,-3(TP) ; PUSH CHANNELS FOR IPRINT
\r
26726 PUSHJ P,IPRINT ; PRINT EXTRA
\r
26727 SUB TP,[2,,2] ; POP OFF CHANNEL
\r
26729 PTYPX2: MOVEI A,">
\r
26730 MOVE B,-2(TP) ; GET CHANNEL INTO B
\r
26732 SUB P,[2,,2] ; FLUSH CRUFT
\r
26735 \f; PRINT PURE CODE POINTER
\r
26737 PPCODE: MOVEI A,2
\r
26738 MOVE B,-2(TP) ; GET CHANNEL INTO B
\r
26744 MOVSI A,TATOM ; PRINT SUBR CALL
\r
26745 MOVE B,MQUOTE PCODE
\r
26746 PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT
\r
26749 MOVE B,-4(TP) ; GET CHANNEL INTO B
\r
26750 PUSHJ P,SPACEQ ; MAYBE SPACE?
\r
26751 HLRZ A,-2(TP) ; OFFSET TO VECTOR
\r
26752 ADD A,PURVEC+1(TVP) ; SLOT TO A
\r
26753 MOVE A,(A) ; SIXBIT NAME
\r
26755 PUSHJ P,6TOCHS ; TO A STRING
\r
26758 MOVE B,-4(TP) ; GET CHANNEL INTO B
\r
26760 HRRZ B,-2(TP) ; GET OFFSET
\r
26763 SUB TP,[2,,2] ; POP CHANNEL OFF STACK
\r
26765 MOVE B,-2(TP) ; GET CHANNEL INTO B
\r
26766 PUSHJ P,PRETIF ; CLOSE THE FORM
\r
26770 \f; PRINT SUB-ENTRY TO RSUBR
\r
26772 PENTRY: MOVE B,(TP) ; GET BLOCK
\r
26773 GETYP A,(B) ; TYPE OF 1ST ELEMENT
\r
26774 CAIE A,TRSUBR ; RSUBR, OK
\r
26776 MOVSI A,TATOM ; UNLINK
\r
26781 PENT2: MOVEI A,2 ; CHECK ROOM
\r
26782 MOVE B,-2(TP) ; GET CHANNEL INTO B
\r
26784 MOVEI A,"% ; SETUP READ TIME MACRO
\r
26789 MOVE B,MQUOTE RSUBR-ENTRY
\r
26790 PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT
\r
26794 PUSHJ P,SPACEQ ; MAYBE SPACE
\r
26795 MOVEI A,"' ; QUOTE TO AVOID EVALING IT
\r
26800 MOVE B,-4(TP) ; GET CHANNEL INTO B
\r
26807 SUB TP,[2,,2] ; POP CHANNEL OFF STACK
\r
26808 MOVE B,-2(TP) ; GET CHANNEL INTO B
\r
26812 PENT1: CAIN A,TATOM
\r
26815 PUSH TP,EQUOTE BAD-ENTRY-BLOCK
\r
26818 \f; HERE TO PRINT TEMPLATED DATA STRUCTURE
\r
26820 TMPRNT: PUSH P,FLAGS ; SAVE FLAGS
\r
26821 MOVE A,(TP) ; GET POINTER
\r
26822 GETYP A,(A) ; GET SAT
\r
26823 PUSH P,A ; AND SAVE IT
\r
26824 MOVEI A,"{ ; OPEN SQUIGGLE
\r
26825 MOVE B,-2(TP) ; GET CHANNEL INTO B
\r
26826 PUSHJ P,PRETIF ; PRINT WITH CHECKING
\r
26827 HLRZ A,(TP) ; GET AMOUNT RESTED OFF
\r
26829 PUSH P,A ; AND SAVE IT
\r
26830 MOVE A,-1(P) ; GET SAT
\r
26831 SUBI A,NUMSAT+1 ; FIXIT UP
\r
26833 ADD A,TD.LNT+1(TVP) ; CHECK FOR WINNAGE
\r
26834 JUMPGE A,BADTPL ; COMPLAIN
\r
26835 HRRZS C,(TP) ; GET LENGTH
\r
26837 SUB B,(P) ; FUDGE FOR RESTS
\r
26838 MOVEI B,-1(B) ; FUDGE IT
\r
26839 PUSH P,B ; AND SAVE IT
\r
26841 TMPRN1: AOS C,-1(P) ; GET ELEMENT OF INTEREST
\r
26842 SOSGE (P) ; CHECK FOR ANY LEFT
\r
26843 JRST TMPRN2 ; ALL DONE
\r
26845 MOVE B,(TP) ; POINTER
\r
26846 HRRZ 0,-2(P) ; SAT
\r
26847 PUSHJ P,TMPLNT ; GET THE ITEM
\r
26848 MOVE FLAGS,-3(P) ; RESTORE FLAGS
\r
26849 PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT
\r
26851 PUSHJ P,IPRINT ; PRINT THIS ELEMENT
\r
26852 SUB TP,[2,,2] ; POP CHANNEL OFF STACK
\r
26853 MOVE B,-2(TP) ; GET CHANNEL INTO B
\r
26854 SKIPE (P) ; IF NOT LAST ONE THEN
\r
26855 PUSHJ P,SPACEQ ; SEPARATE WITH A SPACE
\r
26858 TMPRN2: SUB P,[4,,4]
\r
26860 MOVEI A,"} ; CLOSE THIS GUY
\r
26865 \f; RSUBR PRINTING ROUTINES. ON PRINTB CHANNELS, WRITES OUT
\r
26866 ; COMPACT BINARY. ON PRINT CHANNELS ALL IS ASCII
\r
26868 PRSUBR: MOVE A,(TP) ; GET RSUBR IN QUESTION
\r
26869 GETYP A,(A) ; CHECK FOR PURE RSUBR
\r
26871 JRST PRSBRP ; PRINT IT SPECIAL WAY
\r
26873 TLNN FLAGS,BINBIT ; SKIP IF BINARY OUTPUT
\r
26877 MOVSI A,TRSUBR ; FIND FIXUPS
\r
26879 HLRE D,1(B) ; -LENGTH OF CODE VEC
\r
26880 PUSH P,D ; SAVE SAME
\r
26882 MOVE D,MQUOTE RSUBR
\r
26883 PUSHJ P,IGET ; GO GET THEM
\r
26884 JUMPE B,RCANT ; NO FIXUPS, BINARY LOSES
\r
26885 PUSH TP,A ; SAVE FIXUP LIST
\r
26888 MOVNI A,1 ; USE ^C AS MARKER FOR RSUBR
\r
26889 MOVE FLAGS,-1(P) ; RESTORE FLAGS
\r
26890 MOVE B,-4(TP) ; GET CHANNEL FOR PITYO
\r
26891 PUSHJ P,PITYO ; OUT IT GOES
\r
26893 PRSBR1: MOVE B,-4(TP)
\r
26894 PUSHJ P,BFCLS1 ; FLUSH OUT CURRENT BUFFER
\r
26896 MOVE B,-4(TP) ; CHANNEL BACK
\r
26897 MOVN E,(P) ; LENGTH OF CODE
\r
26899 HRROI A,(P) ; POINT TO SAME
\r
26900 PUSHJ P,DOIOTO ; OUT GOES COUNT
\r
26902 MOVEM C,ASTO(PVP) ; FOR IOT INTERRUPTS
\r
26903 MOVE A,-2(TP) ; GET POINTER TO CODE
\r
26905 PUSHJ P,DOIOTO ; IOT IT OUT
\r
26907 ADDI E,1 ; UPDATE ACCESS
\r
26909 SETZM ASTO(PVP) ; UNSCREW A
\r
26911 ; NOW PRINT OUT NORMAL RSUBR VECTOR
\r
26913 MOVE FLAGS,-1(P) ; RESTORE FLAGS
\r
26915 MOVE B,-2(TP) ; GET RSUBR VECTOR
\r
26916 PUSHJ P,PRBODY ; PRINT ITS BODY
\r
26918 ; HERE TO PRINT BINARY FIXUPS
\r
26920 MOVEI E,0 ; 1ST COMPUTE LENGTH OF FIXUPS
\r
26921 SKIPN A,(TP) ; LIST TO A
\r
26922 JRST PRSBR5 ; EMPTY, DONE
\r
26923 JUMPL A,UFIXES ; JUMP IF FIXUPS IN UVECTOR FORM
\r
26924 ADDI E,1 ; FOR VERS
\r
26926 PRSBR6: HRRZ A,(A) ; NEXT?
\r
26929 CAIE B,TDEFER ; POSSIBLE STRING
\r
26930 JRST PRSBR7 ; COULD BE ATOM
\r
26931 MOVE B,1(A) ; POSSIBLE STRINGER
\r
26933 CAIE C,TCHSTR ; YES!!!
\r
26934 JRST BADFXU ; LOSING FIXUPS
\r
26935 HRRZ C,(B) ; # OF CHARS TO C
\r
26936 ADDI C,5+5 ; ROUND AND ADD FOR COUNT
\r
26937 IDIVI C,5 ; TO WORDS
\r
26939 JRST FIXLST ; COUNT FOR USE LIST ETC.
\r
26941 PRSBR7: GETYP B,(A) ; GET TYPE
\r
26946 FIXLST: HRRZ A,(A) ; REST IT TO OLD VAL
\r
26948 GETYP B,(A) ; FIX?
\r
26952 HRRZ A,(A) ; TO USE LIST
\r
26956 JRST BADFXU ; LOSER
\r
26957 MOVE C,1(A) ; GET LIST
\r
26959 PRSBR8: JUMPE C,PRSBR9
\r
26960 GETYP B,(C) ; TYPE OK?
\r
26964 AOJA D,PRSBR8 ; LOOP
\r
26966 PRSBR9: ADDI D,2 ; ROUND UP
\r
26967 ASH D,-1 ; DIV BY 2 FOR TWO GOODIES PER HWORD
\r
26971 PRSBR5: PUSH P,E ; SAVE LENGTH OF FIXUPS
\r
26972 PUSH TP,$TUVEC ; SLOT FOR BUFFER POINTER
\r
26975 PFIXU1: MOVE B,-6(TP) ; START LOOPING THROUGH CHANNELS
\r
26976 PUSHJ P,BFCLS1 ; FLUSH BUFFER
\r
26977 MOVE B,-6(TP) ; CHANNEL BACK
\r
26978 MOVEI C,BUFSTR-1(B) ; SETUP BUFFER
\r
26979 PUSHJ P,BYTDOP ; FIND D.W.
\r
26983 MOVE E,(P) ; LENGTH OF FIXUPS
\r
26984 SETZB C,D ; FOR EOUT
\r
26986 MOVE C,-2(TP) ; FIXUP LIST
\r
26987 MOVE E,1(C) ; HAVE VERS
\r
26988 PUSHJ P,EOUT ; OUT IT GOES
\r
26990 PFIXU2: HRRZ C,(C) ; FIRST THING
\r
26991 JUMPE C,PFIXU3 ; DONE?
\r
26992 GETYP A,(C) ; STRING OR ATOM
\r
26993 CAIN A,TATOM ; MUST BE STRING
\r
26995 MOVE A,1(C) ; POINT TO POINTER
\r
26996 HRRZ D,(A) ; LENGTH
\r
26998 PUSH P,E ; SAVE REMAINDER
\r
27005 PFXU1A: MOVE A,1(C) ; RESTORE POINTER
\r
27006 HRRZ A,1(A) ; BYTE POINTER
\r
27013 MOVE D,-1(P) ; LAST WORD
\r
27018 MOVE E,(A) ; LAST WORD OF CHARS
\r
27020 PUSHJ P,EOUT ; OUT
\r
27024 PADS: ASCII /#####/
\r
27030 PFIXU4: HRRZ E,(C) ; GET CURRENT VAL
\r
27032 PUSHJ P,ATOSQ ; GET SQUOZE
\r
27034 TLO E,400000 ; USE TO DIFFERENTIATE BETWEEN STRING
\r
27037 ; HERE TO WRITE OUT LISTS
\r
27039 PFIXU5: HRRZ C,(C) ; POINT TO CURRENT VALUE
\r
27041 HRRZ C,(C) ; POINT TO USES LIST
\r
27042 HRRZ D,1(C) ; GET IT
\r
27044 PFIXU6: TLCE D,400000 ; SKIP FOR RH
\r
27045 HRLZ E,1(D) ; SETUP LH
\r
27048 PUSHJ P,EOUT ; WRITE IT OUT
\r
27050 TRNE D,-1 ; SKIP IF DONE
\r
27053 TRNE E,-1 ; SKIP IF ZERO BYTE EXISTS
\r
27056 JRST PFIXU2 ; DO NEXT
\r
27058 PFIXU3: HLRE C,(TP) ; -AMNT LEFT IN BUFFER
\r
27059 MOVN D,C ; PLUS SAME
\r
27060 ADDI C,BUFLNT ; WORDS USED TO C
\r
27061 JUMPE C,PFIXU7 ; NONE USED, LEAVE
\r
27062 MOVSS C ; START SETTING UP BTB
\r
27063 MOVN A,C ; ALSO FINAL IOT POINTER
\r
27064 HRR C,(TP) ; PDL POINTER PART OF BTB
\r
27066 HRLI D,C ; CONTINUE SETTING UP BTB
\r
27067 POP C,@D ; MOVE 'EM DOWN
\r
27070 HRRI A,@D ; OUTPUT POINTER
\r
27073 MOVEM B,ASTO(PVP)
\r
27075 PUSHJ P,DOIOTO ; WRITE IT OUT
\r
27078 PFIXU7: SUB TP,[4,,4]
\r
27082 ; ROUTINE TO OUTPUT CONTENTS OF E
\r
27084 EOUT: MOVE B,-6(TP) ; CHANNEL
\r
27086 MOVE A,(TP) ; BUFFER POINTER
\r
27088 AOBJP A,.+3 ; COUNT AND GO
\r
27092 SUBI A,BUFLNT ; SET UP IOT POINTER
\r
27094 MOVEM A,(TP) ; RESET SAVED POINTER
\r
27096 MOVEM 0,ASTO(PVP)
\r
27098 MOVEM 0,DSTO(PVP)
\r
27099 MOVEM 0,CSTO(PVP)
\r
27100 PUSHJ P,DOIOTO ; OUT IT GOES
\r
27106 ; HERE IF UVECOR FORM OF FIXUPS
\r
27108 UFIXES: PUSH TP,$TUVEC
\r
27109 PUSH TP,A ; SAVE IT
\r
27111 UFIX1: MOVE B,-6(TP) ; GET SAME
\r
27112 PUSHJ P,BFCLS1 ; FLUSH OUT BUFFER
\r
27113 HLRE C,(TP) ; GET LENGTH
\r
27116 HRROI A,(P) ; READY TO ZAP IT OUT
\r
27117 PUSHJ P,DOIOTO ; ZAP!
\r
27119 HLRE C,(TP) ; LENGTH BACK
\r
27122 ADDM C,ACCESS(B) ; UPDATE ACCESS
\r
27123 MOVE A,(TP) ; NOW THE UVECTOR
\r
27125 MOVEM C,ASTO(PVP)
\r
27126 PUSHJ P,DOIOTO ; GO
\r
27132 RCANT: PUSH TP,$TATOM
\r
27133 PUSH TP,EQUOTE RSUBR-LACKS-FIXUPS
\r
27137 BADFXU: PUSH TP,$TATOM
\r
27138 PUSH TP,EQUOTE BAD-FIXUPS
\r
27141 PRBODY: TDZA C,C ; FLAG SAYING FLUSH CODE
\r
27142 PRBOD1: MOVEI C,1 ; PRINT CODE ALSO
\r
27147 MOVEI A,"[ ; START VECTOR TEXT
\r
27148 MOVE B,-6(TP) ; GET CHANNEL FOR PITYO
\r
27151 MOVE B,(TP) ; RSUBR BACK
\r
27152 JUMPN C,PRSON ; GO START PRINTING
\r
27153 MOVEI A,"0 ; PLACE SAVER FOR CODE VEC
\r
27154 MOVE B,-6(TP) ; GET CHANNEL FOR PITYO
\r
27157 PRSBR2: MOVE B,[2,,2] ; BUMP VECTOR
\r
27159 JUMPGE B,PRSBR3 ; NO SPACE IF LAST
\r
27160 MOVE B,-6(TP) ; GET CHANNEL FOR SPACEQ
\r
27162 SKIPA B,(TP) ; GET BACK POINTER
\r
27163 PRSON: JUMPGE B,PRSBR3
\r
27164 GETYP 0,(B) ; SEE IF RSUBR POINTED TO
\r
27166 JRST .+3 ; JUMP IF RSUBR ENTRY
\r
27167 CAIE 0,TRSUBR ; YES!
\r
27168 JRST PRSB10 ; COULD BE SUBR/FSUBR
\r
27169 MOVE C,1(B) ; GET RSUBR
\r
27170 PUSH P,0 ; SAVE TYPE FOUND
\r
27171 GETYP 0,2(C) ; SEE IF ATOM
\r
27174 MOVE B,3(C) ; GET ATOM NAME
\r
27175 PUSHJ P,IGVAL ; GO LOOK
\r
27176 MOVE C,(TP) ; ORIG RSUBR BACK
\r
27178 POP P,0 ; DESIRED TYPE
\r
27179 CAIE 0,(A) ; SAME TYPE
\r
27182 MOVE 0,3(D) ; NAME OF RSUBR IN QUESTION
\r
27183 CAME 0,3(B) ; WIN?
\r
27187 MOVEM A,(C) ; UNLINK
\r
27189 PRSBR4: MOVE FLAGS,(P) ; RESTORE FLAGS
\r
27192 MOVE B,1(B) ; PRINT IT
\r
27193 PUSH TP,-7(TP) ; PUSH CHANNEL FOR IPRINT
\r
27196 SUB TP,[2,,2] ; POP OFF CHANNEL
\r
27199 PRSB10: CAIE 0,TSUBR ; SUBR?
\r
27203 MOVE C,1(B) ; GET LOCN OF SUBR OR FSUBR
\r
27204 MOVE C,@-1(C) ; NAME OF IT
\r
27205 MOVEM C,1(B) ; SMASH
\r
27206 MOVSI C,TATOM ; AND TYPE
\r
27210 PRSBR3: MOVEI A,"]
\r
27212 PUSHJ P,PRETIF ; CLOSE IT UP
\r
27213 SUB TP,[2,,2] ; FLUSH CRAP
\r
27218 \f; HERE TO PRINT PURE RSUBRS
\r
27220 PRSBRP: MOVEI A,2 ; WILL "%<" FIT?
\r
27221 MOVE B,-2(TP) ; GET CHANNEL FOR RETIF
\r
27228 MOVE B,MQUOTE RSUBR
\r
27229 PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT
\r
27231 PUSHJ P,IPRINT ; PRINT IT OUT
\r
27232 SUB TP,[2,,2] ; POP OFF CHANNEL
\r
27234 PUSHJ P,SPACEQ ; MAYBE SPACE
\r
27235 MOVEI A,"' ; QUOTE THE VECCTOR
\r
27237 MOVE B,(TP) ; GET RSUBR BODY BACK
\r
27238 PUSH TP,$TFIX ; STUFF THE STACK
\r
27240 PUSHJ P,PRBOD1 ; PRINT AND UNLINK
\r
27241 SUB TP,[2,,2] ; GET JUNK OFF STACK
\r
27242 MOVE B,-2(TP) ; GET CHANNEL FOR RETIF
\r
27247 ; HERE TO PRINT ASCII RSUBRS
\r
27249 ARSUBR: PUSH P,FLAGS ; SAVE FROM GET
\r
27253 MOVE D,MQUOTE RSUBR
\r
27254 PUSHJ P,IGET ; TRY TO GET FIXUPS
\r
27256 JUMPE B,PUNK ; NO FIXUPS LOSE
\r
27258 CAIE A,TLIST ; ARE FIXUPS A LIST?
\r
27259 JRST PUNK ; NO, AGAIN LOSE
\r
27261 PUSH TP,B ; SAVE FIXUPS
\r
27266 PUSH P,[440700,,[ASCIZ /%<FIXUP!-RSUBRS!-/]]
\r
27268 AL1: ILDB A,(P) ; GET CHAR
\r
27277 PUSHJ P,PRETIF ; QUOTE TO AVOID ADDITIONAL EVAL
\r
27278 MOVE B,-2(TP) ; PRINT ACTUAL KLUDGE
\r
27280 MOVE B,-4(TP) ; GET CHANNEL FOR SPACEQ
\r
27282 MOVEI A,"' ; DONT EVAL FIXUPS EITHER
\r
27286 PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT
\r
27289 SUB TP,[2,,2] ; POP CHANNEL OFF STACK
\r
27290 MOVE B,-2(TP) ; GET CHANNEL INTO B
\r
27295 \f; HERE TO DO LOCATIVES (PRINT CONTENTS THEREOF)
\r
27297 LOCP: PUSH TP,-1(TP)
\r
27300 MCALL 1,IN ; GET ITS CONTENTS FROM "IN"
\r
27302 PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT
\r
27304 PUSHJ P,IPRINT ; PRINT IT
\r
27305 SUB TP,[2,,2] ; POP CHANNEL OFF STACK
\r
27307 \f;INTERNAL SUBROUTINE TO HANDLE CHARACTER OUTPUT
\r
27308 ;B CONTAINS CHANNEL
\r
27309 ;PRINTER ITYO USED FOR FLATSIZE FAKE OUT
\r
27310 PITYO: TLNN FLAGS,FLTBIT
\r
27312 PITYO1: PUSH TP,[TTP,,0] ; PUSH ON TP POINTER
\r
27314 TLNE FLAGS,UNPRSE ;SKIPS UNPRSE NOT SET
\r
27316 AOS FLTSIZ ;FLATSIZE DOESN'T PRINT
\r
27317 ;INSTEAD IT COUNTS THE CHARACTERS THAT WOULD BE OUTPUT
\r
27318 SOSGE FLTMAX ;UNLESS THE MAXIMUM IS EXCEEDED
\r
27320 POP TP,B ; GET CHANNEL BACK
\r
27323 MOVEI E,(B) ; GET POINTER FOR UNBINDING
\r
27325 MOVE P,UPB+8 ; RESTORE P
\r
27326 POP TP,B ; GET BACK TP POINTER
\r
27327 PUSH P,0 ; SAVE FLAGS
\r
27328 MOVE TP,B ; RESTORE TP
\r
27329 PITYO3: MOVEI C,(TB)
\r
27332 POP P,0 ; RESTORE FLAGS
\r
27333 MOVSI A,TFALSE ;IN WHICH CASE IT IMMEDIATELY GIVES UP AND RETURNS FALSE
\r
27337 PITYO2: HRR TB,OTBSAV(TB) ; RESTORE TB
\r
27341 \f;THE REAL THING
\r
27342 ;NOTE THAT THE FOLLOWING CODE HAS BUGS IF IT IS PRINTING OUT LONG
\r
27343 ;CHARACTER STRINGS
\r
27344 ; (NOTE THAT THE ABOVE COMMENT, IF TRUE, SHOULD NOT BE ADMITTED.)
\r
27345 ITYO: PUSH TP,$TCHAN
\r
27347 PUSH P,FLAGS ;SAVE STUFF
\r
27349 ITYOCH: PUSH P,A ;SAVE OUTPUT CHARACTER
\r
27352 ITYO1: TLNE FLAGS,UNPRSE ;SKIPS UNPRSE NOT SET
\r
27353 JRST UNPROUT ;IF FROM UNPRSE, STASH IN STRING
\r
27354 CAIE A,^L ;SKIP IF THIS IS A FORM-FEED
\r
27356 SETZM LINPOS(B) ;ZERO THE LINE NUMBER
\r
27359 NOTFF: CAIE A,15 ;SKIP IF IT IS A CR
\r
27361 SETZM CHRPOS(B) ;ZERO THE CHARACTER POSITION
\r
27362 PUSHJ P,WXCT ;OUTPUT THE C-R
\r
27363 PUSHJ P,AOSACC ; BUMP COUNT
\r
27364 AOS C,LINPOS(B) ;ADD ONE TO THE LINE NUMBER
\r
27365 CAMG C,PAGLN(B) ;SKIP IF THIS TAKES US PAST PAGE END
\r
27368 SETZM LINPOS(B) ;ZERO THE LINE POSITION
\r
27369 ; PUSHJ P,WXCT ; REMOVED FOR NOW
\r
27371 ; MOVEI A,^L ; DITTO
\r
27374 NOTCR: CAIN A,^I ;SKIP IF NOT TAB
\r
27376 CAIE A,10 ; BACK SPACE
\r
27378 SOS CHRPOS(B) ; BACK UP ONE
\r
27380 CAIE A,^J ;SKIP IF LINE FEED
\r
27381 AOS CHRPOS(B) ;ADD TO CHARACTER NUMBER
\r
27383 ITYXT: PUSHJ P,AOSACC ; BUMP ACCESS
\r
27384 ITYXTA: PUSHJ P,WXCT ;OUTPUT THE CHARACTER
\r
27385 ITYXT1: POP P,A ;RESTORE THE ORIGINAL CHARACTER
\r
27387 ITYRET: POP P,C ;RESTORE REGS & RETURN
\r
27389 POP TP,B ; GET CHANNEL BACK
\r
27395 ADDI C,8. ;INCREMENT COUNT BY EIGHT (MOD EIGHT)
\r
27398 MOVEM C,CHRPOS(B) ;REPLACE COUNT
\r
27402 UNPROUT: POP P,A ;GET BACK THE ORIG CHAR
\r
27403 IDPB A,UPB+2 ;DEPOSIT USING BYTE POINTER I PUSHED LONG AGO
\r
27405 JRST ITYRET ;RETURN
\r
27407 AOSACC: TLNN FLAGS,BINBIT
\r
27409 AOS C,ACCESS-1(B) ; COUNT CHARS IN WORD
\r
27413 HLLZS ACCESS-1(B)
\r
27416 NRMACC: AOS ACCESS(B)
\r
27419 SPACEQ: MOVEI A,40
\r
27420 TLNE FLAGS,FLTBIT+BINBIT
\r
27421 JRST PITYO ; JUST OUTPUT THE SPACE
\r
27422 PUSH P,[1] ; PRINT SPACE IF NOT END OF LINE
\r
27426 RETIF1: MOVEI A,1
\r
27428 RETIF: PUSH P,[0]
\r
27429 TLNE FLAGS,FLTBIT+BINBIT
\r
27430 JRST SPOPJ ; IF WE ARE IN FLATSIZE THEN ESCAPE
\r
27431 RETIF2: PUSH P,FLAGS
\r
27434 RETCH1: ADD A,CHRPOS(B) ;ADD THE CHARACTER POSITION
\r
27435 SKIPN CHRPOS(B) ; IF JUST RESET, DONT DO IT AGAIN
\r
27437 CAMG A,LINLN(B) ;SKIP IF GREATER THAN LINE LENGTH
\r
27440 MOVEI A,^M ;FORCE A CARRIAGE RETURN
\r
27443 PUSHJ P,AOSACC ; BUMP CHAR COUNT
\r
27444 MOVEI A,^J ;AND FORCE A LINE FEED
\r
27446 PUSHJ P,AOSACC ; BUMP CHAR COUNT
\r
27448 CAMG A,PAGLN(B) ;AT THE END OF THE PAGE ?
\r
27450 ; MOVEI A,^L ;IF SO FORCE A FORM FEED
\r
27452 ; PUSHJ P,AOSACC ; BUMP CHAR COUNT
\r
27458 SPOPJ: SUB P,[1,,1]
\r
27461 PRETIF: PUSH P,A ;SAVE CHAR
\r
27466 RETIF3: TLNE FLAGS,FLTBIT ; NOTHING ON FLATSIZE
\r
27470 HRRI FLAGS,2 ; PRETEND ONLY 1 CHANNEL
\r
27474 RETXT1: SKIPN -2(P) ; SKIP IF SPACE HACK
\r
27484 \f;THIS IS CODE TO HANDLE UNKNOWN DATA TYPES.
\r
27485 ;IT PRINTS "*XXXXXX*XXXXXXXXXXXX*", WHERE THE FIRST NUMBER IS THE
\r
27486 ;TYPE CODE IN OCTAL, THE SECOND IS THE VALUE FIELD IN OCTAL.
\r
27487 PRERR: MOVEI A,21. ;CHECK FOR 21. SPACES LEFT ON PRINT LINE
\r
27488 MOVE B,-2(TP) ; GET CHANNEL INTO B
\r
27489 PUSHJ P,RETIF ;INSERT CARRIAGE RETURN IF NOT ENOUGH
\r
27490 MOVEI A,"* ;JUNK TO INDICATE ERROR PRINTOUT IN OCTAL
\r
27491 PUSHJ P,PITYO ;TYPE IT
\r
27493 MOVE E,[000300,,-2(TP)] ;GET POINTER INDEXED OFF TP SO THAT
\r
27494 ;TYPE CODE MAY BE OBTAINED FOR PRINTING.
\r
27495 MOVEI D,6 ;# OF OCTAL DIGITS IN HALF WORD
\r
27496 OCTLP1: ILDB A,E ;GET NEXT 3-BIT BYTE OF TYPE CODE
\r
27497 IORI A,60 ;OR-IN 60 FOR ASCII DIGIT
\r
27498 PUSHJ P,PITYO ;PRINT IT
\r
27499 SOJG D,OCTLP1 ;REPEAT FOR SIX CHARACTERS
\r
27501 PRE01: MOVEI A,"* ;DELIMIT TYPE CODE FROM VALUE FIELD
\r
27504 HRLZI E,(410300,,(TP)) ;BYTE POINTER TO SECOND WORD
\r
27506 MOVEI D,12. ;# OF OCTAL DIGITS IN A WORD
\r
27507 OCTLP2: LDB A,E ;GET 3 BITS
\r
27508 IORI A,60 ;CONVERT TO ASCII
\r
27509 PUSHJ P,PITYO ;PRINT IT
\r
27510 IBP E ;INCREMENT POINTER TO NEXT BYTE
\r
27511 SOJG D,OCTLP2 ;REPEAT FOR 12. CHARS
\r
27513 MOVEI A,"* ;DELIMIT END OF ERROR TYPEOUT
\r
27514 PUSHJ P,PITYO ;REPRINT IT
\r
27516 JRST PNEXT ;RESTORE REGS & POP UP ONE LEVEL TO CALLER
\r
27518 POCTAL: MOVEI A,14. ;RETURN TO NEW LINE IF 14. SPACES NOT LEFT
\r
27519 MOVE B,-2(TP) ; GET CHANNEL INTO B
\r
27521 JRST PRE01 ;PRINT VALUE AS "*XXXXXXXXXXXX*"
\r
27523 \f;PRINT BINARY INTEGERS IN DECIMAL.
\r
27525 PFIX: MOVM E,(TP) ; GET # (MAFNITUDE)
\r
27526 JUMPL E,POCTAL ; IF ABS VAL IS NEG, MUST BE SETZ
\r
27529 PFIX1: MOVE B,-2(TP) ; GET CHANNEL INTO B
\r
27530 PFIX2: MOVE D,UPB+6 ; IF UNPARSE, THIS IS RADIX
\r
27531 TLNE FLAGS,UNPRSE+FLTBIT ;SKIPS IF NOT FROM UNPARSE OR FLATSIZE
\r
27533 MOVE D,RADX(B) ; GET OUTPUT RADIX
\r
27534 PFIXU: CAIG D,1 ; DONT ALLOW FUNNY RADIX
\r
27535 MOVEI D,10. ; IF IN DOUBT USE 10.
\r
27537 MOVEI A,1 ; START A COUNTER
\r
27538 SKIPGE B,(TP) ; CHECK SIGN
\r
27539 MOVEI A,2 ; NEG, NEED CHAR FOR SIGN
\r
27541 IDIV B,D ; START COUNTING
\r
27545 MOVE B,-2(TP) ; CHANNEL TO B
\r
27546 TLNN FLAGS,FLTBIT+BINBIT
\r
27547 PUSHJ P,RETIF3 ; CHECK FOR C.R.
\r
27548 MOVE B,-2(TP) ; RESTORE CHANNEL
\r
27549 MOVEI A,"- ; GET SIGN
\r
27550 SKIPGE (TP) ; SKIP IF NOT NEEDED
\r
27552 MOVM C,(TP) ; GET MAGNITUDE OF #
\r
27553 MOVE B,-2(TP) ; RESTORE CHANNEL
\r
27554 POP P,E ; RESTORE RADIX
\r
27555 PUSHJ P,FIXTYO ; WRITE OUT THE #
\r
27557 SUB P,[1,,1] ; FLUSH P STUFF
\r
27561 HRLM D,(P) ; SAVE REMAINDER
\r
27564 HLRZ A,(P) ; START GETTING #'S BACK
\r
27566 MOVE B,-2(TP) ; CHANNEL BACK
\r
27569 \f;PRINT SINGLE-PRECISION FLOATING POINT NUMBERS IN DECIMAL.
\r
27571 PFLOAT: SKIPN A,(TP) ; SKIP IF NUMBER IS NON-ZERO (SPECIAL HACK FOR ZERO)
\r
27572 JRST PFLT0 ; HACK THAT ZERO
\r
27573 MOVM E,A ; CHECK FOR NORMALIZED
\r
27574 TLNN E,400 ; NORMALIZED
\r
27576 MOVEI E,FLOATB ;ADDRESS OF FLOATING POINT CONVERSION ROUTINE
\r
27577 MOVE D,[6,,6] ;# WORDS TO GET FROM STACK
\r
27579 PNUMB: HRLI A,1(P) ;LH(A) TO CONTAIN ADDRESS OF RETURN AREA ON STACK
\r
27580 HRR A,TP ;RH(A) TO CONTAIN ADDRESS OF DATA ITEM
\r
27581 HLRZ B,A ;SAVE RETURN AREA ADDRESS IN REG B
\r
27582 ADD P,D ;ADD # WORDS OF RETURN AREA TO BOTH HALVES OF SP
\r
27583 JUMPGE P,PDLERR ;PLUS OR ZERO STACK POINTER IS OVERFLOW
\r
27584 PDLWIN: PUSHJ P,(E) ;CALL ROUTINE WHOSE ADDRESS IS IN REG E
\r
27586 MOVE C,(B) ;GET COUNT 0F # CHARS RETURNED
\r
27587 MOVE A,C ;MAKE SURE THAT # WILL FIT ON PRINT LINE
\r
27588 PFLT1: PUSH P,B ; SAVE B
\r
27589 MOVE B,-2(TP) ; GET CHANNEL INTO B
\r
27590 PUSHJ P,RETIF ;START NEW LINE IF IT WON'T
\r
27591 POP P,B ; RESTORE B
\r
27593 HRLI B,000700 ;MAKE REG B INTO BYTE POINTER TO FIRST CHAR LESS ONE
\r
27594 PNUM01: ILDB A,B ;GET NEXT BYTE
\r
27596 MOVE B,-2(TP) ; GET CHANNEL INTO B
\r
27597 PUSHJ P,PITYO ;PRINT IT
\r
27600 SOJG C,PNUM01 ;DECREMENT CHAR COUNT: LOOP IF NON-ZERO
\r
27602 SUB P,D ;SUBTRACT # WORDS USED ON STACK FOR RETURN
\r
27603 JRST PNEXT ;STORE REGS & POP UP ONE LEVEL TO CALLER
\r
27606 PFLT0: MOVEI A,9. ; WIDTH OF 0.0000000
\r
27607 MOVEI C,9. ; SEE ABOVE
\r
27608 MOVEI D,0 ; WE'RE GONNA TEST D SOON...SO WILL DO RIGHT THING
\r
27609 MOVEI B,[ASCII /0.0000000/]
\r
27610 SOJA B,PFLT1 ; PT TO 1 BELOW CONST, THEN REJOIN CODE
\r
27615 PDLERR: SUB P,D ;REST STACK POINTER
\r
27616 REPEAT 6,PUSH P,[0]
\r
27618 \f;PRINT SHORT (ONE WORD) CHARACTER STRINGS
\r
27620 PCHRS: MOVEI A,3 ;MAX # CHARS PLUS 2 (LESS ESCAPES)
\r
27621 MOVE B,-2(TP) ; GET CHANNEL INTO B
\r
27622 TLNE FLAGS,NOQBIT ;SKIP IF QUOTES WILL BE USED
\r
27623 MOVEI A,1 ;ELSE, JUST ONE CHARACTER POSSIBLE
\r
27624 PUSHJ P,RETIF ;NEW LINE IF INSUFFICIENT SPACE
\r
27625 TLNE FLAGS,NOQBIT ;DON'T QUOTE IF IN PRINC MODE
\r
27627 MOVEI A,"! ;TYPE A EXCL
\r
27629 MOVEI A,"" ;AND A DOUBLE QUOTE
\r
27632 PCASIS: MOVE A,(TP) ;GET NEXT BYTE FROM WORD
\r
27633 TLNE FLAGS,NOQBIT ;SKIP IF WE ARE NOT IN PRINC MODE (NOQBIT=0)
\r
27634 JRST PCPRNT ;IF BIT IS ON, PRINT WITHOUT ESCAPING
\r
27635 CAIE A,ESCHAR ;SKIP IF NOT THE ESCAPE CHARACTER
\r
27636 JRST PCPRNT ;ESCAPE THE ESCAPE CHARACTER
\r
27638 ESCPRT: MOVEI A,ESCHAR ;TYPE THE ESCAPE CHARACTER
\r
27641 PCPRNT: MOVE A,(TP) ;GET THE CHARACTER AGAIN
\r
27642 PUSHJ P,PITYO ;PRINT IT
\r
27646 \f;PRINT DEFERED (INVISIBLE) ITEMS. (PRINTED AS THE THING POINTED TO)
\r
27648 PDEFER: MOVE A,(B) ;GET FIRST WORD OF ITEM
\r
27649 MOVE B,1(B) ;GET SECOND
\r
27650 PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT
\r
27652 PUSHJ P,IPRINT ;PRINT IT
\r
27653 SUB TP,[2,,2] ; POP OFF CHANNEL
\r
27654 JRST PNEXT ;GO EXIT
\r
27657 ; Print an ATOM. TRAILERS are added if the atom is not in the current
\r
27658 ; lexical path. Also escaping of charactets is performed to allow READ
\r
27661 PATOM: PUSH P,[440700,,D] ; PUSH BYE POINTER TO FINAL STRING
\r
27662 SETZB D,E ; SET CHARCOUNT AD DESTINATION TO 0
\r
27663 HLLZS -1(TP) ; RH OF TATOM,, WILL COUNT ATOMS IN PATH
\r
27665 PATOM0: PUSH TP,$TPDL ; SAVE CURRENT STAKC FOR \ LOGIC
\r
27667 LDB A,[301400,,(P)] ; GET BYTE PTR POSITION
\r
27668 DPB A,[301400,,E] ; SAVE IN E
\r
27669 MOVE C,-2(TP) ; GET ATOM POINTER
\r
27670 ADD C,[3,,3] ; POINT TO PNAME
\r
27671 HLRE A,C ; -# WORDS TO A
\r
27672 PUSH P,A ; PUSH THAT FOR "AOSE"
\r
27673 MOVEI A,177 ; PUT RUBOUT WHERE \ MIGHT GO
\r
27675 HRLI C,440700 ; BUILD BYET POINTER
\r
27677 PATOM1: ILDB A,C ; GET A CHAR
\r
27678 JUMPE A,PATDON ; END OF PNAME?
\r
27679 TLNN C,760000 ; SKIP IF NOT WORD BOUNDARY
\r
27680 AOS (P) ; COUNT WORD
\r
27681 JRST PENTCH ; ENTER THE CHAR INTO OUTPUT
\r
27683 PATDON: LDB A,[220600,,E] ; GET "STATE"
\r
27684 LDB A,STABYT+6 ; SIMULATE "END" CHARACTER
\r
27685 DPB A,[220600,,E] ; AND STORE
\r
27686 MOVE B,E ; SETUP BYTE POINTER TO 1ST CHAR
\r
27688 HRR B,(TP) ; POINT
\r
27689 SUB TP,[2,,2] ; FLUSH SAVED PDL
\r
27690 MOVE C,-1(P) ; GET BYE POINTER
\r
27691 SUB P,[2,,2] ; FLUSH
\r
27695 AOS -1(TP) ; COUNT ATOMS
\r
27696 TLNE FLAGS,NOQBIT ; SKIP IF NOT "PRINC"
\r
27697 JRST NOLEX4 ; NEEDS NO LEXICAL TRAILERS
\r
27698 MOVEI A,"\ ; GET QUOTER
\r
27699 TLNN E,2 ; SKIP IF NEEDED
\r
27701 SOS -1(TP) ; DONT COUNT BECAUSE OF SLASH
\r
27702 DPB A,B ; CLOBBER
\r
27703 PATDO1: MOVEI E,(E) ; CLEAR LH(E)
\r
27704 PUSH P,C ; SAVE BYTER
\r
27705 PUSH P,E ; ALSO CHAR COUNT
\r
27707 MOVE B,IMQUOTE OBLIST
\r
27709 PUSHJ P,IDVAL ; GET LOCAL/GLOBAL VALUE
\r
27710 POP P,FLAGS ; AND RESTORES FLAGS
\r
27711 MOVE C,(TP) ; GET ATOM BACK
\r
27712 SKIPN C,2(C) ; GET ITS OBLIST
\r
27713 AOJA A,NOOBL1 ; NONE, USE FALSE
\r
27714 JUMPL C,.+3 ; JUMP IF REAL OBLIST
\r
27715 ADDI C,(TVP) ; ELSE MUST BE OFFSET
\r
27717 CAME A,$TLIST ; SKIP IF A LIST
\r
27718 CAMN A,$TOBLS ; SKIP IF UNREASONABLE VALUE
\r
27719 JRST CHOBL ; WINS, NOW LOCATE IT
\r
27721 CHROOT: CAME C,ROOT+1(TVP) ; IS THIS ROOT?
\r
27722 JRST FNDOBL ; MUST FIND THE PATH NAME
\r
27723 POP P,E ; RESTORE CHAR COUNT
\r
27724 MOVE D,(P) ; AND PARTIAL WORD
\r
27725 EXCH D,-1(P) ; STORE BYTE POINTER AND GET PARTIAL WORD
\r
27726 MOVEI A,"! ; PUT OUT MAGIC
\r
27727 JSP B,DOIDPB ; INTO BUFFER
\r
27733 NOLEX0: SUB P,[2,,2] ; REMOVE COUNTER AND BYTE POINTER
\r
27734 PUSH P,D ; PUSH NEXT WORD IF ANY
\r
27737 NOLEX: MOVE E,(P) ; GET COUNT
\r
27739 NOLEX4: MOVEI E,(E) ; CLOBBER LH(E)
\r
27740 MOVE A,E ; COUNT TO A
\r
27741 SKIPN (P) ; FLUSH 0 WORD
\r
27743 HRRZ C,-1(TP) ; GET # OF ATOMS
\r
27744 SUBI A,(C) ; FIX COUNT
\r
27745 MOVE B,-2(TP) ; GET CHANNEL INTO B
\r
27746 PUSHJ P,RETIF ; MAY NEED C.R.
\r
27747 MOVEI C,-1(E) ; COMPUTE WORDS-1
\r
27748 IDIVI C,5 ; WORDS-1 TO C
\r
27751 SUB D,C ; POINTS TO 1ST WORD OF CHARS
\r
27752 MOVSI C,440700+D ; BYTEPOINTER TO STRING
\r
27753 PUSH TP,$TPDL ; SAVE FROM GC
\r
27756 PATOUT: ILDB A,C ; READ A CHAR
\r
27757 SKIPE A ; IGNORE NULS
\r
27758 PUSHJ P,PITYO ; PRINT IT
\r
27759 MOVE D,(TP) ; RESTORE POINTER
\r
27762 NOLEXD: SUB TP,[2,,2] ; FLUSH TP JUNK
\r
27763 MOVE P,D ; RESTORE P
\r
27768 PENTCH: TLNE FLAGS,NOQBIT ; "PRINC"?
\r
27769 JRST PENTC1 ; YES, AVOID SLASHING
\r
27770 IDIVI A,CHRWD ; GET CHARS TYPE
\r
27772 CAIL B,6 ; SKIP IF NOT SPECIAL
\r
27773 JRST PENTC2 ; SLASH IMMEDIATE
\r
27774 LDB A,[220600,,E] ; GET "STATE"
\r
27775 LDB A,STABYT-1(B) ; GET NEW STATE
\r
27776 DPB A,[220600,,E] ; AND SAVE IT
\r
27777 PENTC3: LDB A,C ; RESTORE CHARACTER
\r
27778 PENTC1: JSP B,DOIDPB
\r
27779 SKIPGE (P) ; SKIP IF DONE
\r
27780 JRST PATOM1 ; CONTINUE
\r
27783 PENTC2: MOVEI A,"\ ; GET CHAR QUOTER
\r
27784 JSP B,DOIDPB ; NEEDED, DO IT
\r
27785 MOVEI A,4 ; PATCH FOR ATOMS ALREADY BACKSLASHED
\r
27788 ; ROUTINE TO PUT ONE CHAR ON STACK BUFFER
\r
27790 DOIDPB: IDPB A,-1(P) ; DEPOSIT
\r
27791 TRNN D,377 ; SKIP IF D FULL
\r
27793 PUSH P,(P) ; MOVE TOP OF STACK UP
\r
27794 MOVEM D,-2(P) ; SAVE WORDS
\r
27795 MOVE D,[440700,,D]
\r
27800 ; CHECK FOR UNIQUENESS LOOKING INTO PATH
\r
27802 CHOBL: CAME A,$TOBLS ; SINGLE OBLIST?
\r
27803 JRST LSTOBL ; NO, AL LIST THEREOF
\r
27804 CAME B,C ; THE RIGTH ONE?
\r
27805 JRST CHROOT ; NO, CHECK ROOT
\r
27806 JRST NOLEX ; WINNER, NO TRAILERS!
\r
27808 LSTOBL: PUSH TP,A ; SCAN A LIST OF OBLISTS
\r
27815 NXTOB2: INTGO ; LIST LOOP, PREVENT LOSSAGE
\r
27816 SKIPN C,-2(TP) ; SKIP IF NOT DONE
\r
27817 JRST CHROO1 ; EMPTY, CHECK ROOT
\r
27818 MOVE B,1(C) ; GET ONE
\r
27819 CAME B,(TP) ; WINNER?
\r
27820 JRST NXTOBL ; NO KEEP LOOKING
\r
27821 CAMN C,-4(TP) ; SKIP IF NOT FIRST ON LIST
\r
27823 MOVE A,-6(TP) ; GET ATOM BACK
\r
27825 ADD A,[3,,3] ; POINT TO PNAME
\r
27826 PUSH P,0 ; SAVE FROM RLOOKU
\r
27829 AOBJN A,.-2 ; PUSH THE PNAME
\r
27830 PUSH P,D ; AND CHAR COUNT
\r
27831 MOVSI A,TLIST ; TELL RLOOKU WE WIN
\r
27832 MOVE B,-4(TP) ; GET BACK OBLIST LIST
\r
27833 SUB TP,[6,,6] ; FLUSH CRAP
\r
27834 PUSHJ P,RLOOKU ; FIND IT
\r
27836 CAMN B,(TP) ; SKIP IF NON UNIQUE
\r
27837 JRST NOLEX ; UNIQUE , NO TRAILER!!
\r
27838 JRST CHROO2 ; CHECK ROOT
\r
27840 NXTOBL: HRRZ B,@-2(TP) ; STEP THE LIST
\r
27845 FNDOBL: MOVE C,(TP) ; GET ATOM
\r
27852 MOVE D,IMQUOTE OBLIST
\r
27856 NOOBL1: POP P,E ; RESTORE CHAR COUNT
\r
27857 MOVE D,(P) ; GET PARTIAL WORD
\r
27858 EXCH D,-1(P) ; AND BYTE POINTER
\r
27859 CAME A,$TATOM ; IF NOT ATOM, USE FALSE
\r
27861 MOVEM B,(TP) ; STORE IN ATOM SLOT
\r
27863 JSP B,DOIDPB ; WRITE IT OUT
\r
27867 JRST PATOM0 ; AND LOOP
\r
27869 NOOBL: MOVE C,[440700,,[ASCIZ /!-#FALSE ()/]]
\r
27876 NOLEX1: SUB TP,[6,,6] ; FLUSH STUFF
\r
27879 CHROO1: SUB TP,[6,,6]
\r
27880 CHROO2: MOVE C,(TP) ; GET ATOM
\r
27881 SKIPGE C,2(C) ; AND ITS OBLIST
\r
27888 \f; STATE TABLES FOR \ OF FIRST CHAR
\r
27904 STABYT: 400400,,STATS(A)
\r
27912 \f;PRINT LONG CHARACTER STRINGS.
\r
27914 PCHSTR: MOVE B,(TP)
\r
27915 TLZ FLAGS,ATMBIT ;WE ARE NOT USING ATOM-NAME TYPE ESCAPING
\r
27916 PUSH P,-1(TP) ; PUSH CHAR COUNT
\r
27917 MOVE D,[AOS E] ;GET INSTRUCTION TO COUNT CHARACTERS
\r
27918 SETZM E ;ZERO COUNT
\r
27919 PUSHJ P,PCHRST ;GO THROUGH STRING, ESCAPING, ETC. AND COUNTING
\r
27920 MOVE A,E ;PUT COUNT RETURNED IN REG A
\r
27921 TLNN FLAGS,NOQBIT ;SKIP (NO QUOTES) IF IN PRINC (BIT ON)
\r
27922 ADDI A,2 ;PLUS TWO FOR QUOTES
\r
27923 PUSH P,B ; SAVE B
\r
27924 MOVE B,-2(TP) ; GET CHANNEL INTO B
\r
27925 PUSHJ P,RETIF ;START NEW LINE IF NO SPACE
\r
27926 POP P,B ; RESTORE B
\r
27927 TLNE FLAGS,NOQBIT ;SKIP (PRINT ") IF BIT IS OFF (NOT PRINC)
\r
27928 JRST PCHS01 ;OTHERWISE, DON'T QUOTE
\r
27929 MOVEI A,"" ;PRINT A DOUBLE QUOTE
\r
27930 PUSH P,B ; SAVE B
\r
27933 POP P,B ; RESTORE B
\r
27935 PCHS01: MOVE D,[PUSHJ P,PITYO] ;OUTPUT INSTRUCTION
\r
27936 MOVEM B,(TP) ;RESET BYTE POINTER
\r
27937 POP P,-1(TP) ; RESET CHAR COUNT
\r
27938 PUSHJ P,PCHRST ;TYPE STRING
\r
27940 TLNE FLAGS,NOQBIT ;AGAIN, SKIP IF DOUBLE-QUOTING TO BE DONE
\r
27941 JRST PNEXT ;RESTORE REGS & POP UP ONE LEVEL TO CALLER
\r
27942 MOVEI A,"" ;PRINT A DOUBLE QUOTE
\r
27943 MOVE B,-2(TP) ; GET CHANNEL INTO B
\r
27944 PUSH P,B ; SAVE B
\r
27945 MOVE B,-2(TP) ; GET CHANNEL
\r
27947 POP P,B ;RESTORE B
\r
27951 ;INTERNAL ROUTINE USED TO COUNT OR OUTPUT CHARACTER STRINGS.
\r
27953 ;THE APPROPRIATE ESCAPING CONVENTIONS ARE USED AS DETERMINED BY THE FLAG BITS.
\r
27955 PCHRST: PUSH P,A ;SAVE REGS
\r
27960 PCHR02: INTGO ; IN CASE VERY LONG STRING
\r
27961 HRRZ C,-1(TP) ;GET COUNT
\r
27962 SOJL C,PCSOUT ; DONE?
\r
27964 ILDB A,(TP) ; GET CHAR
\r
27966 TLNE FLAGS,NOQBIT ;SKIP IF WE ARE NOT IN PRINC MODE (NOQBIT=0)
\r
27967 JRST PCSPRT ;IF BIT IS ON, PRINT WITHOUT ESCAPING
\r
27968 CAIN A,ESCHAR ;SKIP IF NOT THE ESCAPE CHARACTER
\r
27969 JRST ESCPRN ;ESCAPE THE ESCAPE CHARACTER
\r
27970 CAIN A,"" ;SKIP IF NOT A DOUBLE QUOTE
\r
27971 JRST ESCPRN ;OTHERWISE, ESCAPE THE """
\r
27972 IDIVI A,CHRWD ;CODE HERE FINDS CHARACTER TYPE
\r
27973 LDB B,BYTPNT(B) ; "
\r
27974 CAIGE B,6 ;SKIP IF NOT A NUMBER/LETTER
\r
27975 JRST PCSPRT ;OTHERWISE, PRINT IT
\r
27976 TLNN FLAGS,ATMBIT ;SKIP IF PRINTING AN ATOM-NAME (UNQUOTED)
\r
27977 JRST PCSPRT ;OTHERWISE, NO OTHER CHARS TO ESCAPE
\r
27979 ESCPRN: MOVEI A,ESCHAR ;TYPE THE ESCAPE CHARACTER
\r
27980 PUSH P,B ; SAVE B
\r
27981 MOVE B,-2(TP) ; GET CHANNEL INTO B
\r
27983 POP P,B ; RESTORE B
\r
27985 PCSPRT: LDB A,(TP) ;GET THE CHARACTER AGAIN
\r
27986 PUSH P,B ; SAVE B
\r
27987 MOVE B,-2(TP) ; GET CHANNEL INTO B
\r
27988 XCT (P)-1 ;PRINT IT
\r
27989 POP P,B ; RESTORE B
\r
27990 JRST PCHR02 ;LOOP THROUGH STRING
\r
27993 POP P,C ;RESTORE REGS & RETURN
\r
27999 \f;PRINT AN ARGUMENT LIST
\r
28000 ;CHECK FOR TIME ERRORS
\r
28002 PARGS: MOVEI B,-1(TP) ;POINT TO ARGS POINTER
\r
28003 PUSHJ P,CHARGS ;AND CHECK THEM
\r
28004 JRST PVEC ; CHEAT TEMPORARILY
\r
28009 PFRAME: MOVEI B,-1(TP) ;POINT TO FRAME POINTER
\r
28011 HRRZ B,(TP) ;POINT TO FRAME ITSELF
\r
28012 HRRZ B,FSAV(B) ;GET POINTER TO SUBROUTINE
\r
28015 SKIPA B,@-1(B) ; SUBRS AND FSUBRS
\r
28016 MOVE B,3(B) ; FOR RSUBRS
\r
28018 PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT
\r
28020 PUSHJ P,IPRINT ;PRINT FUNCTION NAME
\r
28021 SUB TP,[2,,2] ; POP CHANNEL OFF STACK
\r
28024 PPVP: MOVE B,(TP) ; PROCESS TO B
\r
28028 MOVE B,PROCID+1(B) ;GET ID
\r
28029 PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT
\r
28032 SUB TP,[2,,2] ; POP CHANNEL OFF STACK
\r
28035 ; HERE TO PRINT LOCATIVES
\r
28037 LOCPT1: HRRZ A,-1(TP)
\r
28039 LOCPT: MOVEI B,-1(TP) ; VALIDITY CHECK
\r
28046 PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT
\r
28049 SUB TP,[2,,2] ; POP CHANNEL OFF STACK
\r
28052 GLOCPT: MOVEI A,2
\r
28053 MOVE B,-2(TP) ; GET CHANNEL
\r
28060 MOVE B,MQUOTE GLOC
\r
28084 \f;PRINT UNIFORM VECTORS.
\r
28086 PUVEC: MOVE B,-2(TP) ; GET CHANNEL INTO B
\r
28087 MOVEI A,2 ; ROOM FOR ! AND SQ BRACK?
\r
28089 MOVEI A,"! ;TYPE AN ! AND OPEN SQUARE BRACKET
\r
28094 MOVE C,(TP) ;GET AOBJN POINTER TO VECTOR
\r
28095 TLNN C,777777 ;SKIP ONLY IF COUNT IS NOT ZERO
\r
28096 JRST NULVEC ;ELSE, VECTOR IS EMPTY
\r
28098 HLRE A,C ;GET NEG COUNT
\r
28099 MOVEI D,(C) ;COPY POINTER
\r
28100 SUB D,A ;POINT TO DOPE WORD
\r
28101 HLLZ A,(D) ;GET TYPE
\r
28102 PUSH P,A ;AND SAVE IT
\r
28104 PUVE02: MOVE A,(P) ;PUT TYPE CODE IN REG A
\r
28105 MOVE B,(C) ;PUT DATUM INTO REG B
\r
28106 PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT
\r
28108 PUSHJ P,IPRINT ;TYPE IT
\r
28109 SUB TP,[2,,2] ; POP CHANNEL OF STACK
\r
28110 MOVE C,(TP) ;GET AOBJN POINTER
\r
28111 AOBJP C,NULVE1 ;JUMP IF COUNT IS ZERO
\r
28112 MOVEM C,(TP) ;PUT POINTER BACK ONTO STACK
\r
28114 MOVE B,-2(TP) ; GET CHANNEL INTO B
\r
28116 JRST PUVE02 ;LOOP THROUGH VECTOR
\r
28118 NULVE1: SUB P,[1,,1] ;REMOVE STACK CRAP
\r
28119 NULVEC: MOVE B,-2(TP) ; GET CHANNEL INTO B
\r
28120 MOVEI A,"! ;TYPE CLOSE BRACKET
\r
28126 \f;PRINT A GENERALIZED VECTOR
\r
28128 PVEC: MOVE B,-2(TP) ; GET CHANNEL INTO B
\r
28129 PUSHJ P,RETIF1 ;NEW LINE IF NO ROOM FOR [
\r
28130 MOVEI A,"[ ;PRINT A LEFT-BRACKET
\r
28133 MOVE C,(TP) ;GET AOBJN POINTER TO VECTOR
\r
28134 TLNN C,777777 ;SKIP IF POINTER-COUNT IS NON-ZERO
\r
28135 JRST PVCEND ;ELSE, FINISHED WITH VECTOR
\r
28136 PVCR01: MOVE A,(C) ;PUT FIRST WORD OF NEXT ELEMENT INTO REG A
\r
28137 MOVE B,1(C) ;SECOND WORD OF LIST INTO REG B
\r
28138 PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT
\r
28140 PUSHJ P,IPRINT ;PRINT THAT ELEMENT
\r
28141 SUB TP,[2,,2] ; POP CHANNEL OFF STACK
\r
28143 MOVE C,(TP) ;GET AOBJN POINTER FROM TP-STACK
\r
28144 AOBJP C,PVCEND ;POSITIVE HERE SERIOUS ERROR! (THOUGH NOT PDL)
\r
28145 AOBJN C,.+2 ;SKIP AND CONTINUE LOOP IF COUNT NOT ZERO
\r
28146 JRST PVCEND ;ELSE, FINISHED WITH VECTOR
\r
28147 MOVEM C,(TP) ;PUT INCREMENTED POINTER BACK ON TP-STACK
\r
28149 MOVE B,-2(TP) ; GET CHANNEL INTO B
\r
28151 JRST PVCR01 ;CONTINUE LOOPING THROUGH OBJECTS ON VECTOR
\r
28153 PVCEND: MOVE B,-2(TP) ; GET CHANNEL INTO B
\r
28154 PUSHJ P,RETIF1 ;NEW LINE IF NO ROOM FOR ]
\r
28155 MOVEI A,"] ;PRINT A RIGHT-BRACKET
\r
28161 PLIST: MOVE B,-2(TP) ; GET CHANNEL INTO B
\r
28162 PUSHJ P,RETIF1 ;NEW LINE IF NO SPACE LEFT FOR "("
\r
28163 MOVEI A,"( ;TYPE AN OPEN PAREN
\r
28165 PUSHJ P,LSTPRT ;PRINT THE INSIDES
\r
28166 MOVE B,-2(TP) ; RESTORE CHANNEL TO B
\r
28167 PUSHJ P,RETIF1 ;NEW LINE IF NO ROOM FOR THE CLOSE PAREN
\r
28168 MOVEI A,") ;TYPE A CLOSE PAREN
\r
28172 PSEG: TLOA FLAGS,SEGBIT ;PRINT A SEGMENT (& SKIP)
\r
28174 PFORM: TLZ FLAGS,SEGBIT ;PRINT AN ELEMENT
\r
28176 PLMNT3: MOVE C,(TP)
\r
28177 JUMPE C,PLMNT1 ;IF THE CALL IS EMPTY GO AWAY
\r
28180 CAMN B,MQUOTE LVAL
\r
28182 CAMN B,MQUOTE GVAL
\r
28184 CAMN B,MQUOTE QUOTE
\r
28186 JUMPE D,PLMNT1 ;NEITHER, LEAVE
\r
28188 ;ITS A SPECIAL HACK
\r
28190 JUMPE C,PLMNT1 ;NIL BODY?
\r
28192 ;ITS VALUE OF AN ATOM
\r
28196 JUMPN C,PLMNT1 ;IF TERE ARE EXTRA ARGS GO AWAY
\r
28198 PUSH P,D ;PUSH THE CHAR
\r
28201 TLNN FLAGS,SEGBIT ;SKIP (CONTINUE) IF THIS IS A SEGMENT
\r
28202 JRST PLMNT4 ;ELSE DON'T PRINT THE "."
\r
28204 ;ITS A SEGMENT CALL
\r
28205 MOVE B,-4(TP) ; GET CHANNEL INTO B
\r
28206 MOVEI A,2 ; ROOM FOR ! AND . OR ,
\r
28211 PLMNT4: MOVE B,-4(TP) ; GET CHANNEL INTO B
\r
28213 POP P,A ;RESTORE CHAR
\r
28217 PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT
\r
28220 SUB TP,[2,,2] ; POP CHANNEL OFF STACK
\r
28224 PLMNT1: TLNN FLAGS,SEGBIT ;SKIP IF THIS IS A SEGMENT
\r
28225 JRST PLMNT5 ;ELSE DON'T TYPE THE "!"
\r
28227 ;ITS A SEGMENT CALL
\r
28228 MOVE B,-2(TP) ; GET CHANNEL INTO B
\r
28229 MOVEI A,2 ; ROOM FOR ! AND <
\r
28234 PLMNT5: MOVE B,-2(TP) ; GET CHANNEL FOR B
\r
28240 MOVE B,-2(TP) ; GET CHANNEL INTO B
\r
28241 TLNE FLAGS,SEGBIT ;SKIP IF NOT SEGEMNT
\r
28249 LSTPRT: SKIPN C,(TP)
\r
28251 HLLZ A,(C) ;GET NEXT ELEMENT
\r
28253 HRRZ C,(C) ;CHOP THE LIST
\r
28255 PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT
\r
28257 PUSHJ P,IPRINT ;PRINT THE LAST ELEMENT
\r
28258 SUB TP,[2,,2] ; POP CHANNEL OFF STACK
\r
28261 PLIST1: MOVEM C,(TP)
\r
28262 PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT
\r
28264 PUSHJ P, IPRINT ;PRINT THE NEXT ELEMENT
\r
28265 SUB TP,[2,,2] ; POP CHANNEL OFF STACK
\r
28266 MOVE B,-2(TP) ; GET CHANNEL INTO B
\r
28268 JRST LSTPRT ;REPEAT
\r
28270 PNEXT: POP P,FLAGS ;RESTORE PREVIOUS FLAG BITS
\r
28271 SUB TP,[2,,2] ;REMOVE INPUT ELEMENT FROM TP-STACK
\r
28272 POP P,C ;RESTORE REG C
\r
28280 JUMPGE B,FNFFL ;ERROR IF IT CANNOT BE OPENED
\r
28286 TITLE GETPUT ASSOCIATION FUNCTIONS FOR MUDDLE
\r
28292 ; COMPONENTS IN AN ASSOCIATION BLOCK
\r
28294 ITEM==0 ;ITEM TO WHICH INDUCATOR APPLIES
\r
28296 INDIC==4 ;INDICATOR
\r
28297 NODPNT==6 ;IF NON ZERO POINTS TO CHAIN
\r
28298 PNTRS==7 ;POINTERS NEXT (RH) AND PREV (LH)
\r
28300 ASOLNT==8 ;NUMBER OF WORDS IN AN ASSOCIATION BLOCK
\r
28302 .GLOBAL ASOVEC ;POINTER TO HASH VECTOR IN TV
\r
28303 .GLOBAL ASOLNT,ITEM,INDIC,VAL,NODPNT,NODES,IPUTP,IGETP,PUT,IFALSE
\r
28304 .GLOBAL DUMNOD,IGETLO,IBLOCK,MONCH,RMONCH,IPUT,IGETL,IREMAS,IGET
\r
28305 .GLOBAL NWORDT,CIGETP,CIGTPR,CIPUTP,CIREMA,MPOPJ
\r
28307 MFUNCTION GETP,SUBR,[GETPROP]
\r
28311 IGETP: PUSHJ P,GETLI
\r
28312 JRST FINIS ; NO SKIP, LOSE
\r
28315 PUSHJ P,RMONCH ; CHECK MONITOR
\r
28316 MOVE A,VAL(B) ;ELSE RETURN VALUE
\r
28318 CFINIS: JRST FINIS
\r
28320 ; FUNCTION TO RETURN LOCATIVE TO ASSOC
\r
28322 MFUNCTION GETPL,SUBR
\r
28326 IGETLO: PUSHJ P,GETLI
\r
28331 GETLI: PUSHJ P,2OR3 ; GET ARGS
\r
28332 PUSHJ P,IGETL ;SEE IF ASSOCIATION EXISTS
\r
28334 AOS (P) ; WIN RETURN
\r
28335 CAMGE AB,[-4,,0] ; ANY ERROR THING
\r
28336 JUMPE B,CHFIN ;IF 0, NONE EXISTS
\r
28339 CHFIN: PUSH TP,4(AB)
\r
28344 ; COMPILER CALLS TO SOME OF THESE
\r
28346 CIGETP: SUBM M,(P) ; FIX RET ADDR
\r
28347 PUSHJ P,IGETL ; GO TO INTERNAL
\r
28350 MPOPJ1: SOS (P) ; WINNER (SOS BECAUSE OF SUBM M,(P))
\r
28351 MPOPJ: SUBM M,(P)
\r
28354 CIGTPR: SUBM M,(P)
\r
28357 MOVE A,VAL(B) ; GET VAL TYPE
\r
28361 CIPUTP: SUBM M,(P)
\r
28362 PUSH TP,-1(TP) ; SAVE VAL
\r
28364 PUSHJ P,IPUT ; DO IT
\r
28369 CIREMA: SUBM M,(P)
\r
28370 PUSHJ P,IREMAS ; FLUSH IT
\r
28373 ; CHECK PUT/GET PUTPROP AND GETPROP ARGS
\r
28376 ASH 0,-1 ; TO -# OF ARGS
\r
28377 ADDI 0,2 ; AT LEAST 2
\r
28378 JUMPG 0,TFA ; 1 OR LESS, LOSE
\r
28379 AOJL 0,TMA ; 4 OR MORE, LOSE
\r
28380 MOVE A,(AB) ; GET ARGS INTO ACS
\r
28388 IGET: PUSHJ P,IGETL ; GET LOCATIVE
\r
28394 ; FUNCTION TO MAKE AN ASSOCIATION
\r
28396 MFUNCTION PUTP,SUBR,[PUTPROP]
\r
28400 IPUTP: PUSHJ P,2OR3 ; GET ARGS
\r
28401 JUMPN 0,REMAS ; REMOVE AN ASSOCIATION
\r
28402 PUSH TP,4(AB) ; SAVE NEW VAL
\r
28404 PUSHJ P,IPUT ; DO IT
\r
28405 MOVE A,(AB) ; RETURN NEW VAL
\r
28409 REMAS: PUSHJ P,IREMAS
\r
28412 IPUT: SKIPN DUMNOD+1(TVP) ; NEW DUMMY NEDDED?
\r
28413 PUSHJ P,DUMMAK ; YES, GO MAKE ONE
\r
28414 IPUT1: PUSHJ P,IGETI ;SEE IF THIS ONE EXISTS
\r
28416 JUMPE B,NEWASO ;JUMP IF NEED NEW ASSOCIATION BLOCK
\r
28417 CLOBV: MOVE C,-5(TP) ; RET NEW VAL
\r
28422 PUSHJ P,MONCH ; MONITOR CHECK
\r
28423 MOVEM C,VAL(B) ;STORE IT
\r
28427 ; HERE TO CREATE A NEW ASSOCIATION
\r
28429 NEWASO: MOVE B,DUMNOD+1(TVP) ; GET BALNK ASSOCIATION
\r
28430 SETZM DUMNOD+1(TVP) ; CAUSE NEW ONE NEXT TIME
\r
28433 ;NOW SPLICE IN CHAIN
\r
28435 JUMPE D,PUT1 ;NO OTHERS EXISTED IN THIS BUCKET
\r
28436 HRLZM C,PNTRS(B) ;CLOBBER PREV POINTER
\r
28437 HRRM B,PNTRS(C) ;AND NEXT POINTER
\r
28440 PUT1: HRRZM B,(C) ;STORE INTO VECTOR
\r
28441 HRRZ C,NODES+1(TVP)
\r
28444 HRRZM B,NODPNT(C)
\r
28447 MOVEI C,-3(TP) ;COPY ARG POINTER
\r
28448 MOVSI A,-4 ;AND COPY POINTER
\r
28450 PUT2: MOVE D,(C) ;START COPYING
\r
28451 MOVEM D,@CLOBTB(A)
\r
28453 AOBJN A,PUT2 ;NOTE *** DEPENDS ON ORDER IN VECTOR ***
\r
28457 ;HERE TO REMOVE AN ASSOCIATION
\r
28459 IREMAS: PUSHJ P,IGETL ;LOOK IT UP
\r
28460 JUMPE B,CPOPJ ;NEVER EXISTED, IGNORE
\r
28461 HRRZ A,PNTRS(B) ;NEXT POINTER
\r
28462 HLRZ E,PNTRS(B) ;PREV POINTER
\r
28463 SKIPE A ;DOES A NEXT EXIST?
\r
28464 HRLM E,PNTRS(A) ;YES CLOBBER ITS PREV POINTER
\r
28465 SKIPN D ;SKIP IF NOT FIRST IN BUCKET
\r
28466 MOVEM A,(C) ;FIRST STORE NEW ONE
\r
28467 SKIPE D ;OTHERWISE
\r
28468 HRRM A,PNTRS(E) ;PATCH NEXT POINTER IN PREVIOUS
\r
28469 HRRZ A,NODPNT(B) ;SEE IF MUST UNSPLICE NODE
\r
28472 HRLM E,NODPNT(A) ;SPLICE
\r
28473 JUMPE E,PUT4 ;FLUSH IF NO PREV POINTER
\r
28474 HRRZ C,NODPNT(E) ;GET PREV'S NEXT POINTER
\r
28475 CAIE C,(B) ;DOES IT POINT TO THIS NODE
\r
28476 .VALUE [ASCIZ /:
\eFATAL PUT LOSSAGE/]
\r
28477 HRRM A,NODPNT(E) ;YES, SPLICE
\r
28478 PUT4: MOVE A,VAL(B) ;RETURN VALUE
\r
28484 ;INTERNAL GET FUNCTION CALLED BY PUT AND GET
\r
28485 ; A AND B ARE THE ITEM
\r
28486 ;C AND D ARE THE INDICATOR
\r
28488 IGETL: PUSHJ P,IGETI
\r
28489 SUB TP,[4,,4] ; FLUSH CRUFT LEFT BY IGETI
\r
28492 IGETI: PUSHJ P,LHCLR
\r
28498 PUSH TP,C ;SAVE C AND D
\r
28500 XOR A,B ; BUILD HASH
\r
28503 TLZ A,400000 ; FORCE POS A
\r
28504 HLRZ B,ASOVEC+1(TVP) ;GET LENGTH OF HASH VECTOR
\r
28506 IDIVI A,(B) ;RELATIVE BUCKET NOW IN B
\r
28507 HRLI B,(B) ;IN CASE GC OCCURS
\r
28508 ADD B,ASOVEC+1(TVP) ;POINT TO BUCKET
\r
28509 MOVEI D,0 ;SET FIRST SWITCH
\r
28510 SKIPN A,(B) ;GET CONTENTS OF BUCKET (DONT SKIP IF EMPTY)
\r
28513 MOVSI 0,TASOC ;FOR INTGOS, MAKE A TASOC
\r
28514 HLLZM 0,ASTO(PVP)
\r
28516 IGET1: GETYPF 0,ITEM(A) ;GET ITEMS TYPE
\r
28519 CAMN 0,-3(TP) ;COMPARE TYPES
\r
28520 CAME E,-2(TP) ;AND VALUES
\r
28521 JRST NXTASO ;LOSER
\r
28522 GETYPF 0,INDIC(A) ;MOW TRY INDICATORS
\r
28523 MOVE E,INDIC+1(A)
\r
28528 SKIPN D ;IF 1ST THEN
\r
28529 MOVE C,B ;RETURN POINTER IN C
\r
28530 MOVE B,A ;FOUND, RETURN ASSOCIATION
\r
28532 IGRET: SETZM ASTO(PVP)
\r
28535 NXTASO: MOVEI D,1 ;SET SWITCH
\r
28537 HRRZ A,PNTRS(A) ;STEP
\r
28544 GFALSE: MOVE C,B ;PRESERVE VECTOR POINTER
\r
28549 ; FUNCTION TO DO A PUT AND ALSO ADD TO THE NODE FOR THIS GOODIE
\r
28552 MFUNCTION PUTN,SUBR
\r
28556 CAML AB,[-4,,0] ;WAS THIS A REMOVAL
\r
28559 PUSHJ P,IPUT ;DO THE PUT
\r
28560 SKIPE NODPNT(C) ;NODE CHAIN EXISTS?
\r
28563 PUSH TP,$TASOC ;NO, START TO BUILD
\r
28565 SKIPN DUMNOD+1(TVP) ; FIX UP DUMMY?
\r
28567 CHPT: MOVE C,$TCHSTR
\r
28568 MOVE D,CHQUOTE NODE
\r
28570 JUMPE B,MAKNOD ;NOT FOUND, LOSE
\r
28571 NODSPL: MOVE C,(TP) ;HERE TO SPLICE IN NEW NODE
\r
28572 MOVE D,VAL+1(B) ;GET POINTER TO NODE STRING
\r
28573 HRRM D,NODPNT(C) ;CLOBBER
\r
28575 SKIPE D ;SPLICE ONLY IF THERE IS SOMETHING THERE
\r
28577 MOVEM C,VAL+1(B) ;COMPLETE NODE CHAIN
\r
28578 MOVE A,2(AB) ;RETURN VALUE
\r
28582 MAKNOD: PUSHJ P,NEWASO ;GENERATE THE NEW ASSOCIATION
\r
28583 MOVE A,@CHPT ;GET UNIQUE STRING
\r
28584 MOVEM A,INDIC(C) ;CLOBBER IN INDIC
\r
28586 MOVEM A,INDIC+1(C)
\r
28587 MOVE B,C ;POINTER TO B
\r
28588 HRRZ C,NODES+1(TVP) ;GET POINTER TO CHAIN OF NODES
\r
28589 HRRZ D,VAL+1(C) ;SKIP DUMMY NODE
\r
28590 HRRM B,VAL+1(C) ;CLOBBER INTO CHAIN
\r
28592 SKIPE D ;SPLICE IF ONLY SOMETHING THERE
\r
28595 MOVSI A,TASOC ;SET TYPE OF VAL TO ASSOCIATION
\r
28598 JRST NODSPL ;GO SPLICE ITEM ONTO NODE
\r
28601 DUMMAK: PUSH TP,A
\r
28607 MOVSI A,400000+SASOC+.VECT.
\r
28608 MOVEM A,ASOLNT(B) ;SET SPECIAL TYPE
\r
28609 MOVEM B,DUMNOD+1(TVP)
\r
28623 MFUNCTION ASSOCIATIONS,SUBR
\r
28626 MOVE B,NODES+1(TVP)
\r
28627 ASSOC1: MOVSI A,TASOC ; SET TYPE
\r
28628 HRRZ B,NODPNT(B) ; POINT TO 1ST REAL NODE
\r
28632 ; RETURN NEXT ASSOCIATION IN CHAIN OR FALSE
\r
28634 MFUNCTION NEXT,SUBR
\r
28638 GETYP 0,(AB) ; BETTER BE ASSOC
\r
28640 JRST WTYP1 ; LOSE
\r
28641 MOVE B,1(AB) ; GET ARG
\r
28644 ; GET ITEM/INDICATOR/VALUE CELLS
\r
28646 MFUNCTION %ITEM,SUBR,ITEM
\r
28648 MOVEI B,ITEM ; OFFSET
\r
28651 MFUNCTION INDICATOR,SUBR
\r
28656 MFUNCTION AVALUE,SUBR
\r
28660 GETYP 0,(AB) ; BETTER BE ASSOC
\r
28663 ADD B,1(AB) ; GET ARG
\r
28670 PUSHJ P,NWORDT ; DEFERRED ?
\r
28673 LHCLR1: TLZ A,TYPMSK#<-1>
\r
28681 TITLE READC TELETYPE DEVICE HANDLER FOR MUDDLE
\r
28690 IFE ITS,.INSRT MUDSYS;STENEX >
\r
28693 .GLOBAL BUFRIN,CHRCNT,SYSCHR,ECHO,BYTPTR,ERASCH,KILLCH,BRKCH,AGC,CHRWRD,W1CHAR,GWB
\r
28694 .GLOBAL IOIN2,READC,WRONGC,BRFCHR,ESCAP,TTYOPE,MTYI,MTYO,NOTTY,TTYOP2,IBLOCK
\r
28695 .GLOBAL RRESET,TTICHN,TTOCHN,CHANNO,STATUS,BRFCH2,TTYBLK,TTYUNB,WAITNS
\r
28696 .GLOBAL EXBUFR,INCHAR,BYTDOP,BUFSTR,LSTCH,CHNCNT,DIRECT,IOINS,IBLOCK,INCONS
\r
28697 .GLOBAL BADCHN,WRONGD,CHNLOS,MODE1,MODE2,GMTYO,IDVAL,GETCHR,PAGLN,LINLN
\r
28702 ; FLAGS CONCERNING TTY CHANNEL STATE
\r
28704 N.ECHO==1 ; NO INPUT ECHO
\r
28705 N.CNTL==2 ; NO RUBOUT ^L ^D ECHO
\r
28706 N.IMED==4 ; ALL CHARS WAKE UP
\r
28707 N.IME1==10 ; SOON WILL BE N.IMED
\r
28710 ; OPEN BLOCK MODE BITS
\r
28717 ; READC IS CALLED BY PUSHJ P,READC
\r
28718 ; B POINTS TO A TTY FLAVOR CHANNEL
\r
28719 ; ONE CHARACTER IS RETURNED IN A
\r
28720 ; BECOMES INTERRUPTABLE IF NO CHARACTERS EXISTS
\r
28722 ; HERE TO ASK SYSTEM FOR SOME CHARACTERS
\r
28724 INCHAR: IRP A,,[0,C,D,E] ;SAVE ACS
\r
28727 MOVE E,BUFRIN(B) ; GET AUX BUFFER
\r
28729 HLRE 0,E ;FIND END OF BUFFER
\r
28731 ANDI 0,-1 ;ISOLATE RH
\r
28732 MOVE C,SYSCHR(E) ; GET FLAGS
\r
28734 INCHR1: TRNE C,N.IMED+N.CNTL ; SKIP IF NOT IMMEDIATE
\r
28736 TLZE D,40 ; SKIP IF NOT ESCAPED
\r
28737 JRST INCHR2 ; ESCAPED
\r
28738 CAMN A,ESCAP(E) ; IF ESCAPE
\r
28739 TLO D,40 ; REMEMBER
\r
28742 CAMN A,BRFCHR(E) ;BUFFER PRINT CHAR
\r
28743 JRST CLEARQ ;MAYBE CLEAR SCREEN
\r
28744 CAMN A,BRKCH(E) ;IS THIS A BREAK?
\r
28745 JRST DONE ;YES, DONE
\r
28746 CAMN A,ERASCH(E) ;ARE IS IT ERASE?
\r
28747 JRST ERASE ;YES, GO PROCESS
\r
28748 CAMN A,KILLCH(E) ;OR KILL
\r
28751 INCHR2: PUSHJ P,PUTCHR ;PUT ACHAR IN BUFFER
\r
28752 INCHR3: MOVEM D,BYTPTR(E)
\r
28755 DONE: SKIPL A ; IF JUST BUFFER FORCE, SKIP
\r
28756 PUSHJ P,PUTCHR ; STORE CHAR
\r
28757 MOVEI A,N.IMED ; TURN OFF IMEDIACY
\r
28758 ANDCAM A,SYSCHR(E)
\r
28759 MOVEM D,BYTPTR(E)
\r
28760 PUSH TP,$TCHAN ; SAVE CHANNEL
\r
28762 MOVE A,CHRCNT(E) ; GET # OF CHARS
\r
28765 ADDI A,4 ; ROUND UP
\r
28766 IDIVI A,5 ; AND DOWN
\r
28767 PUSHJ P,IBLOCK ; GET CORE
\r
28768 HLRE A,B ; FIND D.W.
\r
28770 MOVSI 0,TCHRS+.VECT. ; GET TYPE
\r
28771 MOVEM 0,(A) ; AND STORE
\r
28772 MOVEI D,(B) ; COPY PNTR
\r
28773 POP P,C ; CHAR COUNT
\r
28778 PUSHJ P,INCONS ; CONS IT ON
\r
28779 MOVE C,-2(TP) ; GET CHAN BACK
\r
28780 MOVEI D,EXBUFR(C) ; POINT TO BUFFER LIST
\r
28781 HRRZ 0,(D) ; LAST?
\r
28784 JRST .-3 ; GO UNTIL END
\r
28785 HRRM B,(D) ; SPLICE
\r
28787 ; HERE TO BLT IN BUFFER
\r
28789 MOVE D,BUFRIN(C) ; POINT TO COMPLETED BUFFER
\r
28790 HRRZ C,(TP) ; START OF NEW STRING
\r
28791 HRLI C,BYTPTR+1(D) ; 1ST WORD OF CHARS
\r
28792 MOVE E,[010700,,BYTPTR(E)]
\r
28793 EXCH E,BYTPTR(D) ; END OF STRING
\r
28794 MOVEI E,-BYTPTR(E)
\r
28795 ADD E,(TP) ; ADD TO START
\r
28797 MOVE B,-2(TP) ; CHANNEL BACK
\r
28798 SUB TP,[4,,4] ; FLUSH JUNK
\r
28799 PUSHJ P,TTYUNB ; UNBLOCK THIS TTY
\r
28800 DONE1: IRP A,,[E,D,C,0]
\r
28806 ERASE: SKIPN CHRCNT(E) ;ANYTHING IN BUFFER?
\r
28807 JRST BARFCR ;NO, MAYBE TYPE CR
\r
28809 SOS CHRCNT(E) ;DELETE FROM COUNT
\r
28810 LDB A,D ;RE-GOBBLE LAST CHAR
\r
28812 LDB C,[600,,STATUS(B)] ; CHECK FOR IMLAC
\r
28813 CAIE C,2 ; SKIP IF IT IS
\r
28816 SKIPN ECHO(E) ; SKIP IF ECHOABLE
\r
28818 PUSHJ P,CHRTYP ; FOUND OUT IMALC BEHAVIOR
\r
28819 SKIPGE C,FIXIM2(C)
\r
28821 NOTFUN: PUSHJ P,DELCHR
\r
28824 NECHO: ADD D,[70000,,0] ;DECREMENT BYTE POINTER
\r
28825 JUMPGE D,INCHR3 ;AND GO ON, UNLESS BYTE POINTER LOST
\r
28826 SUB D,[430000,,1] ;FIX UP BYTE POINTER
\r
28829 LFKILL: PUSHJ P,LNSTRV
\r
28832 BSKILL: PUSHJ P,GETPOS ; CURRENT POSITION TO A
\r
28833 PUSHJ P,SETPOS ; POSITION IMLAC CURSOR
\r
28836 MOVEI A,"L ; L , DELETE TO END OF LINE
\r
28840 TBKILL: PUSHJ P,GETPOS
\r
28842 SUBI A,10 ; A -NUMBER OF DELS TO DO
\r
28852 PUSH P,A ; USE TENEX SLASH RUBOUT
\r
28862 ; ROUTINE TO DEL CHAR ON IMLAC
\r
28864 DELCHR: MOVEI A,20
\r
28870 ; HERE FOR SPECIAL IMLAC HACKS
\r
28872 FOURQ: PUSH P,CNOTFU
\r
28873 FOURQ2: MOVEI C,2 ; FOR ^Z AND ^_
\r
28874 CAMN B,TTICHN+1(TVP) ; SKIP IF NOT CONSOLE TTY
\r
28876 CNOTFU: POPJ P,NOTFUN
\r
28878 CNECHO: JRST NECHO
\r
28880 LNSTRV: MOVEI A,20 ; ^P
\r
28886 ; HERE IF KILLING A C.R., RE-POSITION CURSOR
\r
28888 CRKILL: PUSHJ P,GETPOS ; COMPUTE LINE POS
\r
28892 SETPOS: PUSH P,A ; SAVE POS
\r
28898 XCT ECHO(E) ; HORIZ POSIT AT END OF LINE
\r
28902 MOVEI 0,10 ; MINIMUM CURSOR POS
\r
28903 PUSH P,[010700,,BYTPTR(E)] ; POINT TO BUFFER
\r
28904 PUSH P,CHRCNT(E) ; NUMBER THEREOF
\r
28906 GETPO1: SOSGE (P) ; COUNT DOWN
\r
28908 ILDB A,-1(P) ; CHAR FROM BUFFER
\r
28909 CAIN A,15 ; SKIP IF NOT CR
\r
28910 MOVEI 0,10 ; C.R., RESET COUNT
\r
28911 PUSHJ P,CHRTYP ; GET TYPE
\r
28912 XCT FIXIM3(C) ; GET FIXED COUNT
\r
28916 GETPO2: MOVE A,0 ; RET COUNT
\r
28917 MOVE 0,-2(P) ; RESTORE AC 0
\r
28921 CHRTYP: MOVEI C,0 ; NUMBER OF FLUSHEES
\r
28922 CAILE A,37 ; SKIP IF CONTROL CHAR
\r
28925 PUSH TP,B ; SAVE CHAN
\r
28926 IDIVI A,12. ; FIND SPECIAL HACKS
\r
28927 MOVE A,FIXIML(A) ; GET CONT WORD
\r
28929 ROTC A,3(B) ; GET CODE IN B
\r
28932 MOVE B,(TP) ; RESTORE CHAN
\r
28944 FIXIM3: MOVEI C,1
\r
28952 CNTTAB: ANDCMI 0,7 ; GET COUNT INCUDING TAB HACK
\r
28957 FIXIML: 111111,,115641 ; CNTL @ABCDE,,FGHIJK
\r
28958 131111,,111111 ; LMNOPQ,,RSTUVW
\r
28959 112011,,120000 ; XYZ LBRAK \ RBRAK,,^ _
\r
28961 ; HERE TO KILL THE WHOLE BUFFER
\r
28963 KILL: CLEARM CHRCNT(E) ;NONE LEFT NOW
\r
28964 MOVE D,[010700,,BYTPTR(E)] ;RESET POINTER
\r
28968 MOVE A,ERASCH(E) ;GET THE ERASE CHAR
\r
28969 CAIN A,177 ;IS IT RUBOUT?
\r
28971 PUSHJ P,CRLF1 ; PRINT CR-LF
\r
28976 MOVE A,STATUS(B) ;CHECK CONSOLE KIND
\r
28978 CAIN A,2 ;DATAPOINT?
\r
28979 PUSHJ P,CLR ;YES, CLEAR SCREEN
\r
28982 BRF: MOVE C,[010700,,BYTPTR(E)] ;POINT TO START OF BUFFER
\r
28983 SKIPN ECHO(E) ;ANY ECHO INS?
\r
28991 ILDB A,C ;GOBBLE CHAR
\r
28992 XCT ECHO(E) ;ECHO IT
\r
28993 JRST .-4 ;DO FOR ENTIRE BUFFER
\r
28995 DECHO: SUB P,[1,,1]
\r
28998 CLR: SKIPN C,ECHO(E) ;ONLY IF INS EXISTS
\r
29000 MOVEI A,20 ;ERASE SCREEN
\r
29006 PUTCHR: AOS CHRCNT(E) ;COUNT THIS CHARACTER
\r
29007 IBP D ;BUMP BYTE POINTER
\r
29008 CAIG 0,@D ;DONT SKIP IF BUFFER FULL
\r
29009 PUSHJ P,BUFULL ;GROW BUFFER
\r
29011 CAIN A,37 ; CHANGE EOL TO CRLF
\r
29014 DPB A,D ;CLOBBER BYTE POINTER IN
\r
29015 MOVE C,SYSCHR(E) ; FLAGS
\r
29016 TRNN C,N.IMED+N.CNTL
\r
29017 CAIE A,15 ; IF CR INPUT, FOLLOW WITH LF
\r
29019 MOVEI A,12 ; GET LF
\r
29022 ; BUFFER FULL, GROW THE BUFFER
\r
29024 BUFULL: PUSH TP,$TCHAN ;SAVE B
\r
29026 PUSH P,A ; SAVE CURRENT CHAR
\r
29029 ADDI A,100 ; MAKE ONE LONGER
\r
29030 PUSHJ P,IBLOCK ; GET IT
\r
29031 MOVE A,(TP) ;RESTORE CHANNEL POINTER
\r
29032 SUB TP,[2,,2] ;AND REMOVE CRUFT
\r
29033 MOVE E,BUFRIN(A) ;GET AUX BUFFER POINTER
\r
29034 MOVEM B,BUFRIN(A)
\r
29035 HLRE 0,E ;RECOMPUTE 0
\r
29037 HRRI E,(B) ; POINT TO DEST
\r
29045 ; ROUTINE TO CRLF ON ANY TTY
\r
29047 CRLF1: SKIPN ECHO(E)
\r
29048 POPJ P, ; NO ECHO INS
\r
29049 CRLF2: MOVEI A,15
\r
29055 ; SUBROUTINE TO FLUSH BUFFER
\r
29057 RRESET: SETZM LSTCH(B) ; CLOBBER RE-USE CHAR
\r
29058 MOVE E,BUFRIN(B) ;GET AUX BUFFER
\r
29060 MOVEI D,N.IMED+N.IME1
\r
29061 ANDCAM D,SYSCHR(E)
\r
29062 MOVE D,[010700,,BYTPTR(E)] ;RESET BYTE POINTER
\r
29063 MOVEM D,BYTPTR(E)
\r
29064 MOVE D,CHANNO(B) ;GOBBLE CHANNEL
\r
29065 SETZM CHNCNT(D) ; FLUSH COUNTERS
\r
29067 LSH D,23. ;POSITION
\r
29069 XCT D ;RESET ITS CHANNEL
\r
29072 MOVEI A,100 ; TTY IN JFN
\r
29075 SETZM EXBUFR(B) ; CLOBBER STAKED BUFFS
\r
29076 MOVEI C,BUFSTR-1(B) ; FIND D.W.
\r
29080 MOVEM A,BUFSTR(B)
\r
29081 HLLZS BUFSTR-1(B)
\r
29084 ; SUBROUTINE TO ESTABLISH ECHO IOINS
\r
29086 MFUNCTION ECHOPAIR,SUBR
\r
29090 GETYP A,(AB) ;CHECK ARG TYPES
\r
29092 CAIN A,TCHAN ;IS A CHANNEL
\r
29093 CAIE C,TCHAN ;IS C ALSO
\r
29094 JRST WRONGT ;NO, ONE OF THEM LOSES
\r
29096 MOVE A,1(AB) ;GET CHANNEL
\r
29097 PUSHJ P,TCHANC ; VERIFY TTY IN
\r
29098 MOVE D,3(AB) ;GET OTHER CHANNEL
\r
29099 MOVEI B,DIRECT-1(D) ;AND ITS DIRECTION
\r
29102 CAME B,[ASCII /PRINT/]
\r
29105 MOVE B,BUFRIN(A) ;GET A'S AUX BUFFER
\r
29106 HRLZ C,CHANNO(D) ; GET CHANNEL
\r
29108 IOR C,[.IOT A] ; BUILD AN IOT
\r
29109 MOVEM C,ECHO(B) ;CLOBBER
\r
29110 CHANRT: MOVE A,(AB)
\r
29111 MOVE B,1(AB) ;RETURN 1ST ARG
\r
29114 TCHANC: MOVEI B,DIRECT-1(A) ;GET DIRECTION
\r
29115 PUSHJ P,CHRWRD ; CONVERT
\r
29117 CAME B,[ASCII /READ/]
\r
29119 LDB C,[600,,STATUS(A)] ;GET A CODE
\r
29120 CAILE C,2 ;MAKE SURE A TTY FLAVOR DEVICE
\r
29125 TTYOP2: MOVEI A,-1 ; TENEX JFN FOR TERMINAL
\r
29126 MOVEI 2,145100 ; MAGIC BITS (SEE TENEX MANUAL)
\r
29128 RFMOD ; LETS FIND SCREEN SIZE
\r
29129 LDB A,[220700,,B] ; GET PAGE WIDTH
\r
29130 LDB B,[310700,,B] ; AND LENGTH
\r
29131 MOVE C,TTOCHN+1(TVP)
\r
29134 MOVEI A,-1 ; NOW HACK CNTL CHAR STUFF
\r
29135 RFCOC ; GET CURRENT
\r
29136 AND B,[036377,,-1] ; CHANGE FOR ^@, ^A AND ^D (FOR NOW)
\r
29137 SFCOC ; AND RESUSE IT
\r
29143 TTYOP2: .SUSET [.RTTY,,C]
\r
29145 JUMPL C,TTYNO ; DONT HAVE TTY
\r
29150 .OPEN TTYIN,[SIXBIT / TTY/]
\r
29152 .OPEN TTYOUT,[21,,(SIXBIT /TTY/)] ;AND OUTPUT
\r
29153 FATAL CANT OPEN TTY
\r
29154 DOTCAL TTYGET,[[1000,,TTYOUT],[2000,,0],[2000,,A],[2000,,B]]
\r
29155 FATAL .CALL FAILURE
\r
29156 DOTCAL TTYSET,[[1000,,TTYOUT],MODE1,MODE2,B]
\r
29157 FATAL .CALL FAILURE
\r
29159 SETCHN: MOVE B,TTICHN+1(TVP) ;GET CHANNEL
\r
29160 MOVEI C,TTYIN ;GET ITS CHAN #
\r
29161 MOVEM C,CHANNO(B)
\r
29162 .STATUS TTYIN,STATUS(B) ;CLOBBER STATUS
\r
29164 MOVE B,TTOCHN+1(TVP) ;GET OUT CHAN
\r
29166 MOVEM C,CHANNO(B)
\r
29167 .STATUS TTYOUT,STATUS(B)
\r
29168 SETZM IMAGFL ;RESET IMAGE MODE FLAG
\r
29170 DOTCAL RSSIZE,[[1000,,TTYOUT],[2000,,C],[2000,,D]]
\r
29171 FATAL .CALL RSSIZE LOSSAGE
\r
29176 ; HERE IF TTY WONT OPEN
\r
29178 TTYNO: SETOM NOTTY
\r
29182 MTYI: SKIPE NOTTY ; SKIP IF HAVE TTY
\r
29183 FATAL TRIED TO USE NON-EXISTANT TTY
\r
29184 IFN ITS, .IOT TTYIN,A
\r
29188 MTYO: SKIPE NOTTY
\r
29189 POPJ P, ; IGNORE, DONT HAVE TTY
\r
29190 SKIPE IMAGFL ;SKIP RE-OPENING IF ALREADY IN ASCII
\r
29191 PUSHJ P,MTYO1 ;WAS IN IMAGE...RE-OPEN
\r
29192 CAIE A,177 ;DONT OUTPUT A DELETE
\r
29193 IFN ITS, .IOT TTYOUT,A
\r
29197 MTYO1: MOVE B,TTOCHN+1(TVP)
\r
29203 ; HERE FOR TYO TO ANY TTY FLAVOR DEVICE
\r
29206 HRRZ 0,IOINS-1(B) ; GET FLAG
\r
29208 PUSHJ P,REASCI ; RE-OPEN TTY
\r
29212 CAIE A,177 ; DONE OUTPUT A DELETE
\r
29220 HRLI C,21 ; ASCII GRAPHIC BIT
\r
29221 MOVE A,CHANNO(B) ; GET CHANNEL
\r
29222 ASH A,23. ; TO AC FIELD
\r
29223 IOR A,[.OPEN 0,C]
\r
29225 FATAL TTY OPEN LOSSAGE
\r
29229 CAMN B,TTOCHN+1(TVP)
\r
29235 WRONGC: PUSH TP,$TATOM
\r
29236 PUSH TP,EQUOTE NOT-A-TTY-TYPE-CHANNEL
\r
29241 ; HERE TO HANDLE TTY BLOCKING AND UNBLOCKING
\r
29243 TTYBLK: PUSH TP,$TCHAN
\r
29246 PUSH P,E ; SAVE SOME ACS
\r
29248 MOVE A,CHANNO(B) ; GET CHANNEL NUMBER
\r
29249 SOSG CHNCNT(A) ; ANY PENDING CHARS
\r
29254 .SUSET [.SIFPI,,0] ; SLAM AN INT ON
\r
29256 TTYBL1: MOVE C,BUFRIN(B)
\r
29257 MOVE A,SYSCHR(C) ; GET FLAGS
\r
29259 TRZE A,N.IME1 ; IF WILL BE
\r
29260 TRO A,N.IMED ; THE MAKE IT
\r
29261 MOVEM A,SYSCHR(C)
\r
29263 MOVE A,[.CALL TTYIOT]; NON-BUSY WAIT
\r
29265 MOVE A,[.SLEEP A,]
\r
29268 MOVE A,[PUSHJ P,TNXIN]
\r
29270 MOVEM A,WAITNS(B)
\r
29272 PUSH TP,CHQUOTE BLOCKED
\r
29275 MCALL 2,INTERRUPT
\r
29277 MOVEM A,BSTO(PVP)
\r
29280 REBLK: MOVEI A,-1 ; IN CASE SLEEPING
\r
29281 XCT WAITNS(B) ; NOW WAIT
\r
29283 IFE ITS, JRST .-3
\r
29284 IFN ITS, JRST CHRSNR ; SNARF CHAR
\r
29285 REBLK1: DISABLE ; FALL THROUG=> UNBLOCKED
\r
29293 CHRSNR: SKIPE NOTTY ; TTY?
\r
29294 JRST REBLK ; NO, JUST RESET AND BLOCK
\r
29295 .SUSET [.SIFPI,,[1_<TTYIN>]]
\r
29296 JRST REBLK ; AND GO BACK
\r
29304 ; HERE TO UNBLOCK TTY
\r
29306 TTYUNB: MOVE A,WAITNS(B) ; GET INS
\r
29307 CAMN A,[JRST REBLK1]
\r
29309 MOVE A,[JRST REBLK1] ; LEAVE THE SLEEP
\r
29310 MOVEM A,WAITNS(B)
\r
29314 PUSH TP,CHQUOTE UNBLOCKED
\r
29317 MCALL 2,INTERRUPT
\r
29318 MOVE B,(TP) ; RESTORE CHANNEL
\r
29323 ; TENEX BASIC TTY I/O ROUTINE
\r
29325 TNXIN: PUSHJ P,MTYI
\r
29329 MFUNCTION TTYECHO,SUBR
\r
29336 MOVE A,1(AB) ; GET CHANNEL
\r
29337 PUSHJ P,TCHANC ; MAKE SURE IT IS TTY INPUT
\r
29338 MOVE E,BUFRIN(A) ; EXTRA INFO BUFFER
\r
29340 DOTCAL TTYGET,[CHANNO(A),[2000,,B],[2000,,C],[2000,,0]]
\r
29341 FATAL .CALL FAILURE
\r
29344 MOVEI A,100 ; TTY JFN
\r
29345 RFMOD ; MODE IN B
\r
29346 TRZ B,6000 ; TURN OFF ECHO
\r
29348 GETYP D,2(AB) ; ARG 2
\r
29349 CAIE D,TFALSE ; SKIP IF WANT ECHO OFF
\r
29353 ANDCM B,[606060,,606060]
\r
29354 ANDCM C,[606060,,606060]
\r
29356 DOTCAL TTYSET,[CHANNO(A),B,C,0]
\r
29357 FATAL .CALL FAILURE
\r
29363 MOVEI B,N.ECHO+N.CNTL ; SET FLAGS
\r
29370 IOR B,[202020,,202020]
\r
29371 IOR C,[202020,,202020]
\r
29372 DOTCAL TTYSET,[CHANNO(A),B,C,0]
\r
29373 FATAL .CALL FAILURE
\r
29379 MOVEI A,N.ECHO+N.CNTL
\r
29380 ANDCAM A,SYSCHR(E)
\r
29385 ; USER SUBR FOR INSTANT CHARACTER SNARFING
\r
29387 MFUNCTION UTYI,SUBR,TYI
\r
29395 MOVE B,IMQUOTE INCHAN
\r
29396 PUSHJ P,IDVAL ; USE INCHAN
\r
29397 GETYP 0,A ; GET TYPE
\r
29400 LDB 0,[600,,STATUS(B)]
\r
29403 SKIPN A,LSTCH(B) ; ANY READ AHEAD CHAR
\r
29404 JRST UTYI1 ; NO, SKIP
\r
29406 TLZN A,400000 ; ! HACK?
\r
29407 JRST UTYI2 ; NO, OK
\r
29408 MOVEM A,LSTCH(B) ; YES SAVE
\r
29409 MOVEI A,"! ; RET AN !
\r
29412 UTYI1: MOVE 0,IOINS(B)
\r
29413 CAME 0,[PUSHJ P,GETCHR]
\r
29418 MOVEI D,N.IME1+N.IMED
\r
29419 IORM D,SYSCHR(C) ; CLOBBER IT IN
\r
29420 DOTCAL TTYGET,[CHANNO(B),[2000,,A],[2000,,D],[2000,,0]]
\r
29421 FATAL .CALL FAILURE
\r
29424 PUSH P,D ; SAVE THEM
\r
29425 IOR D,[030303,,030303]
\r
29426 IOR A,[030303,,030303]
\r
29427 DOTCAL TTYSET,[CHANNO(B),A,D,0]
\r
29428 FATAL .CALL FAILURE
\r
29430 SKIPE CHRCNT(C) ; ALREADY SOME?
\r
29432 MOVE C,BUFRIN(B) ; GET BUFFER BACK
\r
29438 MOVEI D,N.IME1+N.IMED
\r
29439 ANDCAM D,SYSCHR(C)
\r
29443 DOTCAL TTYSET,[CHANNO(B),C,D,0]
\r
29444 FATAL .CALL FAILURE
\r
29445 UTYI2: MOVEI B,(A)
\r
29449 MFUNCTION IMAGE,SUBR
\r
29451 JUMPGE AB,TFA ; 1 OR 2 ARGS NEEDED
\r
29452 GETYP A,(AB) ;GET THE TYPE OF THE ARG
\r
29453 CAIE A,TFIX ;CHECK IT FOR CORRECT TYPE
\r
29454 JRST WTYP1 ;WAS WRONG...ERROR EXIT
\r
29463 MOVE B,3(AB) ; GET CHANNEL
\r
29464 IMAGE1: LDB 0,[600,,STATUS(B)]
\r
29465 CAILE 0,2 ; MUST BE TTY
\r
29468 CAMN 0,[PUSHJ P,MTYO]
\r
29470 CAME 0,[PUSHJ P,GMTYO]
\r
29472 HRRZ 0,IOINS-1(B)
\r
29474 IMGIOT: MOVE A,1(AB) ;GET VALUE
\r
29479 IMGEXT: MOVE A,(AB) ;RETURN THE ORIGINAL ARG
\r
29484 IMAGFO: PUSH TP,$TCHAN ;IMAGE OUTPUT FOR NON TTY
\r
29486 MOVEI B,DIRECT-1(B)
\r
29489 CAME B,[ASCII /PRINT/]
\r
29490 CAMN B,[<ASCII /PRINT/>+1]
\r
29492 JRST BADCHN ; CHANNEL COULDNT BE BLESSED
\r
29494 PUSHJ P,GWB ; MAKE SURE CHANNEL HAS BUFFER
\r
29495 MOVE A,1(AB) ; GET THE CHARACTER TO DO
\r
29498 MOVE B,1(AB) ;RETURN THE FIX
\r
29502 USEOTC: MOVSI A,TATOM
\r
29503 MOVE B,IMQUOTE OUTCHAN
\r
29507 MOVE B,TTICHN+1(TVP)
\r
29510 OPNIMG: HLLOS IOINS-1(B)
\r
29511 CAMN B,TTOCHN+1(TVP)
\r
29514 HRLI C,41 ; SUPER IMAGE BIT
\r
29517 IOR A,[.OPEN 0,C]
\r
29519 FATAL TTY OPEN LOSSAGE
\r
29527 MOVE E,[220600,,C]
\r
29540 IMGBLK: OUT+IMAGEM+UNIT,,(SIXBIT /TTY/)
\r
29553 TITLE READER FOR MUDDLE
\r
29555 ;C. REEVE DEC. 1970
\r
29559 READER==1 ;TELL MUDDLE > TO USE SOME SPECIAL HACKS
\r
29560 FRMSIN==1 ;FLAG SAYING WHETHER OR "." AND "'" HACKS EXIST
\r
29564 .GLOBAL CONS,VECTOR,NXTCHR,RLOOKU,CRADIX,SPTIME,QUOTE,TENTAB,CHMAK,FLUSCH,ITENTB
\r
29565 .GLOBAL SETDEV,OPNCHN,ILVAL,RADX,IDVAL,LSTCH,EVECTOR,EUVECTOR,CHUNW
\r
29566 .GLOBAL CHRWRD,EOFCND,DIRECT,ACCESS,IOINS,ROOT,DIRECT,DOIOTI,DOACCS,IGVAL,BYTDOP
\r
29567 .GLOBAL ICONS,INCONS,IEVECT,IEUVEC,BUFSTR,TYPFND,SQUTOA,IBLOCK,GRB
\r
29568 .GLOBAL BADCHN,WRONGD,CHNCLS,FNFFL,IPUT,IGET,ILOC,RXCT,WXCT,IUNWIN,UNWIN2
\r
29569 .GLOBAL CNXTCH,CREADC,MPOPJ,CREDC1,CNXTC1,IREMAS
\r
29573 FF=0 ;FALG REGISTER DURING NUMBER CONVERSION
\r
29575 ;FLAGS USED (RIGHT HALF)
\r
29577 NOTNUM==1 ;NOT A NUMBER
\r
29578 NFIRST==2 ;NOT FIRST CHARACTER BEING READ
\r
29579 DECFRC==4 ;FORCE DECIMAL CONVERSION
\r
29580 NEGF==10 ;NEGATE THIS THING
\r
29581 NUMWIN==20 ;DIGIT(S) SEEN
\r
29582 INSTRN==40 ;IN QUOTED CHARACTER STRING
\r
29583 FLONUM==100 ;NUMBER IS FLOOATING POINT
\r
29584 DOTSEN==200 ;. SEEN IN IMPUT STREAM
\r
29585 EFLG==400 ;E SEEN FOR EXPONENT
\r
29587 FRSDOT==1000 ;. CAME FIRST
\r
29588 USEAGN==2000 ;SPECIAL DOT HACK
\r
29593 ;TEMPORARY OFFSETS
\r
29595 VCNT==0 ;NUMBER OF ELEMENTS IN CURRENT VECTOR
\r
29596 ONUM==1 ;CURRENT NUMBER IN OCTAL
\r
29597 DNUM==3 ;CURRENT NUMBER IN DECIMAL
\r
29598 FNUM==5 ;CURRENTLY UNUSED
\r
29599 CNUM==7 ;IN CURRENT RADIX
\r
29600 NDIGS==11 ;NUMBER OF DIGITS
\r
29601 ENUM==13 ;EXPONENT
\r
29604 \f; TEXT FILE LOADING PROGRAM
\r
29606 MFUNCTION MLOAD,SUBR,[LOAD]
\r
29610 HLRZ A,AB ;GET NO. OF ARGS
\r
29611 CAIE A,-4 ;IS IT 2
\r
29612 JRST TRY2 ;NO, TRY ANOTHER
\r
29613 GETYP A,2(AB) ;GET TYPE
\r
29614 CAIE A,TOBLS ;IS IT OBLIST
\r
29615 CAIN A,TLIST ; OR LIST THEREOF?
\r
29619 TRY2: CAIE A,-2 ;IS ONE SUPPLIED
\r
29622 CHECK1: GETYP A,(AB) ;GET TYPE
\r
29623 CAIE A,TCHAN ;IS IT A CHANNEL
\r
29626 LOAD1: HLRZ A,TB ;GET CURRENT TIME
\r
29627 PUSH TP,$TTIME ;AND SAVE IT
\r
29630 MOVEI C,CLSNGO ; LOCATION OF FUNNY CLOSER
\r
29631 PUSHJ P,IUNWIN ; SET UP AS UNWINDER
\r
29633 LOAD2: PUSH TP,(AB) ;USE SUPPLIED CHANNEL
\r
29635 PUSH TP,(TB) ;USE TIME AS EOF ARG
\r
29637 CAML AB,[-2,,0] ;CHECK FOR 2ND ARG
\r
29639 PUSH TP,2(AB) ;PUSH ON 2ND ARG
\r
29642 JRST CHKRET ;CHECK FOR EOF RET
\r
29644 LOAD3: MCALL 2,READ
\r
29645 CHKRET: CAMN A,(TB) ;IS TYPE EOF HACK
\r
29646 CAME B,1(TB) ;AND IS VALUE
\r
29647 JRST EVALIT ;NO, GO EVAL RESULT
\r
29652 MOVE B,CHQUOTE DONE
\r
29655 CLSNGO: PUSH TP,$TCHAN
\r
29658 JRST UNWIN2 ; CONTINUE UNWINDING
\r
29660 EVALIT: PUSH TP,A
\r
29667 ; OTHER FILE LOADING PROGRAM
\r
29671 MFUNCTION FLOAD,SUBR
\r
29675 MOVEI C,1 ;INITIALIZE OPEN'S ARG COUNT
\r
29676 PUSH TP,$TAB ;SLOT FOR SAVED AB
\r
29677 PUSH TP,[0] ;EMPTY FOR NOW
\r
29678 PUSH TP,$TCHSTR ;PUT IN FIRST ARG
\r
29679 PUSH TP,CHQUOTE READ
\r
29680 MOVE A,AB ;COPY OF ARGUMENT POINTER
\r
29682 FARGS: JUMPGE A,CALOPN ;DONE? IF SO CALL OPEN
\r
29683 GETYP B,(A) ;NO, CHECK TYPE OF THIS ARG
\r
29684 CAIE B,TOBLS ;OBLIST?
\r
29685 CAIN B,TLIST ; OR LIST THEREOF
\r
29686 JRST OBLSV ;YES, GO SAVE IT
\r
29688 PUSH TP,(A) ;SAVE THESE ARGS
\r
29690 ADD A,[2,,2] ;BUMP A
\r
29691 AOJA C,FARGS ;COUNT AND GO
\r
29693 OBLSV: MOVEM A,1(TB) ;SAVE THE AB
\r
29695 CALOPN: ACALL C,FOPEN ;OPEN THE FILE
\r
29697 JUMPGE B,FNFFL ;FILE MUST NO EXIST
\r
29698 EXCH A,(TB) ;PLACE CHANNEL ON STACK
\r
29699 EXCH B,1(TB) ;OBTAINING POSSIBLE OBLIST
\r
29700 JUMPN B,2ARGS ;OBLIST SUOPPLIED?
\r
29702 MCALL 1,MLOAD ;NO, JUST CALL
\r
29706 2ARGS: PUSH TP,(B) ;PUSH THE OBLIST
\r
29712 FNFFL: PUSH TP,$TATOM
\r
29713 PUSH TP,EQUOTE FILE-SYSTEM-ERROR
\r
29720 \fMFUNCTION READ,SUBR
\r
29724 PUSH P,[IREAD1] ;WHERE TO GO AFTER BINDING
\r
29725 READ0: PUSH TP,$TTP ;SLOT FOR LAST THING READ (TYPE IS UNREADABLE)
\r
29727 PUSH TP,$TFIX ;SLOT FOR RADIX
\r
29729 PUSH TP,$TCHAN ;AND SLOT FOR CHANNEL
\r
29731 PUSH TP,[0] ; USER DISP SLOT
\r
29734 PUSH TP,[0] ;SEGMENT FOR SPLICING MACROS
\r
29735 JUMPGE AB,READ1 ;NO ARGS, NO BINDING
\r
29736 GETYP C,(AB) ;ISOLATE TYPE
\r
29739 PUSH TP,[TATOM,,-1] ;PUSH THE ATOMS
\r
29740 PUSH TP,IMQUOTE INCHAN
\r
29741 PUSH TP,(AB) ;PUSH ARGS
\r
29743 PUSH TP,[0] ;DUMMY
\r
29745 MOVE B,1(AB) ;GET CHANNEL POINTER
\r
29746 ADD AB,[2,,2] ;AND ARG POINTER
\r
29747 JUMPGE AB,BINDEM ;MORE?
\r
29748 PUSH TP,[TVEC,,-1]
\r
29749 ADD B,[EOFCND-1,,EOFCND-1]
\r
29754 JUMPGE AB,BINDEM ;IF ANY MORE ARGS GO PROCESS AND BIND THEM
\r
29755 GETYP C,(AB) ;ISOLATE TYPE
\r
29760 PUSH TP,[TATOM,,-1] ;PUSH THE ATOMS
\r
29761 PUSH TP,IMQUOTE OBLIST
\r
29762 PUSH TP,(AB) ;PUSH ARGS
\r
29764 PUSH TP,[0] ;DUMMY
\r
29766 ADD AB,[2,,2] ;AND ARG POINTER
\r
29767 JUMPGE AB,BINDEM ; ALL DONE, BIND ATOMS
\r
29768 GETYP 0,(AB) ; GET TYPE OF TABLE
\r
29769 CAIE 0,TVEC ; SKIP IF BAD TYPE
\r
29770 JRST WTYP ; ELSE COMPLAIN
\r
29771 PUSH TP,[TATOM,,-1]
\r
29772 PUSH TP,IMQUOTE READ-TABLE
\r
29777 ADD AB,[2,,2] ; BUMP TO NEXT ARG
\r
29778 JUMPL AB,TMA ;MORE ?, ERROR
\r
29779 BINDEM: PUSHJ P,SPECBIND
\r
29782 MFUNCTION RREADC,SUBR,READCHR
\r
29786 JRST READC0 ;GO BIND VARIABLES
\r
29788 MFUNCTION NXTRDC,SUBR,NEXTCHR
\r
29793 READC0: CAMGE AB,[-5,,]
\r
29798 MOVE B,IMQUOTE INCHAN
\r
29805 READC1: PUSHJ P,@(P)
\r
29812 MOVE A,EOFCND-1(B)
\r
29824 MFUNCTION PARSE,SUBR
\r
29828 PUSHJ P,GAPRS ;GET ARGS FOR PARSES
\r
29829 PUSHJ P,GPT ;GET THE PARSE TABLE
\r
29830 PUSHJ P,NXTCH ; GET A CHAR TO TEST FOR ! ALT
\r
29831 SKIPN 11.(TB) ; EOF HIT, COMPLAIN TO LOOSER
\r
29833 MOVEI A,33 ; CHANGE IT TO AN ALT, SNEAKY HUH?
\r
29834 CAIN B,MANYT ; TYPE OF MULTIPLE CLOSE, I.E. ! ALT
\r
29836 PUSHJ P,IREAD1 ;GO DO THE READING
\r
29838 JRST LPSRET ;PROPER EXIT
\r
29839 NOPRS: PUSH TP,$TATOM
\r
29840 PUSH TP,EQUOTE CAN'T-PARSE
\r
29843 MFUNCTION LPARSE,SUBR
\r
29847 PUSHJ P,GAPRS ;GET THE ARGS TO THE PARSE
\r
29850 GAPRS: PUSH TP,$TTP
\r
29855 PUSH TP,[0] ; LETTER SAVE
\r
29857 PUSH TP,[0] ; PARSE TABLE MAYBE?
\r
29859 PUSH TP,[0] ;SEGMENT FOR SPLICING MACROS
\r
29860 PUSH TP,[0] ;SLOT FOR LOCATIVE TO STRING
\r
29863 PUSH TP,[TATOM,,-1]
\r
29864 PUSH TP,IMQUOTE PARSE-STRING
\r
29866 PUSH TP,1(AB) ; BIND OLD PARSE-STRING
\r
29884 PUSH TP,[TATOM,,-1]
\r
29885 PUSH TP,IMQUOTE OBLIST
\r
29887 PUSH TP,1(AB) ; HE WANTS HIS OWN OBLIST
\r
29896 PUSH TP,[TATOM,,-1]
\r
29897 PUSH TP,IMQUOTE PARSE-TABLE
\r
29909 MOVEM 0,5(TB) ; STUFF IN A LOOK-AHEAD CHARACTER IF HE WANTS
\r
29912 USPSTR: MOVE B,IMQUOTE PARSE-STRING
\r
29913 PUSHJ P,ILOC ; GET A LOCATIVE TO THE STRING, WHEREVER
\r
29915 CAIN 0,TUNBOUND ; NONEXISTANT
\r
29917 GETYP 0,(B) ; IT IS POINTING TO A STRING
\r
29924 LPRS1: PUSHJ P,GPT ; GET THE VALUE OF PARSE-TABLE IN SLOT
\r
29926 PUSH TP,[0] ; HERE WE ARE MAKE PLACE TO SAVE GOODIES
\r
29929 LPRS2: PUSHJ P,IREAD1
\r
29930 JRST LPRSDN ; IF WE ARE DONE, WE ARE THROUGH
\r
29935 MOVEM B,-2(TP) ; SAVE THE BEGINNING ON FIRST
\r
29937 HRRM B,(C) ; PUTREST INTO IT
\r
29940 LPRSDN: MOVSI A,TLIST
\r
29942 LPSRET: SKIPLE C,5(TB) ; EXIT FOR PARSE AND LPARSE
\r
29943 CAIN C,400033 ; SEE IF NO PEEK AHEAD OR IF ! ALTMODE
\r
29944 JRST FINIS ; IF SO NO NEED TO BACK STRING ONE
\r
29946 JRST FINIS ; IF ATE WHOLE STRING, DONT GIVE BACK ANY
\r
29948 ADDM D,(C) ; AOS THE COUNT OF STRING LENGTH
\r
29949 SKIPG D,1(C) ; SEXIER THAN CLR'S CODE FOR DECREMENTING
\r
29950 SUB D,[430000,,1] ; A BYTE POINTER
\r
29954 JUMPE E,FINIS ; SEE IF WE NEED TO BACK UP TWO
\r
29955 HLLZS 2(TB) ; CLEAR OUT DOUBLE CHR LOOKY FLAG
\r
29956 JRST BUPRS ; AND BACK UP PARSE STRING A LITTLE MORE
\r
29958 \f; ARGUMENTS ARE BOUND, NOW GET THE VALUES OF THINGS
\r
29961 GRT: MOVE B,IMQUOTE READ-TABLE
\r
29962 SKIPA ; HERE TO GET TABLE FOR READ
\r
29963 GPT: MOVE B,IMQUOTE PARSE-TABLE
\r
29964 MOVSI A,TATOM ; TO FILL SLOT WITH PARSE TABLE
\r
29975 READ1: PUSHJ P,GRT
\r
29976 MOVE B,IMQUOTE INCHAN
\r
29978 PUSHJ P,IDVAL ;NOW GOBBLE THE REAL CHANNEL
\r
29979 TLZ A,TYPMSK#777777
\r
29980 HLLZS A ; INCASE OF FUNNY BUG
\r
29981 CAME A,$TCHAN ;IS IT A CHANNEL
\r
29983 MOVEM A,4(TB) ; STORE CHANNEL
\r
29986 TRC A,C.OPN+C.READ
\r
29987 TRNE A,C.OPN+C.READ
\r
29990 TRNE A,C.BIN ; SKIP IF NOT BIN
\r
29991 JRST BREAD ; CHECK FOR BUFFER
\r
29993 GETIOA: MOVE B,5(TB)
\r
29994 GETIO: MOVE A,IOINS(B) ;GOBBLE THE I/O INSTRUCTION
\r
29995 JUMPE A,OPNFIL ;GO REALLY OPEN THE CROCK
\r
29996 MOVE A,RADX(B) ;GET RADIX
\r
29998 MOVEM B,5(TB) ;SAVE CHANNEL
\r
29999 REREAD: MOVE D,LSTCH(B) ;ANY CHARS AROUND?
\r
30001 CAIN D,400033 ;FLUSH THE TERMINATOR HACK
\r
30002 MOVEM 0,LSTCH(B) ; MAKE ! ALT INTO JUST ALT IF IT IS STILL AROUND
\r
30004 PUSHJ P,@(P) ;CALL INTERNAL READER
\r
30005 JRST BADTRM ;LOST
\r
30006 RFINIS: SUB P,[1,,1] ;POP OFF LOSER
\r
30009 JUMPE C,FLSCOM ; FLUSH TOP LEVEL COMMENT
\r
30013 MOVE B,5(TB) ; GET CHANNEL
\r
30015 MOVE D,MQUOTE COMMENT
\r
30021 FLSCOM: MOVE A,4(TB)
\r
30024 MOVE D,MQUOTE COMMENT
\r
30028 BADTRM: MOVE C,5(TB) ; GET CHANNEL
\r
30029 JUMPGE B,CHLSTC ;NO, MUST BE UNMATCHED PARENS
\r
30030 SETZM LSTCH(C) ; DONT REUSE EOF CHR
\r
30031 PUSH TP,4(TB) ;CLOSE THE CHANNEL
\r
30034 PUSH TP,EOFCND-1(B)
\r
30035 PUSH TP,EOFCND(B)
\r
30036 MCALL 1,EVAL ;AND EVAL IT
\r
30038 GETYP 0,A ; CHECK FOR FUNNY ACT
\r
30040 JRST RFINIS ; AND RETURN
\r
30042 PUSHJ P,CHUNW ; UNWIND TO POINT
\r
30043 MOVSI A,TREADA ; SEND MESSAGE BACK
\r
30046 ;HERE TO ATTEMPT TO OPEN A CLOSED CHANNEL
\r
30048 OPNFIL: PUSHJ P,OPNCHN ;GO DO THE OPEN
\r
30049 JUMPGE B,FNFFL ;LOSE IC B IS 0
\r
30053 CHLSTC: MOVE B,5(TB) ;GET CHANNEL BACK
\r
30057 BREAD: MOVE B,5(TB) ; GET CHANNEL
\r
30060 MOVEI A,BUFLNT ; GET A BUFFER
\r
30062 MOVEI C,BUFLNT(B) ; POINT TO END
\r
30064 MOVE B,5(TB) ; CHANNEL BACK
\r
30067 MOVEM C,BUFSTR(B)
\r
30068 MOVSI C,TCHSTR+.VECT.
\r
30069 MOVEM C,BUFSTR-1(B)
\r
30071 \f;MAIN ENTRY TO READER
\r
30073 NIREAD: PUSHJ P,LSTCHR
\r
30074 NIREA1: PUSH P,[-1] ; DONT GOBBLE COMMENTS
\r
30078 PUSHJ P,LSTCHR ;DON'T REREAD LAST CHARACTER
\r
30079 IREAD1: PUSH P,[0] ; FLAG SAYING SNARF COMMENTS
\r
30081 BDLP: SKIPE C,9.(TB) ;HAVE WE GOT A SPLICING MACRO LEFT
\r
30082 JRST SPLMAC ;IF SO GIVE HIM SOME OF IT
\r
30083 PUSHJ P,NXTCH ;GOBBLE CHAR IN A AND TYPE IN D
\r
30084 MOVMS B ; FOR SPECIAL NEG HACK OF MACRO TABLES
\r
30086 JUMPN B,@DTBL-1(B) ;ERROR ON ZERO TYPE OR FUNNY TYPE
\r
30090 SPLMAC: HRRZ D,(C) ;GET THE REST OF THE SEGMENT
\r
30091 MOVEM D,9.(TB) ;AND PUT BACK IN PLACE
\r
30092 GETYP D,(C) ;SEE IF DEFERMENT NEEDED
\r
30094 MOVE C,1(C) ;IF SO, DO DEFEREMENT
\r
30096 MOVE B,1(C) ;GET THE GOODIE
\r
30097 AOS -1(P) ;ALWAYS A SKIP RETURN
\r
30098 POP P,(P) ;DONT WORRY ABOUT COMMENT SEARCHAGE
\r
30099 SETZB C,D ;MAKE SURE HE DOESNT THINK WE GOT COMMENT
\r
30100 POPJ P, ;GIVE HIM WHAT HE DESERVES
\r
30102 DTBL: NUMLET ;HERE IF NUMBER OR LETTER
\r
30110 NONSPC==.-DTBL ;NUMBER OF NON-SPECIAL CHARACTERS
\r
30111 SPACE ;SPACING CHAR CR,LF,SP,TAB ETC.
\r
30112 SPATYP==.-DTBL ;TYPE FOR SPACE CHARS
\r
30115 ;THE FOLLOWING ENTRIES ARE VARIOUS PUNCTUATION CROCKS
\r
30117 LPAREN ;( - BEGIN LIST
\r
30118 RPAREN ;) - END CURRENT LEVEL OF INPUT
\r
30119 LBRACK ;[ -BEGIN ARRAY
\r
30121 RBRACK ;] - END OF ARRAY
\r
30122 QUOTIT ;' - QUOTE THE FOLLOWING GOODIE
\r
30125 MACCAL ;% - INVOKE A READ TIME MACRO
\r
30127 CSTRING ;" - CHARACTER STRING
\r
30129 NUMLET ;\ - ESCAPE,BEGIN ATOM
\r
30131 ESCTYP==.-DTBL ;TYPE OF ESCAPE CHARACTER
\r
30133 SPECTY ;# - SPECIAL TYPE TO BE READ
\r
30135 OPNANG ;< - BEGIN ELEMENT CALL
\r
30137 SLMNT==.-DTBL ;TYPE OF START OF SEGMENT
\r
30139 CLSANG ;> - END ELEMENT CALL
\r
30142 EOFCHR ;^C - END OF FILE
\r
30144 COMNT ;; - BEGIN COMMENT
\r
30145 COMTYP==.-DTBL ;TYPE OF START OF COMMENT
\r
30147 GLOVAL ;, - GET GLOBAL VALUE
\r
30149 ILLSQG ;{ - START TEMPLATE STRUCTURE
\r
30151 CLSBRA ;} - END TEMPLATE STRUCTURE
\r
30157 ; EXTENDED TABLE FOR ! HACKS
\r
30159 NUMLET ; !! FAKE OUT
\r
30160 SEGDOT ;!. - CALL TO LVAL (SEG)
\r
30162 UVECIN ;![ - INPUT UNIFORM VECTOR ]
\r
30164 QUOSEG ;!' - SEG CALL TO QUOTE
\r
30166 SINCHR ;!" - INPUT ONE CHARACTER
\r
30168 SEGIN ;!< - SEG CALL
\r
30170 GLOSEG ;!, - SEG CALL TO GVAL
\r
30172 LOSPATH ;!- - PATH NAME SEPARATOR
\r
30174 TERM ;!$ - (EXCAL-ALT MODE) PUT ALL CLOSES
\r
30176 USRDS1 ; DISPATCH FOR USER TABLE (NO !)
\r
30178 USRDS2 ; " " " " (WITH !)
\r
30184 SPACE: PUSHJ P,LSTCHR ;DONT REREAD SPACER
\r
30187 USRDS1: SKIPA B,A ; GET CHAR IN B
\r
30188 USRDS2: MOVEI B,200(A) ; ! CHAR, DISP 200 FURTHER
\r
30190 ADD B,7(TB) ; POINT TO TABLE ENTRY
\r
30193 MOVE B,1(B) ; IF LIST, USE FIRST ITEM-SPECIAL NO BREAK HACK
\r
30194 SKIPL C,5(TB) ; GET CHANNEL POINTER (IF ANY)
\r
30196 ADD C,[EOFCND-1,,EOFCND-1]
\r
30198 HRRM SP,(TP) ; BUILD A TBVL
\r
30203 MOVEI D,PVLNT*2+1(PVP)
\r
30209 USRDS3: PUSH TP,(B) ; APPLIER
\r
30211 PUSH TP,$TCHRS ; APPLY TO CHARACTER
\r
30213 PUSHJ P,LSTCHR ; FLUSH CHAR
\r
30214 MCALL 2,APPLY ; GO TO USER GOODIE
\r
30215 HRRZ SP,(SP) ; UNBIND MANUALLY
\r
30221 SUB TP,[4,,4] ; FLUSH TP CRAP
\r
30222 GETYP 0,A ; CHECK FOR DISMISS?
\r
30224 JRST GOTSPL ; RETURN OF SEGMENT INDICATES SPLICAGE
\r
30225 CAIN 0,TREADA ; FUNNY?
\r
30228 JRST RET ; NO, RETURN FROM IREAD
\r
30229 JRST BDLP ; YES, IGNORE RETURN
\r
30231 GOTSPL: MOVEM B,9.(TB) ; STICK IN THE SPLICAGE SLOT SO IREADS WILL GET HIM
\r
30232 JRST BDLP ; GO BACK AND READ FROM OUR SPLICE, OK?
\r
30235 ;HERE ON NUMBER OR LETTER, START ATOM
\r
30237 NUMLET: PUSHJ P,GOBBLE ;READ IN THE ATOM AND PUT PNTR ON ARG PDL
\r
30238 JRST RET ;NO SKIP RETURN I.E. NON NIL
\r
30240 ;HERE TO START BUILDING A CHARACTER STRING GOODIE
\r
30242 CSTRING: PUSHJ P,GOBBL1 ;READ IN STRING
\r
30245 ;ARRIVE HERE TO INVOKE A READ TIME MACRO FUNCTION
\r
30247 MACCAL: PUSHJ P,NXTCH1 ;READ ONE MORE CHARACTER
\r
30248 CAIE B,MACTYP ;IS IT ANOTHER MACRO CHAR
\r
30250 JRST MACAL2 ;NO, CALL MACRO AND USE VALUE
\r
30251 PUSHJ P,LSTCHR ;DONT REREAD %
\r
30252 PUSHJ P,MACAL1 ;OTHERWISE, USE SIDE EFFECCT, BUT NOT VALUE
\r
30255 MACAL2: PUSH P,CRET
\r
30256 MACAL1: PUSHJ P,IREAD1 ;READ FUNCTION NAME
\r
30259 PUSH TP,D ; SAVE COMMENT IF ANY
\r
30260 PUSH TP,A ;SAVE THE RESULT
\r
30261 PUSH TP,B ;AND USE IT AS AN ARGUMENT
\r
30264 POP TP,C ; RESTORE COMMENT IF ANY...
\r
30265 CRET: POPJ P,RET12
\r
30267 ;CALL GOBBLE TO FIND THE TYPE AND THEN IREAD TO READ IT
\r
30269 SPECTY: PUSHJ P,NIREAD ; READ THE TYPES NAME (SHOULD BE AN ATOM)
\r
30273 PUSHJ P,NXTCH ; GET NEXT CHAR
\r
30274 CAIN B,TMPTYP ; SKIP IF NOT TEMPLATE START
\r
30279 PUSH TP,A ;BEGIN SETTING UP CHTYPE CALL
\r
30281 PUSHJ P,IREAD1 ;NOW READ STRUCTURE
\r
30283 MOVEM C,-3(TP) ; SAVE COMMENT
\r
30285 EXCH A,-1(TP) ;USE AS FIRST ARG
\r
30287 PUSH TP,A ;USE OTHER AS 2D ARG
\r
30289 MCALL 2,CHTYPE ;ATTEMPT TO MUNG
\r
30291 POP TP,C ; RESTORE COMMENT
\r
30292 RET12: SETOM (P) ; DONT LOOOK FOR MORE!
\r
30295 RDTMPL: PUSH P,["}] ; SET UP TERMINATE TEST
\r
30300 PUSH P,[BLDTMP] ; FLAG FOR VECTOR READING CODE
\r
30303 BLDTMP: ADDI A,1 ; 1 MORE ARGUMENT
\r
30304 ACALL A,APPLY ; DO IT TO IT
\r
30307 RETER1: SUB TP,[2,,2]
\r
30308 RETERR: SKIPL A,5(TB)
\r
30309 MOVEI A,5(TB)-LSTCH ;NO CHANNEL, USE SLOT
\r
30310 MOVEM B,LSTCH(A) ; RESTORE LAST CHAR
\r
30314 ;THIS CODE CALLS IREAD RECURSIVELY TO READ THAT WHICH IS
\r
30315 ;BETWEEN (), ARRIVED AT WHEN ( IS READ
\r
30317 SEGIN: PUSH TP,$TSEG
\r
30320 OPNANG: PUSH TP,$TFORM ;SAVE TYPE
\r
30321 OPNAN1: PUSH P,[">]
\r
30324 LPAREN: PUSH P,[")]
\r
30325 PUSH TP,$TLIST ;START BY ASSUMING NIL
\r
30326 LPARN1: PUSH TP,[0]
\r
30327 PUSHJ P,LSTCHR ;DON'T REREAD PARENS
\r
30328 LLPLOP: PUSHJ P,IREAD1 ;READ IT
\r
30329 JRST LDONE ;HIT TERMINATOR
\r
30331 ;HERE WHEN MUST ADD CAR TO CURRENT WINNER
\r
30333 GENCAR: PUSH TP,C ; SAVE COMMENT
\r
30335 MOVE C,A ; SET UP CALL
\r
30337 PUSHJ P,INCONS ; CONS ON TO NIL
\r
30340 POP TP,E ;GET CDR
\r
30341 JUMPN E,CDRIN ;IF STACKED GOODIE NOT NIL SKIP
\r
30342 PUSH TP,B ;AND USE AS TOTAL VALUE
\r
30343 PUSH TP,$TLIST ;SAVE THIS AS FIRSST THING ON LIST
\r
30344 MOVE A,-2(TP) ; GET REAL TYPE
\r
30345 JRST .+2 ;SKIP CDR SETTING
\r
30346 CDRIN: HRRM B,(E)
\r
30347 PUSH TP,B ;CLOBBER IN NEW PARTIAL GOODIE
\r
30348 JUMPE C,LLPLOP ; JUMP IF NO COMMENT
\r
30352 MOVE D,MQUOTE COMMENT
\r
30354 JRST LLPLOP ;AND CONTINUE
\r
30356 ; HERE TO RAP UP LIST
\r
30358 LDONE: CAME B,(P) ;CHECK VALIDITY OF CHARACTER
\r
30359 PUSHJ P,MISMAT ;REPORT MISMATCH
\r
30361 POP TP,B ;GET VALUE OF PARTIAL RESULT
\r
30362 POP TP,A ;AND TYPE OF SAME
\r
30363 JUMPE B,RET ;VALUE IS NIL, DON'T POP AGAIN
\r
30364 POP TP,B ;POP FIRST LIST ELEMENT
\r
30365 POP TP,A ;AND TYPE
\r
30368 ;THIS CODE IS SIMILAR TO LIST GENERATING CODE BUT IS FOR VECTORS
\r
30369 OPNBRA: PUSH P,["}] ; SAVE TERMINATOR
\r
30370 UVECIN: PUSH P,[135] ; CLOSE SQUARE BRACKET
\r
30371 PUSH P,[IEUVECTOR] ;PUSH NAME OF U VECT HACKER
\r
30372 JRST LBRAK2 ;AND GO
\r
30374 LBRACK: PUSH P,[135] ; SAVE TERMINATE
\r
30375 PUSH P,[IEVECTOR] ;PUSH GEN VECTOR HACKER
\r
30376 LBRAK2: PUSHJ P,LSTCHR ;FORCE READING NEW CHAR
\r
30377 PUSH P,[0] ; COUNT ELEMENTS
\r
30378 PUSH TP,$TLIST ; AND SLOT FOR GOODIES
\r
30381 LBRAK1: PUSHJ P,IREAD1 ;RECURSIVELY READ ELEMENTS OF ARRAY
\r
30382 JRST LBDONE ;RAP UP ON TERMINATOR
\r
30384 STAKIT: EXCH A,-1(TP) ; STORE RESULT AND GET CURRENT LIST
\r
30386 AOS (P) ; COUNT ELEMENTS
\r
30387 JUMPE C,LBRAK3 ; IF NO COMMENT, GO ON
\r
30388 MOVEI E,(B) ; GET CDR
\r
30389 PUSHJ P,ICONS ; CONS IT ON
\r
30390 MOVEI E,(B) ; SAVE RS
\r
30391 MOVSI C,TFIX ; AND GET FIXED NUM
\r
30394 LBRAK3: PUSH TP,A ; SAVE CURRENT COMMENT LIST
\r
30398 ; HERE TO RAP UP VECTOR
\r
30400 LBDONE: CAME B,-2(P) ; FINISHED RETURN (WAS THE RIGHT STOP USED?)
\r
30401 PUSHJ P,MISMAB ; WARN USER
\r
30402 POP TP,1(TB) ; REMOVE COMMENT LIST
\r
30404 MOVE A,(P) ; COUNT TO A
\r
30405 PUSHJ P,-1@(P) ; MAKE THE VECTOR
\r
30408 ; PUT COMMENTS ON VECTOR (OR UVECTOR)
\r
30410 MOVNI C,1 ; INDICATE TEMPLATE HACK
\r
30413 CAMN A,$TUVEC ; SKIP IF UVECTOR
\r
30416 PUSH TP,A ; SAVE VECTOR/UVECTOR
\r
30419 VECCOM: SKIPN C,1(TB) ; ANY LEFT?
\r
30420 JRST RETVEC ; NO, LEAVE
\r
30421 MOVE A,1(C) ; ASSUME WINNING TYPES
\r
30423 HRRZ C,(C) ; CDR THE LIST
\r
30424 HRRZ E,(C) ; AGAIN
\r
30425 MOVEM E,1(TB) ; SAVE CDR
\r
30426 GETYP E,(C) ; CHECK DEFFERED
\r
30428 CAIN E,TDEFER ; SKIP IF NOT DEFERRED
\r
30431 GETYPF D,(C) ; GET REAL TYPE
\r
30432 MOVE B,(TP) ; GET VECTOR POINTER
\r
30433 SKIPGE (P) ; SKIP IF NOT TEMPLATE
\r
30435 HRLI A,(A) ; COUNTER
\r
30436 LSH A,@(P) ; MAYBE SHIFT IT
\r
30438 MOVE A,-1(TP) ; TYPE
\r
30439 TMPCO1: PUSH TP,D
\r
30440 PUSH TP,1(C) ; PUSH THE COMMENT
\r
30442 MOVE D,MQUOTE COMMENT
\r
30446 TMPCOM: MOVSI A,(A)
\r
30451 RETVEC: SUB P,[1,,1]
\r
30456 ; BUILD A SINGLE CHARACTER ITEM
\r
30458 SINCHR: PUSHJ P,NXTC1 ;FORCE READ NEXT
\r
30459 CAIN B,ESCTYP ;ESCAPE?
\r
30460 PUSHJ P,NXTC1 ;RETRY
\r
30466 ; HERE ON RIGHT PAREN, BRACKET, ANGLE BRACKET OR CTL C
\r
30469 CLSANG: ;CLOSE ANGLE BRACKETS
\r
30470 RBRACK: ;COMMON RETURN FOR END OF ARRAY ALSO
\r
30471 RPAREN: PUSHJ P,LSTCHR ;DON'T REREAD
\r
30472 EOFCH1: MOVE B,A ;GETCHAR IN B
\r
30473 MOVSI A,TCHRS ;AND TYPE IN A
\r
30474 RET1: SUB P,[1,,1]
\r
30477 EOFCHR: SETZB C,D
\r
30478 JUMPL A,EOFCH1 ; JUMP ON REAL EOF
\r
30479 JRST RRSUBR ; MAYBE A BINARY RSUBR
\r
30481 DOEOF: MOVE A,[-1,,3]
\r
30486 ; NORMAL RETURN FROM IREAD/IREAD1
\r
30488 RETCL: PUSHJ P,LSTCHR ;DONT REREAD
\r
30489 RET: AOS -1(P) ;SKIP
\r
30490 POP P,E ; POP FLAG
\r
30491 RETC: JUMPL E,RET2 ; DONT LOOK FOR COMMENTS
\r
30492 PUSH TP,A ; SAVE ITEM
\r
30494 CHCOMN: PUSHJ P,NXTCH ; READ A CHARACTER
\r
30495 CAIE B,COMTYP ; SKIP IF COMMENT
\r
30497 PUSHJ P,IREAD ; READ THE COMMENT
\r
30507 CHSPA: CAIN B,SPATYP
\r
30508 PUSHJ P,SPACEQ ; IS IT A REAL SPACE
\r
30510 PUSHJ P,LSTCHR ; FLUSH THE SPACE
\r
30513 ;RANDOM MINI-SUBROUTINES USED BY THE READER
\r
30515 ;READ A CHAR INTO A AND TYPE CODE INTO D
\r
30517 NXTC1: SKIPL B,5(TB) ;GET CHANNEL
\r
30518 JRST NXTPR1 ;NO CHANNEL, GO READ STRING
\r
30520 PUSHJ P,CNTACC ; COUNT ON ACCESS POINTER
\r
30522 NXTC: SKIPL B,5(TB) ;GET CHANNEL
\r
30523 JRST NXTPRS ;NO CHANNEL, GO READ STRING
\r
30524 SKIPE A,LSTCH(B) ;CHAR IN A IF REUSE
\r
30526 NXTC2: PUSHJ P,RXCT ;GET CHAR FROM INPUT
\r
30527 HLLZS 2(TB) ;FLAG INDICATING ONE CHAR LOOK AHEAD
\r
30528 MOVEM A,LSTCH(B) ;SAVE THE CHARACTER
\r
30529 PRSRET: TRZE A,400000 ;DONT SKIP IF SPECIAL
\r
30530 JRST RETYPE ;GO HACK SPECIALLY
\r
30531 GETCTP: CAILE A,177 ; CHECK RANGE
\r
30533 PUSH P,A ;AND SAVE FROM DIVISION
\r
30535 IDIVI A,CHRWD ;YIELDS WORD AND CHAR NUMBER
\r
30536 LDB B,BYTPNT(B) ;GOBBLE TYPE CODE
\r
30540 NXTPRS: SKIPE A,5(TB) ;GET OLD CHARACTER IF ONE EXISTS
\r
30542 NXTPR1: MOVEI A,400033
\r
30545 HRRZ B,(C) ;GET THE STRING
\r
30548 ILDB A,1(C) ;GET THE CHARACTER FROM THE STRING
\r
30549 NXTPR2: MOVEM A,5(TB) ;SAVE IT
\r
30551 JRST PRSRET ;CONTINUE
\r
30552 NXTPR3: SETZM 8.(TB)
\r
30553 SETZM 9.(TB) ;CLEAR OUT LOCATIVE, AT END OF STRING
\r
30556 ; NXTCH AND NXTCH1 ARE SAME AS NXTC AND NXTC1 EXCEPT THEY CHECK !
\r
30559 NXTCH1: PUSHJ P,NXTC1 ;READ CHAR
\r
30561 NXTCH: PUSHJ P,NXTC ;READ CHAR
\r
30562 CAIGE B,NTYPES+1 ;IF 1 > THAN MAX, MUST BE SPECIAL
\r
30563 JRST CHKUS1 ; CHECK FOR USER DISPATCH
\r
30565 CAIN B,NTYPES+1 ;FOR OBSCURE BUG FOUND BY MSG
\r
30566 PUSHJ P,NXTC1 ;READ NEXT ONE
\r
30567 HLLOS 2(TB) ;FLAG FOR TWO CHAR LOOK AHEAD
\r
30569 RETYP1: CAIN A,". ;!.
\r
30570 MOVEI B,DOTEXT ;YES, GET EXTENDED TYPE
\r
30584 MOVEI B,MANYT ;! ALTMODE
\r
30586 CRMLST: ADDI A,400000 ;CLOBBER LASTCHR
\r
30588 SKIPL B,5(TB) ;POINT TO CHANNEL
\r
30589 MOVEI B,5(TB)-LSTCH ;NO CHANNEL, POINT AT SLOT
\r
30591 SUBI A,400000 ;DECREASE CHAR
\r
30594 CHKUS2: SKIPN 7(TB) ; SKIP IF USER TABLE
\r
30598 ASH A,1 ; POINT TO SLOT
\r
30601 SKIPL A ;IS THERE VECTOR ENOUGH?
\r
30603 SKIPN 1(A) ; NON-ZERO==>USER FCN EXISTS
\r
30604 JRST CHKUS4 ; HOPE HE APPRECIATES THIS
\r
30606 CHKRDO: PUSH P,0 ; CHECK FOR REDOING IF CHAR IN TABLE
\r
30610 POP P,0 ;WE ARE TRANSMOGRIFYING
\r
30611 POP P,(P) ;FLUSH OLD CHAR
\r
30612 MOVE A,1(A) ;GET NEW CHARACTER
\r
30614 PUSH P,2(TB) ; FLAGS FOR NUM OF CHRS IN LOOK AHEAD
\r
30615 PUSH P,5(TB) ; TO AVOID SMASHING LSTCHR
\r
30616 SETZM 5(TB) ; CLEAR OUT CHANNEL
\r
30617 SETZM 7(TB) ;CLEAR OUT TABLE
\r
30618 TRZE A,200 ; ! HACK
\r
30619 TRO A,400000 ; TURN ON PROPER BIT
\r
30621 POP P,5(TB) ; GET BACK CHANNEL
\r
30623 POP P,7(TB) ;GET BACK OLD PARSE TABLE
\r
30626 CHKUS5: CAIE 0,TLIST
\r
30627 JRST .+4 ; SPECIAL NON-BREAK TYPE HACK
\r
30628 MOVNS -1(P) ; INDICATE BY NEGATIVE
\r
30629 MOVE A,1(A) ; GET <1 LIST>
\r
30630 GETYP 0,(A) ; AND GET THE TYPE OF THAT
\r
30631 CAIE 0,TFIX ; SEE IF HE WANTS SAME CHAR WITH DIFF TYPE
\r
30632 JRST CHKUS6 ; JUST A VANILLA HACK
\r
30633 MOVE A,1(A) ; PRETEND IT IS SAME TYPE AS NEW CHAR
\r
30634 PUSH P,7(TB) ; CLEAR OUT TRANSLATE TABLE
\r
30635 PUSH P,2(TB) ; FLAGS FOR # OF CHRS IN LOOK AHEAD
\r
30638 TRO A,400000 ; TURN ON PROPER BIT IF ! HACK
\r
30639 PUSHJ P,PRSRET ; REGET TYPE
\r
30641 POP P,7(TB) ; PUT TRANSLATE TABLE BACK
\r
30642 CHKUS6: SKIPGE -1(P) ; SEE IF A SPECIAL NON-BREAK
\r
30643 MOVNS B ; SEXY, HUH?
\r
30646 MOVMS A ; FIX UP A POSITIVE CHARACTER
\r
30652 CHKUS1: SKIPN 7(TB) ; USER CHECK FOR NOT ! CASE
\r
30663 JRST CHKRDO ; TRANSMOGRIFY CHARACTER?
\r
30668 UPLO: POPJ P, ; LETS NOT AND SAY WE USED TO
\r
30669 ; AVOID STRANGE ! BLECHAGE
\r
30671 RETYPE: PUSHJ P,GETCTP ;GET TYPE OF CHAR
\r
30674 NXTCS: PUSHJ P,NXTC
\r
30675 PUSH P,A ; HACK TO NOT TRANSLATE CHAR
\r
30676 PUSHJ P,CHKUS1 ; BUT DO TRANSLATION OF TYPE IF HE WANTS
\r
30677 POP P,A ; USED TO BUILD UP STRINGS
\r
30680 CHKALT: CAIN A,33 ;ALT?
\r
30685 TERM: MOVEI B,0 ;RETURN A 0
\r
30689 CHKMIN: CAIN A,"- ; IF CHAR IS -, WINNER
\r
30693 LOSPAT: PUSHJ P,LSTCHR ; FIX RECURSIVE LOSAGE
\r
30695 PUSH TP,EQUOTE UNATTACHED-PATH-NAME-SEPARATOR
\r
30699 ; HERE TO SEE IF READING RSUBR
\r
30701 RRSUBR: PUSHJ P,LSTCHR ; FLUSH JUST READ CHAR
\r
30702 SKIPL B,5(TB) ; SKIP IF A CHANNEL EXISTS
\r
30703 JRST SPACE ; ELSE LIKE A SPACE
\r
30704 MOVE C,@BUFSTR(B) ; SEE IF FLAG SAYS START OF RSUBR
\r
30705 TRNN C,1 ; SKIP IF REAL RSUBR
\r
30706 JRST SPACE ; NO, IGNORE FOR NOW
\r
30708 ; REALLY ARE READING AN RSUBR
\r
30710 HRRZ 0,4(TB) ; GET READ/READB INDICATOR
\r
30711 MOVE C,ACCESS(B) ; GET CURRENT ACCESS
\r
30712 JUMPN 0,.+3 ; ALREADY WORDS, NO NEED TO DIVIDE
\r
30713 ADDI C,4 ; ROUND UP
\r
30715 PUSH P,C ; SAVE WORD ACCESS
\r
30716 MOVEI A,(C) ; COPY IT FOR CALL
\r
30719 MOVEM C,ACCESS(B) ; FIXUP ACCESS
\r
30720 HLLZS ACCESS-1(B) ; FOR READB LOSER
\r
30721 PUSHJ P,DOACCS ; AND GO THERE
\r
30722 PUSH P,[0] ; FOR READ IN
\r
30723 HRROI A,(P) ; PREPARE TO READ LENGTH
\r
30724 PUSHJ P,DOIOTI ; READ IT
\r
30725 POP P,C ; GET READ GOODIE
\r
30726 MOVEI A,(C) ; COPY FOR GETTING BLOCK
\r
30727 ADDI C,1 ; COUNT COUNT WORD
\r
30729 PUSH TP,$TUVEC ; WILL HOLD UVECTOR OF FIXUPS IF THEY STAY
\r
30731 PUSHJ P,IBLOCK ; GET A BLOCK
\r
30733 PUSH TP,B ; AND SAVE
\r
30734 MOVE A,B ; READY TO IOT IT IN
\r
30735 MOVE B,5(TB) ; GET CHANNEL BACK
\r
30736 MOVSI 0,TUVEC ; SETUP A'S TYPE
\r
30737 MOVEM 0,ASTO(PVP)
\r
30738 PUSHJ P,DOIOTI ; IN COMES THE WHOLE BLOCK
\r
30739 SETZM ASTO(PVP) ; A NO LONGER SPECIAL
\r
30740 MOVEI C,BUFSTR-1(B) ; NO RESET BUFFER
\r
30741 PUSHJ P,BYTDOP ; A POINTS TO DOPW WORD
\r
30743 HRLI A,010700 ; SETUP BYTE POINTER TO END
\r
30744 HLLZS BUFSTR-1(B) ; ZERO CHAR COUNNT
\r
30745 MOVEM A,BUFSTR(B)
\r
30746 HRRZ A,4(TB) ; READ/READB FLG
\r
30747 MOVE C,(P) ; ACCESS IN WORDS
\r
30748 SKIPN A ; SKIP FOR ASCII
\r
30750 MOVEM C,ACCESS(B) ; UPDATE ACCESS
\r
30751 PUSHJ P,NIREAD ; READ RSUBR VECTOR
\r
30752 JRST BRSUBR ; LOSER
\r
30753 GETYP A,A ; VERIFY A LITTLE
\r
30754 CAIE A,TVEC ; DONT SKIP IF BAD
\r
30755 JRST BRSUBR ; NOT A GOOD FILE
\r
30756 PUSHJ P,LSTCHR ; FLUSH REREAD CHAR
\r
30757 MOVE C,(TP) ; CODE VECTOR BACK
\r
30759 HLR A,B ; FUNNY COUNT
\r
30760 MOVEM A,(B) ; CLOBBER
\r
30762 PUSH TP,$TRSUBR ; MAKE RSUBR
\r
30765 ; NOW LOOK OVER FIXUPS
\r
30767 MOVE B,5(TB) ; GET CHANNEL
\r
30769 HLLZS ACCESS-1(B) ; FOR READB LOSER
\r
30770 HRRZ 0,4(TB) ; READ/READB FLG
\r
30772 ADDI C,4 ; ROUND UP
\r
30773 IDIVI C,5 ; TO WORDS
\r
30774 MOVEI D,(C) ; FIXUP ACCESS
\r
30776 MOVEM D,ACCESS(B) ; AND STORE
\r
30777 RSUB1: ADDI C,1 ; ACCOUNT FOR EXTRA COUNTERS
\r
30778 MOVEM C,(P) ; SAVE FOR LATER
\r
30779 MOVEI A,-1(C) ; FOR DOACS
\r
30780 MOVEI C,2 ; UPDATE REAL ACCESS
\r
30781 SKIPN 0 ; SKIP FOR READB CASE
\r
30784 PUSHJ P,DOACCS ; DO THE ACCESS
\r
30785 PUSH TP,$TUVEC ; SLOT FOR FIXUP BUFFER
\r
30788 ; FOUND OUT IF FIXUPS STAY
\r
30790 MOVE B,MQUOTE KEEP-FIXUPS
\r
30791 PUSHJ P,ILVAL ; GET VALUE
\r
30793 MOVE B,5(TB) ; CHANNEL BACK TO B
\r
30796 JRST RSUB4 ; NO, NOT KEEPING FIXUPS
\r
30797 PUSH P,[0] ; SLOT TO READ INTO
\r
30798 HRROI A,(P) ; GET LENGTH OF SAME
\r
30801 MOVEI A,(C) ; GET UVECTOR FOR KEEPING
\r
30802 ADDM C,(P) ; ACCESS TO END
\r
30803 PUSH P,C ; SAVE LENGTH OF FIXUPS
\r
30805 MOVEM B,-6(TP) ; AND SAVE
\r
30806 MOVE A,B ; FOR IOTING THEM IN
\r
30807 ADD B,[1,,1] ; POINT PAST VERS #
\r
30810 MOVEM C,ASTO(PVP)
\r
30811 MOVE B,5(TB) ; AND CHANNEL
\r
30812 PUSHJ P,DOIOTI ; GET THEM
\r
30814 MOVE A,(TP) ; GET VERS
\r
30815 PUSH P,-1(A) ; AND PUSH IT
\r
30818 RSUB4: PUSH P,[0]
\r
30819 PUSH P,[0] ; 2 SLOTS FOR READING
\r
30825 ADDM C,-2(P) ; NOW -2(P) IS ACCESS TO END OF FIXUPS
\r
30826 RSUB5: MOVEI C,BUFSTR-1(B) ; FIXUP BUFFER
\r
30828 SUBI A,2 ; POINT BEFORE D.W.
\r
30830 MOVEM A,BUFSTR(B)
\r
30831 HLLZS BUFSTR-1(B)
\r
30834 SUBI A,BUFLNT-1 ; ALSO MAKE AN IOT FLAVOR BUFFER
\r
30838 MOVEM C,ASTO(PVP)
\r
30841 RSUB2A: PUSH P,-1(P) ; ANOTHER COPY OF LENGTH OF FIXUPS
\r
30843 ; LOOP FIXING UP NEW TYPES
\r
30845 RSUB2: PUSHJ P,WRDIN ; SEE WHAT NEXT THING IS
\r
30846 JRST RSUB3 ; NO MORE, DONE
\r
30847 JUMPL E,STSQ ; MUST BE FIRST SQUOZE
\r
30848 MOVNI 0,(E) ; TO UPDATE AMNT OF FIXUPS
\r
30850 HRLI E,(E) ; IS LENGTH OF STRING IN WORDS
\r
30851 ADD E,(TP) ; FIXUP BUFFER POINTER
\r
30853 SUB E,[BUFLNT,,BUFLNT]
\r
30854 JUMPGE E,.-1 ; STILL NOT RIGHT
\r
30855 EXCH E,(TP) ; FIX UP SLOT
\r
30856 HLRE C,E ; FIX BYTE POINTER ALSO
\r
30857 IMUL C,[-5] ; + CHARS LEFT
\r
30858 MOVE B,5(TB) ; CHANNEL
\r
30859 PUSH TP,BUFSTR-1(B)
\r
30860 PUSH TP,BUFSTR(B)
\r
30861 HRRM C,BUFSTR-1(B)
\r
30862 HRLI E,440700 ; AND BYTE POINTER
\r
30863 MOVEM E,BUFSTR(B)
\r
30864 PUSHJ P,NIREAD ; READ ATOM NAME OF TYPE
\r
30865 TDZA 0,0 ; FLAG LOSSAGE
\r
30866 MOVEI 0,1 ; WINNAGE
\r
30867 MOVE C,5(TB) ; RESET BUFFER
\r
30869 POP TP,BUFSTR-1(C)
\r
30870 JUMPE 0,BRSUBR ; BAD READ OF RSUBR
\r
30871 GETYP A,A ; A LITTLE CHECKING
\r
30874 PUSHJ P,LSTCHR ; FLUSH REREAD CHAR
\r
30875 HRRZ 0,4(TB) ; FIXUP ACCESS PNTR
\r
30878 HLLZS ACCESS-1(C) ; FOR READB HACKER
\r
30883 MOVEM D,ACCESS(C) ; RESET
\r
30884 TYFIXE: PUSHJ P,TYPFND ; SEE IF A LEGAL TYPE NAME
\r
30885 JRST TYPFIX ; GO SEE USER ABOUT THIS
\r
30886 PUSHJ P,FIXCOD ; GO FIX UP THE CODE
\r
30889 ; NOW FIX UP SUBRS ETC. IF NECESSARY
\r
30891 STSQ: MOVE B,MQUOTE MUDDLE
\r
30892 PUSHJ P,IGVAL ; GET CURRENT VERS
\r
30893 CAME B,-1(P) ; SKIP IF NO FIXUPS NEEDED
\r
30894 JRST DOFIX0 ; MUST DO THEM
\r
30896 ; ALL DONE, ACCESS PAST FIXUPS AND RETURN
\r
30898 RSUB3: MOVE A,-3(P)
\r
30900 MOVEI C,(A) ; UPDATE CHANNEL ACCESS IN CASE SKIPPING
\r
30901 HRRZ 0,4(TB) ; READ/READB FLAG
\r
30904 MOVEM C,ACCESS(B) ; INTO ACCESS SLOT
\r
30905 HLLZS ACCESS-1(B)
\r
30906 PUSHJ P,DOACCS ; ACCESSED
\r
30907 MOVEI C,BUFSTR-1(B) ; FIX UP BUFFER
\r
30911 MOVEM A,BUFSTR(B)
\r
30912 HLLZS BUFSTR-1(B)
\r
30913 SKIPN A,-6(TP) ; SKIP IF KEEPING FIXUPS
\r
30920 MOVE D,MQUOTE RSUBR
\r
30921 PUSHJ P,IPUT ; DO THE ASSOCIATION
\r
30923 RSUB6: MOVE B,-2(TP) ; GET RSUBR
\r
30925 SUB P,[4,,4] ; FLUSH P CRUFT
\r
30929 ; FIXUP SUBRS ETC.
\r
30931 DOFIX0: SKIPN C,-6(TP) ; GET BUFFER IF KEEPING
\r
30933 MOVEM B,(C) ; CLOBBER
\r
30936 FIXUPL: PUSHJ P,WRDIN
\r
30938 DOFIXE: JUMPGE E,BRSUBR
\r
30939 TLZ E,740000 ; KILL BITS
\r
30940 PUSHJ P,SQUTOA ; LOOK IT UP
\r
30942 MOVEI D,(E) ; FOR FIXCOD
\r
30943 PUSHJ P,FIXCOD ; FIX 'EM UP
\r
30946 ; ROUTINE TO FIXUP ACTUAL CODE
\r
30948 FIXCOD: MOVEI E,0 ; FOR HWRDIN
\r
30949 PUSH P,D ; NEW VALUE
\r
30950 PUSHJ P,HWRDIN ; GET HW NEEDED
\r
30951 MOVE D,(P) ; GET NEW VAL
\r
30952 MOVE A,(TP) ; AND BUFFER POINTER
\r
30953 SKIPE -6(TP) ; SAVING?
\r
30954 HRLM D,-1(A) ; YES, CLOBBER
\r
30955 SUB C,(P) ; DIFFERENCE
\r
30958 FIXLP: PUSHJ P,HWRDIN ; GET AN OFFSET
\r
30960 HRRES C ; MAKE NEG IF NEC
\r
30962 ADD C,-4(TP) ; POINT INTO CODE
\r
30972 FIXED: SUB P,[1,,1]
\r
30975 ; ROUTINE TO READ A WORD FROM BUFFER
\r
30979 SOSG -3(P) ; COUNT IT DOWN
\r
30981 AOS -2(P) ; SKIP RETURN
\r
30982 MOVE B,5(TB) ; CHANNEL
\r
30983 HRRZ A,4(TB) ; READ/READB SW
\r
30988 MOVE A,(TP) ; BUFFER
\r
30990 AOBJP A,WRDIN2 ; NEED NEW BUFFER
\r
30996 WRDIN2: MOVE B,-3(P) ; IS THIS LAST WORD?
\r
30997 SOJLE B,WRDIN1 ; YES, DONT RE-IOT
\r
30998 SUB A,[BUFLNT,,BUFLNT]
\r
31001 MOVEM B,ASTO(PVP)
\r
31007 ; READ IN NEXT HALF WORD
\r
31009 HWRDIN: JUMPN E,NOIOT ; USE EXISTING WORD
\r
31010 PUSH P,-3(P) ; FAKE OUT WRDIN IF NEC.
\r
31013 POP P,-4(P) ; RESET COUNTER
\r
31014 HLRZ C,E ; RET LH
\r
31021 TYPFIX: PUSH TP,$TATOM
\r
31022 PUSH TP,EQUOTE BAD-TYPE-NAME
\r
31026 PUSH TP,EQUOTE ERRET-TYPE-NAME-DESIRED
\r
31030 BRSUBR: PUSH TP,$TATOM
\r
31031 PUSH TP,EQUOTE RSUBR-IN-BAD-FORMAT
\r
31036 ;TABLE OF BYTE POINTERS FOR GETTING CHARS
\r
31038 BYTPNT": 350700,,CHTBL(A)
\r
31044 ;HERE ARE THE TABLES OF CHXRACTERS (NOTE EVERYTHING NOT SPECIFIED IS
\r
31045 ;IN THE NUMBER LETTER CATAGORY)
\r
31047 SETCHR 2,[0123456789]
\r
31055 SETCOD 6,[15,12,11,14,40,33] ;ALL ARE TYPE 2 (SPACING - FF,TAB,SPACE,ALT-MODE)
\r
31057 INCRCH 7,[()[]'%"\#<>] ;GIVE THESE INCREASRNG CODES FROM 3
\r
31059 SETCOD 22,[3] ;^C - EOF CHARACTER
\r
31061 INCRCH 23,[;,{}!] ;COMMENT AND GLOBAL VALUE AND SPECIAL
\r
31064 OUTTBL ;OUTPUT THE TABLE RIGHT HERE
\r
31067 \f; THIS CODE FLUSHES WANDERING COMMENTS
\r
31069 COMNT: PUSHJ P,IREAD
\r
31073 COMNT2: SKIPL A,5(TB) ; RESTORE CHANNEL
\r
31074 MOVEI A,5(TB)-LSTCH ;NO CHANNEL, POINT AT SLOT
\r
31075 MOVEM B,LSTCH(A) ; CLOBBER IN CHAR
\r
31079 ;SUBROUTINE TO READ CHARS ONTO STACK
\r
31081 GOBBL1: MOVEI FF,0 ;KILL ALL FLAGS
\r
31082 PUSHJ P,LSTCHR ;DON'T REREAD "
\r
31083 TROA FF,NOTNUM+INSTRN ;SURPRESS NUMBER CONVERSION
\r
31084 GOBBLE: MOVEI FF,0 ;FLAGS CONCERRNING CURRENT GOODIE IN HERE
\r
31085 MOVE A,TP ;GOBBLE CURRENT TP TO BE PUSHED
\r
31086 MOVEI C,6 ;NOW PUSH 6 0'S ON TO STACK
\r
31087 PUSH TP,$TFIX ;TYPE IS FIXED
\r
31088 PUSH TP,FF ;AND VALUE IS 0
\r
31089 SOJG C,.-2 ;FOUR OF THEM
\r
31090 PUSH TP,$TTP ;NOW SAVE OLD TP
\r
31091 ADD A,[1,,1] ;MAKE IT LOOK LIKE A TB
\r
31093 MOVEI D,0 ;ZERO OUT CHARACTER COUNT
\r
31094 GOB1: MOVSI C,(<440700,,(P)>) ;SET UP FIRST WORD OF CHARS
\r
31095 PUSH P,[0] ;BYTE POINTER
\r
31096 GOB2: PUSH P,FF ;SAVE FLAG REGISTER
\r
31097 INTGO ; IN CASE P OVERFLOWS
\r
31100 MOVEI A,NXTCS ; HACK TO GET MAYBE NEW TYPE WITHOUT CHANGE
\r
31102 POP P,FF ;AND RESTORE FLAG REGISTER
\r
31103 CAIN B,ESCTYP ;IS IT A CHARACTER TO BE ESCAPED
\r
31104 JRST ESCHK ;GOBBLE THE ESCAPED CHARACTER
\r
31105 TRNE FF,INSTRN ;ARE WE BUILDING A CHAR STRING
\r
31106 JRST ADSTRN ;YES, GO READ IN
\r
31107 CAILE B,NONSPC ;IS IT SPECIAL
\r
31108 JRST DONEG ;YES, RAP THIS UP
\r
31110 TRNE FF,NOTNUM ;IS NUMERIC STILL WINNING
\r
31111 JRST SYMB2 ;NO, ONLY DO CHARACTER HACKING
\r
31112 CAIL A,60 ;CHECK FOR DIGIT
\r
31114 JRST SYMB1 ;NOT A DIGIT
\r
31115 JRST CNV ;GO CONVERT TO NUMBER
\r
31118 ;ARRIVE HERE IF STILL BUILDING A NUMBER
\r
31119 CNV: MOVE B,(TP) ;GOBBLE POINTER TO TEMPS
\r
31120 TRO FF,NUMWIN ;SAY DIGITSSEEN
\r
31121 SUBI A,60 ;CONVERT TO A NUMBER
\r
31122 TRNE FF,EFLG ;HAS E BEEN SEEN
\r
31123 JRST ECNV ;YES, CONVERT EXPONENT
\r
31124 TRNE FF,DOTSEN ;HAS A DOT BEEN SEEN
\r
31126 JRST DECNV ;YES, THIS IS A FLOATING NUMBER
\r
31128 MOVE E,ONUM(B) ; OCTAL CONVERT
\r
31132 TRNE FF,OCTSTR ; SKIP OTHER CONVERSIONS IF OCTAL FORCE
\r
31135 JFCL 17,.+1 ;KILL ALL FLAGS
\r
31136 MOVE E,CNUM(B) ;COMPUTE CURRENT RADIX
\r
31138 ADD E,A ;ADD IN CURRENT DIGIT
\r
31140 MOVEM E,CNUM(B) ;AND SAVE IT
\r
31144 ;INSERT OCTAL AND CRADIX CROCK HERE IF NECESSSARY
\r
31145 JRST DECNV1 ;CONVERT TO DECIMAL(FIXED)
\r
31148 DECNV: TRO FF,FLONUM ;SET FLOATING FLAG
\r
31149 DECNV1: JFCL 17,.+1 ;CLEAR ALL FLAGS
\r
31150 MOVE E,DNUM(B) ;GET DECIMAL NUMBER
\r
31152 JFCL 10,CNV2 ;JUMP IF OVERFLOW
\r
31153 ADD E,A ;ADD IN DIGIT
\r
31155 TRNE FF,FLONUM ;IS THIS FRACTION?
\r
31156 SOS NDIGS(B) ;YES, DECREASE EXPONENT BY ONE
\r
31158 CNV1: PUSHJ P,NXTCH ;RE-GOBBLE CHARACTER
\r
31159 JRST SYMB2 ;ALSO DEPOSIT INTO SYMBOL BEING MADE
\r
31160 CNV2: ;OVERFLOW IN DECIMAL NUMBER
\r
31161 TRNE FF,DOTSEN ;IS THIS FRACTION PART?
\r
31162 JRST CNV1 ;YES,IGNORE DIGIT
\r
31163 AOS NDIGS(B) ;NO, INCREASE IMPLICIT EXPONENT BY ONE
\r
31164 TRO FF,FLONUM ;SET FLOATING FLAG BUT
\r
31165 JRST CNV1 ;DO NOT FORCE DECIMAL(DECFRC)
\r
31167 ECNV: ;CONVERT A DECIMAL EXPONENT
\r
31168 HRRZ E,ENUM(B) ;GET EXPONENT
\r
31170 ADD E,A ;ADD IN DIGIT
\r
31171 TLNN E,777777 ;IF OVERFLOW INTO LEFT HALF
\r
31172 HRRM E,ENUM(B) ;DO NOT STORE(CATCH ERROR LATER)
\r
31174 JRST SYMB2 ;ALSO DEPOSIT INTO SYMBOL BEING MADE
\r
31177 ;HERE TO PUT INTO IDENTIFIER BEING BUILT
\r
31179 ESCHK: PUSHJ P,NXTC1 ;GOBBLE NEXT CHAR
\r
31180 SYMB: MOVE B,(TP) ;GET BACK TEM POINTER
\r
31181 TRNE FF,EFLG ;IF E FLAG SET
\r
31182 HLRZ FF,ENUM(B) ;RESTORE SAVED FLAGS
\r
31183 TRO FF,NOTNUM ;SET NOT NUMBER FLAG
\r
31184 SYMB2: TRO FF,NFIRST ;NOT FIRST IN WORLD
\r
31185 SYMB3: IDPB A,C ;INSERT IT
\r
31186 PUSHJ P,LSTCHR ;READ NEW CHARACTER
\r
31187 TLNE C,760000 ;WORD FULL?
\r
31188 AOJA D,GOB2 ;NO, KEEP TRYING
\r
31189 AOJA D,GOB1 ;COUNT WORD AND GO
\r
31191 ;HERE TO CHECK FOR +,-,. IN NUMBER
\r
31193 SYMB1: TRNE FF,NFIRST ;IS THIS THE FIRST CHARACTER
\r
31194 JRST CHECK. ;NO, ONLY LOOK AT DOT
\r
31195 CAIE A,"- ;IS IT MINUS
\r
31196 JRST .+3 ;NO CHECK PLUS
\r
31197 TRO FF,NEGF ;YES, NEGATE AT THE END
\r
31199 CAIN A,"+ ;IS IT +
\r
31200 JRST SYMB2 ;ESSENTIALLY IGNORE IT
\r
31201 CAIE A,"* ; FUNNY OCTAL CROCK?
\r
31209 CHECK.: PUSHJ P,LSTCHR ;FLUSH LAST CHARACTER
\r
31211 TRNN FF,DOTSEN+EFLG ;IF ONE ALREADY SEEN
\r
31213 JRST CHECKE ;GO LOOK FOR E
\r
31216 TRNN FF,NFIRST ;IS IT THE FIRST
\r
31217 JRST DOT1 ;YES, COULD MEAN EVALUATE A VARIABLE
\r
31220 CHCK.1: TRO FF,DECFRC+DOTSEN ;FORCE DECIMAL
\r
31221 IFN FRMSIN, TRNN FF,FRSDOT ;IF NOT FIRST ., PUT IN CHAR STRING
\r
31222 JRST SYMB2 ;ENTER INTO SYMBOL
\r
31223 IFN FRMSIN, JRST GOB2 ;IGNORE THE "."
\r
31229 ;HERE TO SET UP FOR .FOO ..FOO OR.<ABC>
\r
31231 DOT1: PUSH P,FF ;SAVE FLAGS
\r
31232 PUSHJ P,NXTCH1 ;GOBBLE A NEW CHARACTER
\r
31233 POP P,FF ;RESTORE FLAGS
\r
31234 TRO FF,FRSDOT ;SET FLAG IN CASE
\r
31235 CAIN B,NUMCOD ;SKIP IF NOT NUMERIC
\r
31236 JRST CHCK.1 ;NUMERIC, COULD BE FLONUM
\r
31238 ; CODE TO HANDLE ALL IMPLICIT CALLS I.E. QUOTE, LVAL, GVAL
\r
31240 MOVSI B,TFORM ;LVAL
\r
31241 MOVE A,MQUOTE LVAL
\r
31242 SUB P,[2,,2] ;POP OFF BYTE POINTER AND GOBBLE CALL
\r
31244 SUB TP,[1,,1] ;REMOVE TP JUNK
\r
31247 GLOSEG: SKIPA B,$TSEG ;SEG CALL TO GVAL
\r
31248 GLOVAL: MOVSI B,TFORM ;FORM CALL TO SAME
\r
31249 MOVE A,MQUOTE GVAL
\r
31252 QUOSEG: SKIPA B,$TSEG ;SEG CALL TO QUOTE
\r
31253 QUOTIT: MOVSI B,TFORM
\r
31254 MOVE A,MQUOTE QUOTE
\r
31257 SEGDOT: MOVSI B,TSEG ;SEG CALL TO LVAL
\r
31258 MOVE A,MQUOTE LVAL
\r
31259 IMPCAL: PUSHJ P,LSTCHR ;FLUSH LAST CHAR EXCEPT
\r
31260 IMPCA1: PUSH TP,$TATOM ;FOR .FOO FLAVOR
\r
31261 PUSH TP,A ;PUSH ARGS
\r
31262 PUSH P,B ;SAVE TYPE
\r
31263 PUSHJ P,IREAD1 ;READ
\r
31264 JRST USENIL ; IF NO ARG, USE NIL
\r
31265 IMPCA2: PUSH TP,C
\r
31267 MOVE C,A ; GET READ THING
\r
31269 PUSHJ P,INCONS ; CONS TO NIL
\r
31270 MOVEI E,(B) ; PREPARE TON CONS ON
\r
31271 POPARE: POP TP,D ; GET ATOM BACK
\r
31273 EXCH C,-1(TP) ; SAVE THAT COMMENT
\r
31276 POP P,A ;GET FINAL TYPE
\r
31277 JRST RET13 ;AND RETURN
\r
31280 USENIL: PUSH TP,C
\r
31282 SKIPL A,5(TB) ; RESTOR LAST CHR
\r
31283 MOVEI A,5(TB)-LSTCH ;NO CHANNEL, POINT AT SLOT
\r
31288 ;HERE AFTER READING ATOM TO CALL VALUE
\r
31290 .SET: SUB P,[1,,1] ;FLUSH GOBBLE CALL
\r
31291 PUSH P,$TFORM ;GET WINNING TYPE
\r
31293 PUSHJ P,RETC ; CHECK FOR POSSIBLE COMMENT
\r
31295 PUSH TP,MQUOTE LVAL
\r
31296 JRST IMPCA2 ;GO CONS LIST
\r
31300 ;HERE TO CHECK FOR "E" FLAVOR OF EXPONENT
\r
31302 CHECKE: CAIN A,"* ; CHECK FOR FINAL *
\r
31304 TRNN FF,EFLG ;HAS ONE BEEN SEEN
\r
31305 CAIE B,NONSPC ;IF NOT, IS THIS ONE
\r
31306 JRST SYMB ;NO, ENTER AS SYMBOL KILL NUMERIC WIN
\r
31308 TRNN FF,NUMWIN ;HAVE DIGITS BEEN SEEN?
\r
31309 JRST SYMB ;NO, NOT A NUMBER
\r
31310 MOVE B,(TP) ;GET POINTER TO TEMPS
\r
31311 HRLM FF,ENUM(B) ;SAVE FLAGS
\r
31312 HRRI FF,DECFRC+DOTSEN+EFLG ;SET NEW FLAGS
\r
31313 JRST SYMB3 ;ENTER SYMBOL
\r
31316 SYMB4: TRZN FF,OCTSTR
\r
31318 TRZN FF,OCTWIN ; ALREADY WON?
\r
31319 TROA FF,OCTWIN ; IF NOT DO IT NOW
\r
31323 ;HERE ON READING CHARACTER STRING
\r
31325 ADSTRN: SKIPL A ; EOF?
\r
31326 CAIN B,MANYT ;TERMINATE?
\r
31329 JRST SYMB2 ;NO JUST INSERT IT
\r
31330 ADSTN1: PUSHJ P,LSTCHR ;DON'T REREAD """
\r
31333 ;HERE TO FINISH THIS CROCK
\r
31335 DONEG: TRNN FF,OCTSTR ; IF START OCTAL BUT NOT FINISH..
\r
31336 TRNN FF,NUMWIN ;HAVE DIGITS BEEN SEEN?
\r
31337 TRO FF,NOTNUM ;NO,SET NOT NUMBER FLAG
\r
31338 SKIPGE C ; SKIP IF STUFF IN TOP WORD
\r
31341 TRNN FF,NOTNUM ;NUMERIC?
\r
31342 JRST NUMHAK ;IS NUMERIC, GO TO IT
\r
31345 MOVE A,(TP) ;GET POINTER TO TEMPS
\r
31346 MOVEM FF,NDIGS(A) ;USE TO HOLD FLAGS
\r
31348 TRNE FF,INSTRN ;ARE WE BUILDING A STRING
\r
31349 JRST MAKSTR ;YES, GO COMPLETE SAME
\r
31350 LOOPAT: PUSHJ P,NXTCH ; CHECK FOR TRAILER
\r
31351 CAIN B,PATHTY ; PATH BEGINNER
\r
31352 JRST PATH0 ; YES, GO PROCESS
\r
31353 CAIN B,SPATYP ; SPACER?
\r
31354 PUSHJ P,SPACEQ ; CHECK FOR REAL SPACE
\r
31356 PUSHJ P,LSTCHR ; FLUSH IT AND RETRY
\r
31358 PATH0: PUSHJ P,NXTCH1 ; READ FORCED NEXT
\r
31359 CAIE B,SPCTYP ; DO #FALSE () HACK
\r
31362 CAIL B,SPATYP ; SPACER?
\r
31363 JRST PATH3 ; YES, USE THE ROOT OBLIST
\r
31364 PATH4: PUSHJ P,NIREA1 ; READ NEXT ITEM
\r
31365 PUSHJ P,ERRPAR ; LOSER
\r
31366 CAME A,$TATOM ; ONLY ALLOW ATOMS
\r
31374 PUSH TP,IMQUOTE OBLIST
\r
31375 MCALL 2,GET ; GET THE OBLIST
\r
31376 CAMN A,$TOBLS ; IF NOT OBLIST, MAKE ONE
\r
31378 MCALL 1,MOBLIS ; MAKE ONE
\r
31381 PATH6: SUB TP,[2,,2]
\r
31385 PATH3: MOVE B,ROOT+1(TVP) ; GET ROOT OBLIST
\r
31387 PATH1: PUSHJ P,RLOOKU ; AND LOOK IT UP
\r
31390 MOVE C,(TP) ;SET TO REGOBBLE FLAGS
\r
31396 SPACEQ: ANDI A,-1
\r
31404 ;HERE TO RAP UP CHAR STRING ITEM
\r
31406 MAKSTR: MOVE C,D ;SETUP TO CALL CHMAK
\r
31407 PUSHJ P,CHMAK ;GO MAKE SAME
\r
31411 NUMHAK: MOVE C,(TP) ;REGOBBLETEMP POINTER
\r
31412 POP P,D ;POP OFF STACK TOP
\r
31415 HRLI D,(D) ;TOO BOTH HALVES
\r
31416 SUB P,D ;REMOVE CHAR STRING
\r
31417 TRNE FF,FLONUM+EFLG ;IS IT A FLOATING POINT NUMBER
\r
31418 JRST FLOATIT ;YES, GO MAKE IT WIN
\r
31421 MOVE B,DNUM(C) ;GRAB FIXED GOODIE
\r
31422 TRNE FF,OCTWIN ; SKIP IF NOT OCTAL
\r
31423 MOVE B,ONUM(C) ; USE OCTAL VALUE
\r
31425 FINID2: MOVSI A,TFIX ;SAY FIXED POINT
\r
31426 FINID1: TRNE FF,NEGF ;NEGATE
\r
31428 FINID: POP TP,TP ;RESTORE OLD TP
\r
31429 SUB TP,[1,,1] ;FINISH HACK
\r
31431 TRNE FF,FRSDOT ;DID . START IT
\r
31432 JRST .SET ;YES, GO HACK
\r
31434 POPJ P, ;AND RETURN
\r
31439 PATH2: MOVE B,IMQUOTE OBLIST
\r
31443 BADPAT: PUSH TP,$TATOM
\r
31444 PUSH TP,EQUOTE NON-ATOMIC-OBLIST-NAME
\r
31449 JFCL 17,.+1 ;CLEAR ALL ARITHMETIC FLAGS
\r
31451 TRNE FF,EFLG ;"E" SEEN?
\r
31452 JRST EXPDO ;YES, DO EXPONENT
\r
31453 MOVE D,NDIGS(C) ;GET IMPLICIT EXPONENT
\r
31455 FLOATE: MOVE A,DNUM(C) ;GET DECIMAL NUMBER
\r
31456 IDIVI A,400000 ;SPLIT
\r
31457 FSC A,254 ;CONVERT MOST SIGNIFICANT
\r
31458 FSC B,233 ; AND LEAST SIGNIFICANT
\r
31459 FADR B,A ;COMBINE
\r
31461 MOVM A,D ;GET MAGNITUDE OF EXPONENT
\r
31462 CAILE A,37. ;HOW BIG?
\r
31463 JRST FOOR ;TOO BIG-FLOATING OUT OF RANGE
\r
31464 JUMPGE D,FLOAT1 ;JUMP IF EXPONENT POSITIVE
\r
31465 FDVR B,TENTAB(A) ;DIVIDE BY TEN TO THE EXPONENT
\r
31468 FLOAT1: FMPR B,TENTAB(A) ;SCALE UP
\r
31470 SETFLO: JFCL 10,FOOR ;FLOATING OUT OF RANGE ON OVERFLOW
\r
31472 IFN FRMSIN, TRZ FF,FRSDOT ;FLOATING NUMBER NOT VALUE
\r
31476 HRRZ D,ENUM(C) ;GET EXPONENT
\r
31477 TRNE FF,NEGF ;IS EXPONENT NEGATIVE?
\r
31479 ADD D,NDIGS(C) ;ADD IMPLICIT EXPONENT
\r
31480 HLR FF,ENUM(C) ;RESTORE FLAGS
\r
31481 JUMPL D,FLOATE ;FLOATING IF EXPONENT NEGATIVE
\r
31482 CAIG D,10. ;OR IF EXPONENT TOO LARGE
\r
31483 TRNE FF,FLONUM ;OR IF FLAG SET
\r
31486 IMUL B,ITENTB(D)
\r
31487 JFCL 10,FLOATE ;IF OVERFLOW, MAKE FLOATING
\r
31488 JRST FINID2 ;GO MAKE FIXED NUMBER
\r
31490 ; HERE TO READ ONE CHARACTER FOR USER.
\r
31492 CREDC1: SUBM M,(P)
\r
31499 CNXTC1: SUBM M,(P)
\r
31506 CREADC: SUBM M,(P)
\r
31514 CNXTCH: SUBM M,(P)
\r
31520 RMPOPJ: SUB TP,[2,,2]
\r
31524 IREADC: MOVEI E,1
\r
31525 MOVE B,(TP) ; CHANNEL
\r
31526 HRRZ A,-4(B) ; GET BLESS BITS
\r
31532 TRC A,C.OPN+C.READ
\r
31533 TRNE A,C.OPN+C.READ
\r
31537 MOVEM A,LSTCH(B) ; SAVE CHAR
\r
31538 CAMN A,[-1] ; SPECIAL PSEUDO TTY HACK?
\r
31539 JRST PSEUDO ; YES, RET AS FIX
\r
31540 TRZN A,400000 ; UNDO ! HACK
\r
31544 MOVEI A,"! ; RETURN AN !
\r
31545 NOEXC1: SKIPGE B,A ; CHECK EOF
\r
31546 SOS (P) ; DO EOF RETURN
\r
31547 MOVE B,A ; CHAR TO B
\r
31562 ; READER ERRORS COME HERE
\r
31564 ERRPAR: PUSH TP,$TCHRS ;DO THE OFFENDER
\r
31567 PUSH TP,[40] ;SPACE
\r
31569 PUSH TP,CHQUOT UNEXPECTED
\r
31572 ;COMPLAIN ABOUT MISMATCHED CLOSINGS
\r
31574 MISMAB: SKIPA A,["]]
\r
31575 MISMAT: MOVE A,-1(P) ;GOBBLE THE DESIRED CHARACTER
\r
31576 JUMPE B,CPOPJ ;IGNORE UNIVERSAL CLOSE
\r
31580 PUSH TP,CHQUOT [ INSTEAD-OF ]
\r
31583 MISMA1: MCALL 3,STRING
\r
31585 PUSH TP,EQUOTE READER-SYNTAX-ERROR-ERRET-ANYTHING-TO-GO-ON
\r
31589 PUSH TP,MQUOTE READ
\r
31593 ; HERE ON BAD INPUT CHARACTER
\r
31595 BADCHR: PUSH TP,$TATOM
\r
31596 PUSH TP,EQUOTE BAD-ASCII-CHARACTER
\r
31599 ; HERE ON YUCKY PARSE TABLE
\r
31601 BADPTB: PUSH TP,$TATOM
\r
31602 PUSH TP,EQUOTE BAD-MACRO-TABLE
\r
31605 BDPSTR: PUSH TP,$TATOM
\r
31606 PUSH TP,EQUOTE BAD-PARSE-STRING
\r
31609 ILLSQG: PUSHJ P,LSTCHR ; DON'T MESS WITH IT AGAIN
\r
31611 PUSH TP,EQUOTE BAD-USE-OF-SQUIGGLY-BRACKETS
\r
31615 ;FLOATING POINT NUMBER TOO LARGE OR SMALL
\r
31616 FOOR: PUSH TP,$TATOM
\r
31617 PUSH TP,EQUOTE NUMBER-OUT-OF-RANGE
\r
31624 SKIPL B,5(TB) ;GET CHANNEL
\r
31625 JRST LSTCH1 ;NO CHANNEL, POINT AT SLOT
\r
31630 LSTCH2: SKIPE LSTCH(B) ;ARE WE REALLY FLUSHING A REUSE CHARACTER ?
\r
31635 LSTCH1: SETZM 5(TB) ;ZERO THE LETTER AND RETURN
\r
31640 HRRZ A,-4(B) ; GET BITS
\r
31647 CNTBIN: AOS A,ACCESS-1(B)
\r
31651 HLLZS ACCESS-1(B)
\r
31655 ;TABLE OF NAMES OF ARGS AND ALLOWED TYPES
\r
31658 IRP A,,[[[CAIN C,TUNBOU]],[[CAIE C,TCHAN],INCHAN],[[PUSHJ P,CHOBL],OBLIST]]
\r
31661 IFSN [C],IMQUOTE C
\r
31666 CHOBL: CAIE C,TLIST ;A LIST OR AN OBLIST
\r
31673 \fTITLE SAVE AND RESTORE STATE OF A MUDDLE
\r
31677 .INSRT DSK:MUDDLE >
\r
31688 .GLOBAL MOPEN,MIOT,MCLOSE,MUDSTR,SWAP,STRTO6,GCPDL,RGPRS
\r
31689 .GLOBAL CHNL0,CHNL1,REOPN,AGC,SWAPIN,MASK1,MASK2,IPCBLS
\r
31690 .GLOBAL P.CORE,P.TOP,SGSNAM,%RUNAM,%RJNAM,INTINT,CLOSAL,TTYOPE
\r
31691 .GLOBAL NOTTY,PURCLN,6TOCHS,DISXTR,IDVAL1,N.CHNS
\r
31693 MFUNCTION FSAVE,SUBR
\r
31697 PUSH P,. ; SAY WE ARE FAST SAVER
\r
31700 MFUNCTION SAVE,SUBR
\r
31704 PUSH P,[0] ; SAY WE ARE OLD SLOW SAVE
\r
31705 SAVE1: SKIPG MUDSTR+2 ; DON'T SAVE FROM EXPERIMENTAL MUDDLE
\r
31707 PUSH P,[0] ; GC OR NOT?
\r
31709 MOVE B,[400600,,]
\r
31710 MOVE C,[440000,,100000]
\r
31712 PUSHJ P,GTFNM ; GET THE FILE NAME ONTO P
\r
31715 JUMPGE AB,TMA ; TOO MUCH STRING
\r
31716 GETYP 0,(AB) ; WHAT IS ARG
\r
31717 CAMGE AB,[-3,,0] ; NOT TOO MANY
\r
31720 IFN ITS, SETOM -4(P) ; GC FLAG
\r
31721 IFE ITS, SETOM (P)
\r
31724 MOVSI A,7 ; IMAGE BLOCK OUT
\r
31725 HRR A,-2(P) ; DEVICE
\r
31727 PUSH P,[SIXBIT /_MUDS_/]
\r
31728 PUSH P,[SIXBIT />/]
\r
31729 MOVEI A,-2(P) ; POINT TO BLOCK
\r
31730 PUSHJ P,MOPEN ; ATTEMPT TO OPEN
\r
31732 SUB P,[3,,3] ; FLUSH OPEN BLOCK
\r
31733 PUSH P,-4(P) ; GC FLAG TO TOP OF STACK
\r
31735 EXCH A,(P) ; CHAN TO STACK GC TO A
\r
31739 ; NOW GET VERSION OF MUDDLE FOR COMPARISON
\r
31741 MOVE A,MUDSTR+2 ; GET #
\r
31742 MOVEI B,177 ; CHANGE ALL RUBOUT CHARACTERS
\r
31743 MOVEI C,40 ; ----- TO SPACES
\r
31747 MOVEI A,0 ; WRITE ZERO IF FAST
\r
31748 IFN ITS, SKIPE -6(P)
\r
31749 IFE ITS, SKIPE -1(P)
\r
31751 MOVE A,VECTOP ; CORE REQUIREMENTS FOR THIS SAVED MUDDLE
\r
31755 SETZB A,B ; FIRST, ALL INTS OFF
\r
31757 SKIPE DISXTR ; IF HAVE DISPLAY, CLOSE IT
\r
31758 .DSTOP ; STOP THE E&S IF RUNNING
\r
31760 ; IF FAST SAVE JUMP OFF HERE
\r
31765 ; NOW DUMP OUT GC SPACE
\r
31766 MOVEI A,E+1 ; ADDRESS OF FIRST NON-SCRATCH WORD
\r
31767 POP P,0 ; CHAN TO 0
\r
31768 LSH 0,23. ; POSITION
\r
31773 MOVEI A,400000 ; FOR THIS PROCESS
\r
31774 DIR ; TURN OFF INT SYSTEM
\r
31776 ; IF FAST, LEAVE HERE
\r
31781 ; NOW DUMP OUT GC SPACE
\r
31782 POP P,0 ; RESTORE JFN
\r
31783 MOVE A,[-<P-E>,,E] ; NUMBER OF ACS TO GO
\r
31789 MOVEI A,20 ; START AT LOCN 20
\r
31791 DMPLP1: MOVEI B,(A) ; POINT TO START OF STUFF
\r
31792 SUB B,VECTOP ; GET BLOCK LENGTH
\r
31794 HRRI B,(A) ; HAVE IOT POINTER
\r
31795 SKIPL B ; SKIP IF OK AOBJN POINTER
\r
31796 HRLI B,400000 ; OTHER WISE AS MUCH AS POSSIBLE
\r
31798 ; MAIN NON-ZERO DUMPING LOOP
\r
31800 DMPLP: SKIPN C,(B) ; FIND FIRST NON-ZERO
\r
31802 JUMPGE B,DMPDON ; NO MORE TO SCAN
\r
31804 DMP4: MOVEI E,(B) ; FOUND ONE, SAVE POINTER TO IT
\r
31805 DMP3: MOVSI D,-5 ; DUPLICATE COUNTER SETUP
\r
31807 DMP1: CAMN C,(B) ; IS NEXT SAME AS THIS?
\r
31808 JRST CNTDUP ; COUNT DUPS
\r
31809 MOVSI D,-5 ; RESET COUNTER
\r
31810 SKIPE C,(B) ; SEARCH FOR ZERO
\r
31811 DMP5: AOBJN B,DMP1 ; COUNT AND GO
\r
31812 JUMPGE B,DMP2 ; JUMP IF BLOCK FINISHED
\r
31814 AOBJP B,DMP2 ; CHECK FOR LONE ZERO
\r
31816 JRST DMP1 ; LONE ZERO, DONT END BLOCK
\r
31818 DMP2: MOVEI D,(E) ; START COMPUTING OUTPUT IOT
\r
31819 SUBI D,(B) ; D=> -LNTH OF BLOCK
\r
31820 HRLI E,(D) ; E=> AOBJN PNTR TO OUTPUT
\r
31822 HRROI A,E ; MAKE AN IOT POINTER TO IT
\r
31824 MOVE A,E ; NOW FOR THE BLOCK
\r
31825 XCT 0 ; ZAP!, OUT IT GOES
\r
31828 EXCH E,B ; AOBJN TO B
\r
31829 MOVE A,0 ; JFN TO A
\r
31831 MOVE D,B ; SAVE POINTER
\r
31832 HRLI B,444400 ; BYTPE POINTER
\r
31833 HLRE C,D ; # OF BYTES
\r
31836 ; NOW COMPUTE A CKS
\r
31839 MOVE D,E ; FIRST WORD OF CKS
\r
31842 AOBJN D,.-2 ; COMP CKS
\r
31844 XCT 0 ; WRITE OUT THE CKS
\r
31852 MOVE B,E ; MAIN POINTER BACK
\r
31855 DMP7: JUMPL B,DMPLP ; MORE TO DO?
\r
31856 DMPDON: SUB B,VECTOP ; DONE?
\r
31857 JUMPGE B,DMPDN1 ; YES, LEAVE
\r
31858 IFN ITS, MOVEI A,400000+PVP ; POINT TO NEXT WORD TO GO
\r
31859 IFE ITS, MOVEI A,400020
\r
31862 DMPDN1: HRROI A,[-1]
\r
31864 DMPDN2: SETZB A,B ; SET UP RENAME WHILE OPEN ETC.
\r
31867 LDB C,[270400,,0] ; GET CHANNEL
\r
31868 .FDELE A ; RENAME IT
\r
31869 FATAL SAVE RENAME FAILED
\r
31870 XOR 0,[<.IOT A>#<.CLOSE>] ; CHANGE TO A CLOSE
\r
31873 MOVE A,MASK1 ; TURN INTS BACK ON
\r
31876 SKIPE DISXTR ; SKIP IF NO E&S
\r
31877 .DCONTINUE ; RESTART THE E&S IF WE HAVE IT
\r
31881 DMPDN1: MOVNI B,1
\r
31882 MOVE A,0 ; WRITE EOF
\r
31886 FATAL CANT CLOSE SAVE FILE
\r
31887 CIS ; CLEAR IT SYSTEM
\r
31889 EIR ; AND RE-ENABLE
\r
31892 SDONE: MOVE A,$TCHSTR
\r
31893 MOVE B,CHQUOTE SAVED
\r
31896 ; SCAN FOR MANY OCCURENCES OF THE SAME THING
\r
31898 CNTDUP: AOBJN D,DMP5 ; 4 IN A ROW YET
\r
31899 CAIN E,-4(B) ; ANY PARTIAL BLOCK?
\r
31900 JRST DMP6 ; NO, DUMP THESE
\r
31901 SUB B,[4,,4] ; BACK UP POINTER
\r
31903 DMP6: CAMN C,(B) ; FIND ALL CONTIG
\r
31905 MOVEI D,(B) ; COMPUTE COUNT
\r
31908 HRRI D,(E) ; HEADER
\r
31912 HRROI A,C ; WRITE THE WORD
\r
31924 ; HERE TO WRITE OUT FAST SAVE FILE
\r
31926 FSAVE1: MOVE A,PARTOP ; DONT WRITE OUT "HOLE"
\r
31935 POP P,0 ; CHANNEL TO 0
\r
31937 ASH 0,23. ; TO AC FIELS
\r
31939 MOVEI A,5 ; START AT WORD 5
\r
31942 MOVE A,[-<P-E>,,E]
\r
31946 MOVE B,P ; WRITE OUT P FOR WIINAGE
\r
31948 MOVE B,[444400,,20]
\r
31950 SOUT ; MAKE PAGE BOUNDARIES WIN
\r
31951 MOVEI A,20 ; START AT 20
\r
31953 MOVEI B,(E) ; PARTOP TO B
\r
31954 PUSHJ P,FOUT ; WRITE OUT UP TO PAIR TOP
\r
31955 HLRZ A,E ; VECBOT TO A
\r
31956 MOVE B,VECTOP ; AND THE REST
\r
31961 FOUT: MOVEI D,(A) ; SAVE START
\r
31962 SUB A,B ; COMPUTE LH OF IOT PNTR
\r
31964 SKIPL A ; IF + MEANS GROSS CORE SIZE
\r
31965 MOVSI A,400000 ; USE BIGGEST
\r
31967 XCT 0 ; ZAP, OUT IT GOES
\r
31968 CAMGE A,B ; SKIP IF ALL WENT
\r
31969 JRST FOUT ; DO THE REST
\r
31970 POPJ P, ; GO CLOSE FILE
\r
31973 FOUT: MOVEI C,(A)
\r
31974 SUBI C,(B) ; # OF BYTES TP C
\r
31975 MOVEI B,(A) ; START TO B
\r
31978 SOUT ; WRITE IT OUT
\r
31983 ; HERE TO ATTEMPT TO RESTORE A SAVED STATE
\r
31985 MFUNCTION RESTORE,SUBR
\r
31988 SKIPG MUDSTR+2 ; DON'T RESTORE FROM EXPERIMENTAL MUDDLE
\r
31991 MOVE B,[100600,,]
\r
31992 MOVE C,[440000,,240000]
\r
31997 MOVEI A,6 ; READ/IMAGE/BLOCK
\r
32000 PUSHJ P,MOPEN ; OPEN THE LOSER
\r
32002 SUB P,[4,,4] ; REMOVE OPEN BLOCK
\r
32004 PUSH P,A ; SAVE CHANNEL
\r
32005 PUSHJ P,SGSNAM ; SAVE SNAME IN SYSTEM
\r
32007 IFE ITS, PUSH P,A ; SAVE JFN
\r
32008 PUSHJ P,WRDIN ; READ MUDDLE VERSION
\r
32009 MOVEI B,40 ; CHANGE ALL SPACES
\r
32010 MOVEI C,177 ; ----- TO RUBOUT CHARACTERS
\r
32012 CAME A,MUDSTR+2 ; AGREE ?
\r
32015 IFN ITS, MCALL 0,IPCOFF ; CLOSE ALL IPC CHANS
\r
32016 PUSHJ P,CLOSAL ; CLOSE CHANNELS
\r
32018 SETZB A,B ; KILL ALL POSSIBLE INTERRUPTION
\r
32022 MOVEI A,400000 ; DISABLE INTS
\r
32025 PUSHJ P,PURCLN ; DONT KEEP PURE SHAREDNESS
\r
32026 POP P,A ; RETRIEVE CHANNEL
\r
32028 PUSH P,A ; AND SAVE IT ON A GOOD PDL
\r
32029 PUSHJ P,WRDIN ; READ A WORD (VECTOP) OR 0==>FAST I.E. MAP RESTORE
\r
32031 MOVEM A,VECTOP ; SAVE FOR LATER
\r
32032 ASH A,-10. ; TO BLOCKS
\r
32033 MOVE C,A ; SAVE A COPY
\r
32034 ADDI A,1 ; ROOM FOR GC PDL
\r
32036 PUSHJ P,NOCORE ; LOSE,LOSE, LOSE
\r
32038 ; NOW READY TO READ IN GC SPACE
\r
32039 POP P,0 ; GET CHAN
\r
32041 MOVE B,[E+1,,E+2] ; BLT SETUP TO ZERO CORE
\r
32044 BLT B,-1+2000(A) ; THE WHOLE THING?
\r
32047 IOR 0,[.IOT A] ; BUILD IOT
\r
32051 BIN ; READ IN NEW "P"
\r
32056 HRROI A,B ; READ A HDR
\r
32058 JUMPL A,LD1 ; DONE
\r
32067 JUMPGE B,LDDUPS ; JUMP IF LOADING DUPS
\r
32069 MOVE A,B ; TO IOTER
\r
32072 MOVE C,B ; COMP CKS
\r
32075 AOBJN B,.-2 ; COMP AWAY
\r
32077 HRROI A,D ; GET FILES CKS
\r
32080 FATAL RESTORE CHECKSUM ERROR
\r
32081 JRST LDLP ; LOAD MORE
\r
32088 SIN ; READ IN A BUNCH
\r
32095 BIN ; READ STORED CKS
\r
32097 FATAL RESTORE CHECKSUM ERROR
\r
32103 HRROI A,(B) ; READ 1ST IN PLACE
\r
32107 MOVE D,B ; SAVE HDR
\r
32108 BIN ; READ WORD OF INTEREST
\r
32112 HLRZ A,B ; # TO A
\r
32113 HRLI B,(B) ; BUILD A BLT PONTER
\r
32121 XOR 0,[<.IOT A>#<.CLOSE>] ; CHANGE TO CLOSE
\r
32122 XCT 0 ; AND DO IT
\r
32128 FASTR1: MOVEI A,P-1
\r
32138 MOVE A,VECTOP ; REAL CORE TOP
\r
32139 ADDI A,2000 ; ROOM FOR GC PDL
\r
32141 MOVEM E,NOTTY ; SAVE TTY FLAG
\r
32142 PUSHJ P,PURCLN ; IN CASE RESTORED THING HAD PURE STUFF
\r
32143 PUSHJ P,INTINT ; USE NEW INTRRRUPTS
\r
32145 ; NOW CYCLE THROUGH CHANNELS
\r
32147 ADD C,[CHNL1+2,,CHNL1+2] ; POINT TO REAL CHANNELS SLOTS
\r
32152 CHNLP: SKIPN B,-1(C) ; GET CHANNEL
\r
32156 MOVE C,(TP) ; GET POINTER
\r
32157 NXTCHN: ADD C,[2,,2] ; AND BUMP
\r
32162 SKIPN C,CHNL0(TVP)+1 ; ANY PSUEDO CHANNELS
\r
32163 JRST RDONE ; NO, JUST GO AWAY
\r
32164 MOVSI A,TLIST ; YES, REOPEN THEM
\r
32166 CHNLP1: MOVEM C,(TP) ; SAVE POINTER
\r
32167 SKIPE B,(C)+1 ; GET CHANNEL
\r
32170 MOVE C,(TP) ; GOBBLE POINTER
\r
32171 HRRZ C,(C) ; REST LIST OF PSUEDO CHANNELS
\r
32174 RDONE: SUB TP,[2,,2]
\r
32178 PUSHJ P,IPCBLS ;BLESS ALL THE IPC CHANNELS
\r
32179 PUSHJ P,SGSNAM ; GET SNAME
\r
32181 .SUSET [.RSNAM,,A]
\r
32182 PUSHJ P,6TOCHS ; TO STRING
\r
32190 MOVE B,CHQUOTE RESTORED
\r
32195 PUSHJ P,WRDIN ; GET CORE TOP
\r
32196 ASH A,-10. ; TO PAGES
\r
32197 MOVEI B,(A) ; SAVE
\r
32198 ADDI A,1 ; ROOM FOR GC PDL
\r
32199 PUSHJ P,P.CORE ; GET ALL CORE
\r
32200 PUSHJ P,NOCORE ; LOSE RETURN
\r
32201 PUSHJ P,WRDIN ; GET PARTOP
\r
32202 ASH A,-10. ; TO PAGES
\r
32204 PUSHJ P,WRDIN ; NOW GET VECBOT
\r
32205 ASH A,-10. ; TO PAGES
\r
32206 EXCH A,E ; AND SAVE IN E
\r
32208 MOVSI A,(A) ; TO PAGE AOBJN
\r
32209 MOVE C,A ; COPY OF POINTER
\r
32210 MOVE 0,NOTTY ; SAVE NOTTY FLAG AROUND
\r
32211 MOVE D,(P) ; CHANNEL
\r
32212 DOTCAL CORBLK,[[1000,,104000],[1000,,-1],A,D,C]
\r
32213 FATAL CORBLK ON RESTORE LOSSAGE
\r
32214 SUBM E,B ; AOBJN LH TO E
\r
32215 HRLI E,(B) ; AOBJN TO CORE
\r
32216 HRLI C,(B) ; AND TO DISK
\r
32217 DOTCAL CORBLK,[[1000,,104000],[1000,,-1],E,D,C]
\r
32218 FATAL CORBLK ON RESTORE LOSSAGE
\r
32219 MOVSI A,(D) ; CHANNEL BACK
\r
32221 MOVEI B,E ; WHERE TO STRAT IN FILE
\r
32222 IOR A,[.ACCESS B]
\r
32223 XCT A ; ACCESS TO RIGHT ACS
\r
32224 XOR A,[<.IOT B>#<.ACCESS B>]
\r
32225 MOVE B,[D-P-1,,E]
\r
32227 MOVE E,0 ; NO TTY FLAG BACK
\r
32228 XOR A,[<.IOT B>#<.CLOSE>]
\r
32232 FASTR: POP P,A ; JFN TO A
\r
32233 BIN ; CORE TOP TO B
\r
32241 MOVE 0,NOTTY ; SAVE NOTTY FLAG AROUND
\r
32242 HRL E,C ; SAVE VECTOP
\r
32243 MOVSI A,(A) ; JFN TO LH
\r
32244 MOVSI B,400000 ; FOR ME
\r
32245 MOVSI C,120400 ; FLAGS
\r
32246 ASH D,-9. ; PAGES TO D
\r
32252 ASH E,-9. ; E==> CORTOP PAGE,,VECBOT PAGE
\r
32253 HLR B,E ; B NOW READY
\r
32263 FATAL CANT CLOSE RESTORE FILE
\r
32264 MOVE E,0 ; NOTTY TO E
\r
32266 MOVE A,PARTOP ; ZERO OUT NEW FREE
\r
32271 BLT A,-1(B) ; ZAP...YOU'RE ZERO
\r
32275 ; HERE TO GROCK FILE NAME FROM ARGS
\r
32282 IRP A,,[DSK,MUDDLE,SAVE]
\r
32283 PUSH P,[SIXBIT /A/]
\r
32285 PUSHJ P,SGSNAM ; GET SNAME
\r
32286 PUSH P,A ; SAVE SNAME
\r
32289 PUSHJ P,RGPRS ; PARSE THESE ARGS
\r
32291 GTFNM1: AOS -4(P) ; SKIP RETURN
\r
32293 POP P,A ; GET SNAME
\r
32294 .SUSET [.SSNAM,,A]
\r
32295 MOVE A,-3(P) ; GET RET ADDR
\r
32296 HLRZS -2(P) ; FIXUP DEVICE SPEC
\r
32300 ; HERE TOO OUT 1 WORD
\r
32304 HRROI B,(P) ; POINT AT C(A)
\r
32305 MOVE A,-3(P) ; CHANNEL
\r
32306 PUSHJ P,MIOT ;WRITE IT
\r
32311 ; HERE TO READ 1 WORD
\r
32317 MOVE B,IMQUOTE SNM
\r
32323 PUSH P,[377777,,377777]
\r
32324 PUSH P,[-1,,[ASCIZ /DSK/]]
\r
32326 PUSH P,[-1,,[ASCIZ /MUDDLE/]]
\r
32327 PUSH P,[-1,,[ASCIZ /SAVE/]]
\r
32330 PUSH P,[77] ; USE AN OBSCURE JFN IF POSSIBLE
\r
32344 MOVE A,-2(P) ; JFN TO A
\r
32360 ;REPLACE ALL OCCURANCES OF CHARACTER (B) TO CHARACTER (C) IN A
\r
32363 MOVE D,[440700,,A]
\r
32366 CAIN 0,(B) ; MATCH ?
\r
32367 DPB C,D ; YES, CLOBBER
\r
32374 CANTOP: PUSH TP,$TATOM
\r
32375 PUSH TP,EQUOTE CANT-OPEN-OUTPUT-FILE
\r
32378 FNF: PUSH TP,$TATOM
\r
32379 PUSH TP,EQUOTE FILE-NOT-FOUND
\r
32382 BADVRS: PUSH TP,$TATOM
\r
32383 PUSH TP,EQUOTE MUDDLE-VERSIONS-DIFFER
\r
32386 EXPVRS: PUSH TP,$TATOM
\r
32387 PUSH TP,EQUOTE EXPERIMENTAL-MUDDLE-VERSION
\r
32390 CHNLO1: MOVE C,(TP)
\r
32394 CHNLOS: MOVE C,(TP)
\r
32396 CHNLO2: MOVEI B,[ASCIZ /
\r
32397 CHANNEL-NOT-RESTORED
\r
32405 WAIT, CORE NOT YET HERE
\r
32408 MOVE A,(P) ; RESTORE BLOCKS NEEDED
\r
32421 \f\fTITLE SPECS FOR MUDDLE
\r
32426 .GLOBAL TYPVLC,PBASE,TYPBOT,MAINPR,PTIME,IDPROC,ROOT,TTICHN,TTOCHN,TYPVEC
\r
32427 .GLOBAL %UNAM,%JNAM,NOTTY,GCHAPN,INTHLD,PURBOT,PURTOP,N.CHNS,SPCCHK,CURFCN
\r
32428 .GLOBAL TD.GET,TD.PUT,TD.LNT,NOSHUF
\r
32448 %UNAM: 0 ; HOLDS UNAME
\r
32449 %JNAM: 0 ; HOLDS JNAME
\r
32450 IDPROC: 0 ; ENVIRONMENT NUMBER GENERATOR
\r
32451 PTIME: 0 ; UNIQUE NUMBER FOR PROCID AND ENVIRONMENTS
\r
32452 OBLNT": 13. ; LENGTH OF DEFAULT OBLISTS (SMALL)
\r
32453 VECTOP": VECLOC ; TOP OF CURRENT GARBAGE COLLECTED SPACE
\r
32454 VECBOT": VECBASE ; BOTTOM OF GARBAGE COLLECTED SPACE
\r
32455 CODBOT: 0 ; ABSOLUTE BOTTOM OF CODE
\r
32456 CODTOP": PARBASE ; TOP OF IMPURE CODE (INCLUDING "STORAGE")
\r
32457 HITOP: 0 ; TOP OF INTERPRETER PURE CORE
\r
32461 VECNEW": 0 ; LOCATION FOR OFFSET BETWWEN OLD GCSTOP AND NEW GCSTOP
\r
32462 INTFLG: 0 ; INTERRUPT PENDING FLAG
\r
32463 MAINPR: 0 ; HOLDS POINTER TO THE MAIN PROCESS
\r
32464 NOTTY: 0 ; NON-ZERO==> THIS MUDDLE HAS NO TTY
\r
32465 GCHAPN: 0 ; NON-ZERO A GC HAS HAPPENED RECENTLY
\r
32466 INTHLD: 0 ; NON-ZERO INTERRUPTS CANT HAPPEN
\r
32467 PURBOT: HIBOT ; BOTTOM OF DYNAMICALLY ALLOCATED PURE
\r
32468 PURTOP: HIBOT ; TOP OF DYNAMICALLY ALLOCATED PURE
\r
32469 SPCCHK: SETZ ; SPECIAL/UNSPECIAL CHECKING?
\r
32470 NOSHUF: 0 ; FLAG TO BUILD A NON MOVING HI SEG
\r
32472 ;PAGE MAP USAGE TABLE FOR MUDDLE
\r
32473 ;EACH PAGE IS REPRESENTED BY ONE BIT IN THE TABLE
\r
32474 ;IF BIT = 0 THEN PAGE IS FREE OTHERWISE BUSY
\r
32475 ;FOR PAGE n USE BIT (n MOD 32.) IN WORD PMAP+n/32.
\r
32476 PMAP": -1 ;SECTION 0 -- BELONGS TO AGC
\r
32477 -1 ;SECTION 1 -- BELONGS TO AGC
\r
32478 -1 ;SECTION 2 -- BELONGS TO AGC
\r
32479 -1 ;SECTION 3 -- BELONGS TO AGC
\r
32480 -1 ;SECTION 4 -- BELONGS TO AGC
\r
32481 -1 ;SECTION 5 -- BELONGS TO AGC (DEPENDS ON HIBOT)
\r
32482 -1 ;SECTION 6 -- START OF PURE CORE (FILLED IN BY INITM)
\r
32483 -1 ;SECTION 7 -- LAST TWO PAGES BELONG TO AGC'S PAGE MAPPER
\r
32486 NINT==72. ; NUMBER OF POSSIBLE ITS INTERRUPTS
\r
32487 NASOCS==159. ; LENGTH OF ASSOCIATION VECTOR
\r
32488 PDLBUF==100 ; EXTRA INSURENCE PDL
\r
32489 ASOLNT==10 ; LENGTH OF ASSOCIATION BLOCKS
\r
32492 .GLOBAL PATCH,TBINIT,LERR,LPROG,PIDSTO,PROCID,PTIME,GCPDL,INTFLG,WTYP1,WTYP2
\r
32493 .GLOBAL PAT,PDLBUF,INTINT,PARNEW,GCPVP,START,SWAP,ICR,SPBASE,TPBASE,GLOBAS,GLOBSP,TPBAS
\r
32494 .GLOBAL TOPLEVEL,INTNUM,INTVEC,INTOBL,ASOVEC,ERROBL,MAINPR,RESFUN,.BLOCK,ASOLNT,NODES
\r
32495 .GLOBAL WRONGT,TTYOPE,OPEN,CLOSE,IOT,ILVAL,MESS,FACTI,REFVEC,MUDOBL,INITIA
\r
32496 .GLOBAL LSTRES,BINDID,DUMNOD,PSTAT,1STEPR,IDPROC,EVATYP,APLTYP,PRNTYP,PURVEC,STOLST
\r
32500 TVBASE": BLOCK TVLNT
\r
32507 ;INITIAL TYPE TABLE
\r
32514 TYPTP==.-2 ; POINT TO TOP OF TYPES
\r
32516 ; INITIAL SYMBOL TABEL FOR RSUBRS
\r
32519 SQUTBL: BLOCK 2*NSUBRS
\r
32523 INTVCL: BLOCK 2*NINT
\r
32531 GENERAL+<SASOC,,0>
\r
32534 NODDUM: BLOCK ASOLNT
\r
32535 GENERAL+<SASOC,,0>
\r
32540 ASOVCL: BLOCK NASOCS
\r
32546 ;THESE ENTRIES MUST NOT MOVE DURING INITILAIZATION
\r
32548 ADDTV TVEC,[-2*NUMPRI-2,,TYPVLC]
\r
32551 ADDTV TVEC,[-2*NUMPRI-2,,TYPVLC]
\r
32552 TYPBOT==TVOFF-1 ; POINT TO CURRENT TOP OF TYPE VECTORS
\r
32554 ;ENTRY FOR ROOT,TTICHN,TTOCHN
\r
32576 ADDTV TVEC,[-2*NINT,,INTVCL]
\r
32578 ADDTV TUVEC,[-NASOCS,,ASOVCL]
\r
32582 CHNL0"==TVOFF-1 ;LIST FOR CURRENTLY OPEN PSUEDO CHANNELS
\r
32591 REPEAT 15.,ADDCHN \.RPCNT+1
\r
32599 REPEAT 15.,ADDIPC \.RPCNT+1
\r
32606 REPEAT N.CHNS-1,[ADDTV TCHAN,0
\r
32610 ADDTV TASOC,[-ASOLNT,,NODLST]
\r
32613 ADDTV TASOC,[-ASOLNT,,NODDUM]
\r
32625 ; SLOTS ASSOCIATED WITH TEMPLATE DATA STRUCTURES
\r
32641 ;GLOBAL SPECIAL PDL
\r
32643 GSP: BLOCK GSPLNT
\r
32647 ADDTV TVEC,[-GSPLNT,,GSP]
\r
32651 GLOBSP==TVOFF-1 ;ENTRY FOR CURRENT POINTER TO GLOBAL SP
\r
32653 ; POINTER VECTOR TO PURE SHARED RSUBRS
\r
32655 PURV: BLOCK 3*20. ; ENOUGH FOR 20 SUCH (INITIALLY)
\r
32659 ADDTV TUVEC,[-3*20.,,PURV]
\r
32665 ;PROCESS VECTOR FOR GARBAGE COLLECTOR PROCESS
\r
32667 GCPVP: BLOCK PVLNT*2
\r
32676 ;INITIAL PROCESS VECTOR
\r
32678 PVBASE": BLOCK PVLNT*2
\r
32684 ;ENTRY FOR PROCESS I.D.
\r
32686 ADDPV TFIX,1,PROCID
\r
32687 ;THE FOLLOWING IRP MAKES SPACE FO9 SAVED ACS
\r
32691 IRP A,,[0,A,B,C,D,E,PVP,TVP,AB,TB,TP,SP,M,R,P]B,,[0
\r
32692 0,0,0,0,0,TPVP,TTVP,TAB,TTB,TTP,TSP,TCODE,TRSUBR,TPDL]
\r
32700 PVLOC==PVLOC+16.*2
\r
32704 ADDPV TTB,0,TBINIT
\r
32705 ADDPV TTP,0,TPBASE
\r
32706 ADDPV TSP,0,SPBASE
\r
32707 ADDPV TPDL,0,PBASE
\r
32709 ADDPV TLIST,0,.BLOCK
\r
32710 ADDPV TLIST,0,MESS
\r
32711 ADDPV TACT,0,FACTI
\r
32712 ADDPV TPVP,0,LSTRES
\r
32713 ADDPV TFIX,0,BINDID
\r
32714 ADDPV TFIX,1,PSTAT
\r
32715 ADDPV TPVP,0,1STEPR
\r
32716 ADDPV TSP,0,CURFCN
\r
32722 \f<PACKAGE "TTY"> ;"TENEX VERSION"
\r
32724 <ENTRY TTY-SET TTY-GET TTY-ON TTY-OFF>
\r
32726 <SETG CALICO-MOD #WORD *700000*> ;"wakeup on all but alpha, no echo"
\r
32727 MUDDLE-MOD ;"gunnasigned initially"
\r
32729 <GDECL (CALICO-MOD MUDDLE-MOD) WORD>
\r
32732 <PSEUDO <SET SFMOD #OPCODE *104000000110*>> ;"JSYS 110"
\r
32733 <PSEUDO <SET RFMOD #OPCODE *104000000107*>> ;"JSYS 107"
\r
32734 <DECLARE ("VALUE" WORD)>
\r
32735 <HRRZI A* -1> ;"controlling tty file desig"
\r
32741 <DECLARE ("VALUE" WORD <PRIMTYPE WORD>)>
\r
32751 <DEFINE TTY-OFF ()
\r
32752 <COND (<NOT <GASSIGNED? MUDDLE-MOD>>
\r
32753 <SETG MUDDLE-MOD <TTY-GET>>)>
\r
32754 <TTY-SET ,CALICO-MOD>>
\r
32756 <DEFINE TTY-ON ()
\r
32757 <COND (<NOT <GASSIGNED? MUDDLE-MOD>>
\r
32758 <SETG MUDDLE-MOD <TTY-GET>>)
\r
32759 (<TTY-SET ,MUDDLE-MOD>)>>
\r
32763 \fTITLE UUO HANDLER FOR MUDDLE AND HYDRA
\r
32767 ;GLOBALS FOR THIS PROGRAM
\r
32769 .GLOBAL BACKTR,PRINT,PDLBUF,TPGROW,SPECSTO,TIMOUT,AGC,VECBOT,VECTOP
\r
32770 .GLOBAL BCKTRK,TPOVFL,.MONWR,.MONRD,.MONEX,MAKACT,IGVAL,ILVAL,BFRAME
\r
32771 .GLOBAL PURTOP,PURBOT,PLOAD,PURVEC,STOSTR,MSGTYP,UUOH,ILLUUO
\r
32773 ;SETUP UUO DISPATCH TABLE HERE
\r
32777 IRP UUOS,,[[DP,DODP],[.MCALL,DMCALL],[.ACALL,DACALL],[.ECALL,DECALL],[.FATAL,DFATAL]]
\r
32779 IRP UUO,DISP,[UUOS]
\r
32787 REPEAT 100-UUFOO,[ILLUUO
\r
32799 JRST UUOPUR ;GO TO PURE CODE FOR THIS
\r
32801 SAVEC: 0 ; USED TO SAVE WORKING AC
\r
32807 ;SEPARATION OF PURE FROM IMPURE CODE HERE
\r
32809 UUOPUR: MOVEM C,SAVEC ; SAVE AC
\r
32810 LDB C,[330900,,40]
\r
32811 JRST @UUOTBL(C) ;DISPATCH BASED ON THE UUO
\r
32815 ILLUUO: FATAL ILLEGAL UUO
\r
32822 MOVEI D,0 ; FLAG NOT ENTRY CALL
\r
32823 LDB C,[270400,,40] ; GET AC FIELD OF UUO
\r
32824 COMCAL: LSH C,1 ; TIMES 2
\r
32825 MOVN AB,C ; GET NEGATED # OF ARGS
\r
32826 HRLI C,(C) ; TO BOTH SIDES
\r
32827 SUBM TP,C ; NOW HAVE TP TO SAVE
\r
32828 MOVEM C,TPSAV(TB) ; SAVE IT
\r
32829 MOVSI AB,(AB) ; BUILD THE AB POINTER
\r
32830 HRRI AB,1(C) ; POINT TO ARGS
\r
32831 HRRZ C,UUOH ; GET PC OF CALL
\r
32832 CAMG C,PURTOP ; SKIP IF NOT IN GC SPACE
\r
32833 CAIGE C,STOSTR ; SKIP IF IN GC SPACE
\r
32835 SUBI C,(M) ; RELATIVIZE THE PC
\r
32836 HRLI C,M ; FOR RETURNER TO WIN
\r
32837 MOVEM C,PCSAV(TB)
\r
32838 MOVEM SP,SPSAV(TB) ; SAVE BINDING GOODIE
\r
32839 MOVSI C,TENTRY ; SET UP ENTRY WORD
\r
32840 HRR C,40 ; POINT TO CALLED SR
\r
32841 ADD TP,[FRAMLN,,FRAMLN] ; ALLOCATE NEW FRAME
\r
32843 CALDON: MOVEM C,FSAV+1(TP) ; CLOBBER THE FRAME
\r
32844 MOVEM TB,OTBSAV+1(TP)
\r
32845 MOVEM AB,ABSAV+1(TP) ; FRAME BUILT
\r
32847 HRRI TB,(TP) ; SETUP NEW TB
\r
32849 MOVEI M,0 ; UNSETUP M FOR GC WINNAGE
\r
32850 CAMG C,VECTOP ; SKIP IF NOT RSUBR
\r
32851 CAMGE C,VECBOT ; SKIP IF RSUBR
\r
32853 GETYP A,(C) ; GET CONTENTS OF SLOT
\r
32854 JUMPN D,EVCALL ; EVAL CALLING ENTRY ?
\r
32855 CAIE A,TRSUBR ; RSUBR CALLING RSUBR ?
\r
32857 MOVE R,(C)+1 ; YES, SETUP R
\r
32858 CALLR0: HRRM R,FSAV+1(TB) ; FIXUP THE PROPER FSAV
\r
32859 CALLR1: AOS E,2(R) ; COUNT THE CALLS
\r
32860 TRNN E,-1 ; SKIP IF OK
\r
32863 SKIPL M,(R)+1 ; SETUP M
\r
32864 JRST SETUPM ; JUMP IF A PURE RSUBR IN QUESTION
\r
32865 AOBJP TB,.+1 ; GO TO CALLED RSUBR
\r
32866 INTGO ; CHECK FOR INTERRUPTS
\r
32869 COUNT1: SOS 2(R) ; UNDO OVERFLOW
\r
32873 CALLS: AOBJP TB,.+1 ; GO TO CALLED SUBR
\r
32874 INTGO ; CHECK FOR INTERRUPTS
\r
32877 ; HERE TO HANDLE A PURE RSUBR (LOAD IF PUNTED OR OTHERWISE FLUSHED)
\r
32879 SETUPM: MOVEI C,0 ; OFFSET (FOR MAIN ENTRIES)
\r
32880 STUPM1: MOVEI D,(M) ; GET OFFSET INTO CODE
\r
32881 HLRS M ; GET VECTOR OFFSET IN BOTH HALVES
\r
32882 ADD M,PURVEC+1(TVP) ; GET IT
\r
32884 FATAL LOSING PURE RSUBR POINTER
\r
32885 HLLM TB,2(M) ; MARK FOR LRU ALGORITHM
\r
32886 SKIPN M,1(M) ; POINT TO CORE IF LOADED
\r
32887 AOJA TB,STUPM2 ; GO LOAD IT
\r
32888 STUPM3: ADDI M,(D) ; POINT TO REAL THING
\r
32889 HRLI C,M ; POINT TO START PC
\r
32892 JRST @C ; GO TO IT
\r
32894 STUPM2: HLRZ A,1(R) ; SET UP TO CALL LOADER
\r
32897 PUSHJ P,PLOAD ; LOAD IT
\r
32901 MOVE M,B ; GET LOCATION
\r
32904 RCHECK: CAIN A,TPCODE ; PURE RSUBR?
\r
32906 CAIE A,TCODE ; EVALUATOR CALLING RSUBR ?
\r
32908 MOVS R,(C) ; YES, SETUP R
\r
32910 JRST CALLR1 ; GO FINISH THE RSUBR CALL
\r
32913 SCHECK: CAIE A,TSUBR ; RSUBR CALLING SUBR AS REFERENCE ?
\r
32915 SKIPA C,(C)+1 ; SKIP AND GET ROUTINE'S ADDRESS
\r
32917 HRRM C,FSAV+1(TB) ; FIXUP THE PROPER FSAV
\r
32918 JRST CALLS ; GO FINISH THE SUBR CALL
\r
32920 ECHECK: CAIE A,TENTER ; SKIP IF SUB ENTRY OF RSUBR
\r
32921 JRST ACHECK ; COULD BE EVAL CALLING ONE
\r
32922 MOVE C,1(C) ; POINT TO SUB ENTRY BLOCK
\r
32923 ECHCK3: GETYP A,(C) ; SEE IF LINKED TO ITS MAIN ENTRY
\r
32928 ; CHECK IF CAN LINK ATOM
\r
32931 JRST BENTRY ; LOSER , COMPLAIN
\r
32932 ECHCK4: MOVE B,1(C) ; GET ATOM
\r
32935 PUSHJ P,IGVAL ; TRY GLOBAL VALUE
\r
32940 CAME A,$TRSUBR ; IS IT A WINNER
\r
32944 HLLM A,(C) ; FIXUP LINKAGE
\r
32948 EVCALL: CAIN A,TATOM ; EVAL CALLING ENTRY?
\r
32949 JRST ECHCK4 ; COULD BE MUST FIXUP
\r
32950 CAIE A,TRSUBR ; YES THIS IS ONE
\r
32953 ECHCK2: MOVE R,B ; SET UP R
\r
32954 HRRM C,FSAV+1(TB) ; SET POINTER INTO FRAME
\r
32955 HRRZ C,2(C) ; FIND OFFSET INTO SAME
\r
32956 SKIPL M,1(R) ; POINT TO START OF RSUBR
\r
32957 JRST STUPM1 ; JUMP IF A LOSER
\r
32959 JRST CALLS ; GO TO SR
\r
32961 ACHECK: CAIE A,TATOM ; RSUBR CALLING THROUGH REFERENCE ATOM ?
\r
32962 JRST DOAPP3 ; TRY APPLYING IT
\r
32966 HRRZ C,40 ; REGOBBLE POINTER TO SLOT
\r
32967 GETYP 0,A ; GET TYPE
\r
32970 SAVEIT: CAIE 0,TRSUBR
\r
32972 JRST SAVEI1 ; WINNER
\r
32976 JRST BADVAL ; SOMETHING STRANGE
\r
32977 SAVEI1: SKIPE NOLINK
\r
32979 MOVEM A,(C) ; CLOBBER NEW VALUE
\r
32982 JRST ENTRIT ; HACK ENTRY TO SUB RSUBR
\r
32983 MOVE R,B ; SETUP R
\r
32984 JRST CALLR0 ; GO FINISH THE RSUBR CALL
\r
32989 SUBRIT: SKIPE NOLINK
\r
32993 HRRM B,FSAV+1(TB) ; FIXUP THE PROPER FSAV
\r
32995 JRST CALLS ; GO FINISH THE SUBR CALL
\r
32997 TRYLCL: MOVE A,(C)
\r
33003 SKIPA D,EQUOTE UNBOUND-VARIABLE
\r
33004 BADVAL: MOVEI D,0
\r
33005 ERCAL: AOBJP TB,.+1 ; MAKE TB A LIGIT FRAME PNTR
\r
33007 HRRM E,FSAV(TB) ; SET A WINNING FSAV
\r
33008 HRRZ C,40 ; REGOBBLE POINTER TO SLOT
\r
33010 SUBI C,(R) ; CALCULATE OFFSET
\r
33012 ADD C,R ; MAKE INTO REAL RSUBR POINTER
\r
33013 PUSH TP,$TRSUBR ; SAVE
\r
33015 HRRZ C,40 ; REGOBBLE POINTER TO SLOT
\r
33021 PUSH TP,MQUOTE CALLER
\r
33023 MOVE C,(TP) ; GET SAVED RSUBR POINTER
\r
33024 SUB TP,[2,,2] ; POP STACK
\r
33029 BENTRY: MOVE D,EQUOTE BAD-ENTRY-BLOCK
\r
33032 ;HANDLER FOR CALL WHERE SPECIFIES NUMBER OF ARGS
\r
33035 LDB C,[270400,,40] ; GOBBLE THE AC LOCN INTO C
\r
33036 EXCH C,SAVEC ; C TO SAVE LOC RESTORE C
\r
33037 MOVE C,@SAVEC ; C NOW HAS NUMBER OF ARGS
\r
33038 MOVEI D,0 ; FLAG NOT E CALL
\r
33039 JRST COMCAL ; JOIN MCALL
\r
33041 ; CALL TO ENTRY FROM EVAL (LIKE ACALL)
\r
33043 DECALL: LDB C,[270400,,40] ; GET NAME OF AC
\r
33044 EXCH C,SAVEC ; STORE NAME
\r
33045 MOVE C,@SAVEC ; C NOW HAS NUM OF ARGS
\r
33046 MOVEI D,1 ; FLAG THIS
\r
33049 ;HANDLE OVERFLOW IN THE TP
\r
33051 TPLOSE: PUSHJ P,TPOVFL
\r
33054 ; RSUBR HAS POSSIBLY BEEN REPLACED BY A FUNCTION OR WHATEVER, DO AN APPLY
\r
33056 DOAPPL: PUSH TP,A ; PUSH THE THING TO APPLY
\r
33059 DOAPP2: JUMPGE AB,DOAPP1 ; ARGS DONE
\r
33066 DOAPP1: ACALL A,APPLY ; APPLY THE LOSER
\r
33069 DOAPP3: MOVE A,(C) ; GET VAL
\r
33071 JRST BADVAL ; GET SETUP FOR APPLY CALL
\r
33073 ; ENTRY TO BUILD A FRAME (USED BY SOME COMPILED PROG/REPEAT)
\r
33075 BFRAME: HRLI A,M ; RELATIVIZE PC
\r
33076 MOVEM A,PCSAV(TB) ; CLOBBER PC IN
\r
33077 MOVEM TP,TPSAV(TB) ; SAVE STATE
\r
33078 MOVEM SP,SPSAV(TB)
\r
33079 ADD TP,[FRAMLN,,FRAMLN]
\r
33081 PUSHJ TPOVFL ; HACK BLOWN PDL
\r
33082 MOVSI A,TCBLK ; FUNNY FRAME
\r
33084 MOVEM A,FSAV+1(TP) ; CLOBBER
\r
33085 MOVEM TB,OTBSAV+1(TP)
\r
33086 MOVEM AB,ABSAV+1(TP)
\r
33087 POP P,A ; RET ADDR TO A
\r
33092 \f;SUBROUTINE TERMINATION CODE (NOT A UUO BUT HERE FOR COMPLETENENSS)
\r
33095 CNTIN1: HRRZS C,OTBSAV(TB) ; RESTORE BASE
\r
33097 CONTIN: MOVE TP,TPSAV(TB) ; START HERE FOR FUNNY RESTART
\r
33099 CAME SP,SPSAV(TB) ; ANY RESTORATION NEEDED
\r
33100 PUSHJ P,SPECSTO ; YES, GO UNRAVEL THE WORLDS BINDINGS
\r
33101 MOVE AB,ABSAV(TB) ; AND GET OLD ARG POINTER
\r
33102 HRRZ C,FSAV(TB) ; CHECK FOR RSUBR
\r
33103 MOVEI M,0 ; UNSETUP M FOR GC WINNAGE
\r
33106 JRST @PCSAV(TB) ; AND RETURN
\r
33107 GETYP 0,(C) ; RETURN TO MAIN OR SUB ENTRY?
\r
33113 HRRI R,(C) ; RESET R
\r
33114 SKIPGE M,1(R) ; GET LOC OF REAL SUBR
\r
33118 FINIS1: CAIE 0,TRSUBR
\r
33119 JRST FINISA ; MAY HAVE BEEN PUT BACK TO ATOM
\r
33124 FINIS2: MOVEI C,(M) ; COMPUTE REAL M FOR PURE RSUBR
\r
33126 ADD M,PURVEC+1(TVP)
\r
33127 SKIPN M,1(M) ; SKIP IF LOADED
\r
33129 ADDI M,(C) ; POINT TO SUB PART
\r
33132 FINIS3: PUSH TP,A
\r
33134 HLRZ A,1(R) ; RELOAD IT
\r
33142 FINISA: CAIE 0,TATOM
\r
33149 MOVE B,1(C) ; GET ATOM
\r
33150 PUSHJ P,IGVAL ; GET VAL
\r
33162 BADENT: PUSH TP,$TATOM
\r
33163 PUSH TP,EQUOTE RSUBR-ENTRY-UNLINKED
\r
33166 PCANT1: ADD TB,[1,,]
\r
33167 PCANT: PUSH TP,$TATOM
\r
33168 PUSH TP,EQUOTE PURE-LOAD-FAILURE
\r
33172 BCKTR1: PUSH TP,A ; SAVE VALUE TO BE RETURNED
\r
33173 PUSH TP,B ; SAVE FRAME ON PP
\r
33180 ; SUBR TO ENABLE AND DISABLE LINKING OF RSUBRS AT RUN TIME
\r
33182 MFUNCTION %RLINK,SUBR,[RSUBR-LINK]
\r
33194 ;HANDLER FOR DEBUGGING CALL TO PRINT
\r
33220 DFATAL: MOVEM A,20
\r