00100	SUBTTL GARBAGE COLLECTER   --- PAGE 16
00200	
00300	GC:	PUSHJ P,AGC
00400		JRST FALSE
00500	
00600	AGC:	DAC R,RGC#
00700	GCPK1:	PUSH P,PA3
00800		PUSH P,PA4
00900		PUSH P,UBDPTR	;special atom UNBOUND; not on OBLIST
01000		PUSH P,MKNAM3
01100		PUSH P,GCMKL	;i/o channel INPOT lists and arrays
01200		PUSH P,BIND3
01300		PUSH P,INITF
01400	GCPK2:	PUSH P,[XWD 0,GCP6]	;this is a return address
01500	
01600	;save AC 0 thru 10 in (regPDL)+1 thru +11.
01700		lac  s,orgPDL
01800		addi s,11
01900		dap  s,.+2
02000		subi s,10
02100		blt  s,x
02200	;clear bit tables.
02300		lac a,orgHBT
02400		setzm (a)
02500		hrl a,a
02600		aos a
02700		lac endFBT
02800		dap .+1
02900		blt a,x
03000		setz ;indicate GC on CPU lights.
03100	;report what is exhausted.
03200		SKIPN GCGAGV
03300		JRST GCP5A
03400		SKIPN F
03500		STRTIP [SIXBIT /←FREE STG EXHAUSTED←!/]
03600		SKIPN FF
03700		STRTIP [SIXBIT /←FULL WORD SPACE EXHAUSTED←!/]
03800	;mark time of GC entry.
03900	GCP5A:	MOVEI TT,1 ;bit for marking.
04000		MOVEI A,0
04100		CALLI A,STIME	;time
04200		MOVNS A
04300		ADDM  A,GCTIM#
04400	;Initialize HBT referances.
04500		lacn A,orgHWS
04600		ash  A,-5
04700		add  A,orgHBT
04800		aos  A
04900		dap  A,GCBTP1
05000		dap  A,GCBTP2
05100		lac  A,orgFBT
05200		dap  A,C2GC
     

00100	;get a node off the PDL.
00200	GCP3:	LAC C,orgPDL	;start at the bottom of the PDL.
00300	GCP6B:	LAC S,P
00400		HLL C,P
00500		MOVEI B,0
00600	GC1:	CAMN C,S
00700		POPJ P,
00800		LAPZ A,(C)
00900	
01000	;Address Test for within LISP space.
01100	GCP:	CAMG  A,endFWS
01200		CAMGE A,orgHWS
01300		JRST GCEND
01400		CAMLE A,endHWS
01500		JRST GCMFWS
01600	
01700	;mark a LISP node of the halfword space.
01800		LAC F,(A)
01900		LSHC A,-5
02000		ROT B,5
02100		LAC AR1,GCBT(B)
02200	GCBTP2:	TDOE AR1,X(A)
02300		JRST GCEND
02400	GCBTP1:	DAC AR1,X(A)
02500		PUSH P,F
02600		LIPZ A,F
02700		JRST GCP
02800	
02900	;mark a full word.
03000	GCMFWS:	LAC  AR1,A
03100		SUB   AR1,orgFWS
03200		IDIVI AR1,44
03300		MOVNS AR2A
03400		LSH AR2A,36
03500		ADD AR2A,C2GC
03600		DPB TT,AR2A
03700	GCEND:	CAMN P,S
03800		AOJA C,GC1
03900		POP P,A
04000		HRRZS A
04100		JRST GCP
04200	
04300	GCMKL:	XWD 0,[XWD [XWD -NIOCH,CHTAB+FSTCH],0]
04400	C2GC:	XWD 430100+AR1,X	;.=bottom of fws bit table
04500	GCBT:	XWD 400000,0
04600	ZZ==1B1
04700	XLIST
04800	REPEAT ↑D31,<ZZ
04900	ZZ==ZZ/2>
05000	LIST
     

00100	GCP6:	LAPZ R,SC2
00200	GCP6C:	CAIL R,(SP)	;mark sp
00300		JRST GCP6A
00400		PUSH P,(R)
00500		LAPZ C,P
00600		PUSHJ P,GCP6B
00700		SUB P,[XWD 1,1]
00800		AOJA R,GCP6C
00900	
01000	GCP6A:	LAPZ R,GCMKL	;mark arrays
01100	GCP6D:	JUMPE R,GCSWP
01200		LIPZ A,(R)
01300		LAC D,(A)
01400	GCP6E:	PUSH P,(D)
01500		LAPZ C,P
01600		PUSH P,(D)
01700		MOVSS (P)
01800		PUSHJ P,GCP6B
01900		SUB P,[XWD 2,2]
02000		AOBJN D,GCP6E
02100		LAPZ R,(R)
02200		JRST GCP6D
02300	
     

00100	GFSWPP:
00200		JUMPL S,3	;0
00300		DAPZ F,(R)	;1   put R on Free List.
00400		LAPZ F,R	;2
00500		LSH S,1		;3   next bit.
00600		AOBJN R,0  	;4   address next word.
00700		LAC S,(D)	;5   get more bits from HBT.
00800		HRLI R,-40	;6   set bit counter.
00900		AOBJN D,0    	;7   increm HBT pointer.
01000		JRST X		;10  return from AC's.
01100				;11  S word from HBT.
01200				;12  D -wrdcnt,,HBT ptr.
01300				;13  R -bitcnt,,HWS ptr.
01400				;14  P
01500				;15  F free storage list.
01600	
01700	;garbage collector sweep
01800	
01900	GCSWP:	MOVSI R,GFSWPP
02000		BLT R,10
02100		MOVEI F,NIL	;will become movei f,-1
02200		lacn D,sizHBT
02300		hrlz D,D
02400		lap  D,orgHBT
02500	
02600		lac R,orgHWS
02700		andi R,37
02800		dap  R,GCBTL2
02900		subi R,↑D32
03000		hrlz R,R
03100		lap R,orgHWS
03200		LAC S,(D)
03300	GCBTL2:	ROT S,X
03400		hrri 10,.+2
03500		AOBJN D,0
03600	
03700		lacn A,sizFWS
03800		movss A
03900		lap A,orgFWS
04000		lac B,endHBT
04100		hrli B,100
04300	
04400		MOVEI FF,0
04500	GCS1:	ILDB C,B
04600		JUMPN C,GCS2
04700		DAPZ FF,(A)
04800		LAPZ FF,A
04900	GCS2:	AOBJN A,GCS1
     

00100		SKIPN GCGAGV
00200		JRST GCSP1
00300		LAC B,F
00400		PUSHJ P,GCPNT
00500		STRTIP [SIXBIT / FREE STG,!/]
00600		LAC B,FF
00700		PUSHJ P,GCPNT
00800		STRTIP [SIXBIT / FULL WORDS AVAILABLE←!/]
00900	GCSP1:	LAPZ  S,orgPDL
01000		AOS S
01100		MOVSS s
01200		BLT S,NACS+3	;reload ac's
01300		SUB P,[XWD GCPK2-GCPK1,GCPK2-GCPK1]	;restore p
01400		JUMPE F,[ERR2 [SIXBIT /NO FREE STG LEFT!/]]
01500		JUMPE FF,[ERR2 [SIXBIT /NO FW STG LEFT!/]]
01600		LAC R,RGC
01700		MOVEI A,0
01800		CALLI A,STIME	;time
01900		ADDM A,GCTIM
02000		POPJ P,
02100	
     

00100	;Garbage Collector Statistics.
00200	
00300	GCGAG:	EXCH A,GCGAGV#
00400		POPJ P,
00500	
00600	GCTIME:	LAC A,GCTIM
00700		JRST FIX1A
00800	
00900	TIME:	MOVEI A,0
01000		CALLI A,STIME
01100		JRST FIX1A
01200	
01300	SPEAK:	LAC A,CONSVAL#
01400		JRST FIX1A
01500	
01600	GCPNT:	MOVEI R,TTYO
01700		MOVEI A,0
01800		JUMPE B,PRINL1
01900		LAPZ B,(B)
02000		AOJA A,.-2
     

00100	SUBTTL GETSYM     --- PAGE 17
00200	
00300	R50MAK:	PUSHJ P,PNAMUK
00400		PUSH C,[0]
00500		HRLI C,700
00600		HRRI C,(SP)
00700		MOVEI B,0
00800	MK3:	ILDB A,C
00900		LDB A,R50FLD
01000		CAMGE B,[50*50*50*50*50]
01100		SKIPN A
01200		POPJ P,
01300		IMULI B,50
01400		ADD B,A
01500		JRST MK3
01600	
01700	GETSYM:	PUSHJ P,R50MAK
01800		TLO B,040000	;04 for globals
01900		LAC C,JOBSYM
02000	MK7:	CAMN B,(C)
02100		JRST MK10	;found
02200		AOBJP C,.+2
02300		AOBJN C,MK7
02400		TLC B,140000	;10 for locals
02500		TLNE B,100000
02600		JRST MK7-1
02700		JRST FALSE
02800	
02900	MK10:	LAC A,1(C)	;value
03000		JRST FIX1A
03100	
03200	PUTSYM:	PUSH P,B
03300		PUSHJ P,R50MAK
03400		LAC A,B
03500		TLO A,040000	;make global
03600		SKIPL JOBSYM
03700		AOS JOBSYM	;increment initial symbol table pointer
03800		MOVN B,[XWD 2,2]
03900		ADDB B,JOBSYM
04000		DAC A,(B)	;name
04100		POP P,1(B)	;value
04200		JRST FALSE
04300	
04400	PATCH:	BLOCK 200
     

00100	SUBTTL ALVINE AND LOADER INTERFACES   --- PAGE 18
00200	
00300	;interface to alvine
00310	EXTERN EDXX
00400	
00500	ED:	MOVEI 10,EDXX
00600		JRST (10)
02000	
02100	GRINDEF: PUSH P,A
02200		PUSHJ P,ED
02300		POP P,A
02400		JRST 2(10)
02500	
02600	EXCISE:	JRST TRUE
03400	
03500	XLIST
03600	VAR
03700	LIT
03800	LIST
     

03100	SYSINI:	DAC A,NAME+1
03200		SETZM NAME+3
03300		INIT 17
03400		SIXBIT /SYS/
03500		0
03600		JRST AIN.4+1
03700		LOOKUP NAME
03800		JRST AIN.7+1
03900		INPUT [IOWD 1,NAME+3	;INPOT size of file
04000			0]
04100		HLRO A,NAME+3
04200		POPJ P,
04300	
04400	NAME:	SIXBIT /LISP/
04500		0
04600		0
04700		0
04800	
04900	SYSINP:	DAC A,LST
05000		INPUT LST
05100		STATZ 740000
05200		ERR1 AIN.8
05300		RELEASE
05400		POPJ P,
05500	
05600	LST:	0
05700		0
     

00100	;Size argument taken from A, pointer returned in A.
00200	MORCOR:	DAC 0,LISPAC
00300		LAC 0,[XWD 1,LISPAC+1]
00400		BLT 0,LISPAC+17
00500		LAC 3,A
00600		LAC 12,AC12
00700		LAC 16,AC16
00800		LAC 17,AC17
00900		PUSHJ 17,CORGET
01000		OUTSTR[ASCIZ/NO MORE CORE./]
01100		LAC A,2
01200		LAC 0,[XWD LISPAC+2,2]
01300		BLT 0,17
01400		LAC 0,LISPAC
01500		POPJ P,
     

     

00100	;SAIL TO LISP.
00200		INTERN LISP
00300		EXTERN CORGET
00400	;ACCUMULATOR-2	POINTER TO FIRST WORD OF SAIL MEMORY BLOCK.
00500	;ACCUMULATOR-3  SIZE OF SAIL MEMORY BLOCK.
00600	LISP:	DAC 0,AC0
00700		LAC 0,[XWD 1,AC1]
00800		BLT 0,AC17
00900		LAC 3,-1(17)
01000		PUSHJ 17,CORGET
01100		JFCL
01200	;JSR ALLOCD ;Allocation dialogue.
01300	OUTSTR [ASCIZ/
01400	/]
01500		
01600	;Bottom, Size & Top of LISP memory space.
01700		lac B,2
01800		lac S,3
01900		lac T,B
02000		addi T,-1(S)
02100	
02200	;Take BPS off the bottom
02300		dac B,orgBPS
02400		add B,sizBPS
02500		dac B,endBPS
02600		sos   endBPS
02700		sub S,sizBPS
02800	
02900	;Take SPD off the top.
03000		dac T,endSPD
03100		sub T,sizSPD
03200		dac T,orgSPD
03300		aos   orgSPD
03400		sub S,sizSPD
03500	
03600	;Compute FWS size ← 400+S/16.
03700		lac  A,S
03800		ash  A,-4
03900		addb A,sizFWS
04000	
04100	;Compute FBT size.
04200		idivi A,44
04300		aos A
04400		dac A,sizFBT
04500	
04600	;Compute PDL size.
04700		lac A,S
04800		ash A,-6
04900		addm A,sizPDL
     

00100	;Compute size of Halfword Bit Table and Half Word Space.
00200		sub S,sizFBT
00300		sub S,sizFWS
00400		sub S,sizPDL
00500		lac A,S
00600		idivi A,41
00700		aos A
00800		dac A,sizHBT
00900		sub S,A
01000		dac S,sizHWS
01100	
01200	;Take Half Word Space, HWS, off the bottom.
01300		lac T,endBPS
01400		movei B,1(T)
01500		dac B,orgHWS
01600		add B,sizHWS
01700		add T,sizHWS
01800		dac T,endHWS
01900	
02000	;allocate Full Word Space, FWS above HWS.
02100		dac B,orgFWS
02200		add B,sizFWS
02300		add T,sizFWS
02400		dac T,endFWS
02500		
02600	;allocate Halfword Bit Table, HBT above FWS.
02700		dac B,orgHBT
02800		add B,sizHBT
02900		add T,sizHBT
03000		dac T,endHBT
03100		
03200	;allocate Fullword Bit Table, FBT above HBT.
03300		dac B,orgFBT
03400		add B,sizFBT
03500		add T,sizFBT
03600		dac T,endFBT
03700		
03800	;allocate Push Down List, PDL above FBT.
03900		dac B,orgPDL
04000		add B,sizPDL
04100		add T,sizPDL
04200		dac T,endPDL
     

00100	;Initialize the values of the BPORG & BPEND atoms.
00200		LAC A,orgBPS
00300		ADDM A,VBPORG	;value of BPORG.
00400		LAC A,endBPS
00500		ADDM A,VBPEND	;value of BPEND.
00600	
00700	;Setup Special PDL pointer.
00800		LACN A,SIZSPD
00900		hrlz A,A
01000		lap A,orgSPD
01100		sos A
01200		dac A,SC2
01300	
01400	;lowest word of PDL holds pointer to OBLIST.
01500		LAC B,orgPDL
01600		LAC A,orgHWS
01700		DAC A,(B)
01800	
01900	;setup regular PDL pointer.
02000		ADDI B,12
02100		DAP B,C2
02200		LACN C,SIZPDL
02300		ADDI C,20
02400		DIP C,C2
02500	
02600	;Fixup references to HWS.
02700		lac FF,orgHWS
02800		subi FF,OBLIST	;HWS displacement.
02900		MOVEI C,FOOLST
03000	REL5:	LAC B,(C)
03100		LAPZ A,(B)
03200		ADD A,FF
03300		DAP A,(B)
03400		LIP B,B
03500		LAPZ A,(B)
03600		ADD A,FF
03700		DAP A,(B)
03800		CAIGE C,EFOLST-1
03900		AOJA C,REL5
     

00100	;Blit prenatal FWS into its allocated space.
00200	
00300		hrli A,BFWS		;from here.
00400		lap  A,orgFWS		;to there.
00500		hrrzi B,EFWS-BFWS(A)	;new top+1.
00600		blt A,(B)
00700	
00800	;Move prenatal HWS into its allocated space.
00900	
01000		movei F,OBLIST		;from here.
01100		lac   T,orgHWS		;to there.
01200		lac  B,orgHWS
01300		subi B,OBLIST		;HWS displacement.
01400		lac  C,orgFWS
01500		subi C,BFWS		;FWS displacement.
01600	
01700	;Relocate CAR portion of a word.
01800	REL1:	lipz A,(F)
01900		caig  A,EFWS
02000		caige A,OBLIST
02100		jrst .+5	; A too high or low.
02200		move  D,B	; A ≥ OBLIST.
02300		cail A,BFWS
02400		lac  D,C	; A ≥ BFWS.
02500		add  A,D
02600		dip A,(T)
02700	
02800	;Relocate CDR portion of a word.
02900		lapz A,(F)
03000		caig  A,EFWS
03100		caige A,OBLIST
03200		jrst .+5	; A too high or low.
03300		move  D,B	; A ≥ OBLIST.
03400		cail A,BFWS
03500		lac  D,C	; A ≥ BFWS.
03600		add  A,D
03700		dap A,(T)
03800	
03900	;advance From and To Pointers.
04000		aos F
04100		caige F,BFWS
04200		aoja  T,REL1
04300	
04400		setzb F,DDTIFG
04500		JSR IOBRST
04600		JRST START
04700	XLIST
04800		LIT
04900		VAR
05000	LIST
     

00100	;The FOO list is for fixing up references to HWS.
00200	
00300	I=0
00400	DEFINE GARP (A,B)
00500	<XWD FOO'A,FOO'B>
00600	
00700	FOO	0
00800	FOOLST:
00900	XLIST
01000	REPEAT <FOOCNT/2>,<
01100	GARP (\I,\<I+1>)
01200	I=I+2>
01300	LIST
01400	
01500	EFOLST:
01600	
01700	DEFINE MKENT (A)<
01800	INTERNAL A>
01900	
01950	MKENT <MEMQ,UNBOUN>
02000	MKENT <EVBIG,NUMBP2,OPOV,NUMV2,NUMV3,NUMV4,OPR,FLOOV,FIX2>
02100	MKENT <NUM1,NUM3,BPR,FWCONS,FALSE,TRUE,FW0CNS,NCONS>
02200	MKENT <READ,READP1,MAKNUM,PRIN1,PRINT,EXPLODE,SASSOC,EQUAL,SOBST>
02300	MKENT <CHCT,LINL,OLDCH,FLATSIZE,TYI,RATOM,CHRCT,TYOD>
02400	MKENT <GET,INTERN,REMOB,MAKNAM,GENSYM,FIX,LENGTH,READLIST,PATOM>
02500	MKENT <LAST,INC,OUTC,FIX1A,NUMVAL,REVERSE,MAPLIST,GC,GETL,PUTPROP>
02600	MKENT <ERR,MAPCAR,REMPROP,LIST,SETQ,ERRSET,REMOB,ARRAY,APPEND>
02700	MKENT <SPECBIND,SPECSTR,XCONS,ATOM,READCH,SET,NCONC,PRINC>
02800	MKENT <CONS,ACONS,CTY,FP7A1,TERPRI,LSPRET,PSAV1,BKTRC>
02900	MKENT <TYO,ITYO,IGSTRT,NOINFG,CHRTAB>
03000	MKENT <EVAL,OEVAL,.APPEND,INPOT,OUTPUT>
03100	
03200	END