COMPIL(SGC,<STRNGC,STRGC,STCLER,SGINS,SGREM,%SPGC1,%ARSR1,.SONTP>
	   ,<.SGCIN,GOGTAB,X11,CORGET,CORREL,CORINC,X22,CORBIG,SPRPDA,INSET>
	   ,<STRING GARBAGE COLLECTOR ROUTINES>
	   ,<%SPGC,%STRMRK,%ARRSRT>)
NOLOW <
MLT←←=16  BKSZ←←5*MLT+1		;BKSZ must always be so related to MLT
↑.CORERR:
	CORERR	<NO CORE FOR ALLOCATON>
HERE (STRGC)
	EXCH	A,-1(P)		;THE DESIRED A IS HERE
	MOVE	USER,GOGTAB
	MOVEM	RF,RACS+RF(USER);SAVE F REGISTER WHERE GC CAN FIND.
	PUSHJ	P,STRNGC	;COLLECT TRASH
	SUB	P,X22		;BACK UP STACK
	MOVNS	A
	ADDM	A,REMCHR(USER)
	MOVE	A,1(P)		;GET ORIGINAL "A" BACK
	JRST	2,@2(P)		;RETURN
HEREFK(.SONTP,..SONT)
	BEGIN 	SONTP
DEFINE CANON (ADR,AC)<
	LDB	TEMP,[POINT 3,ADR,5]	;4,5,6,7,0,1 FROM POSITION
	IMULI	AC,5			;ADDR IN CHARS
	ADD	AC,BPTBL(TEMP)		;0,1,2,3,4,5 EXTRA CHARS
>
	MOVE	USER,GOGTAB
	PUSH	P,A
	PUSH	P,B
	PUSH	P,C
	PUSH	P,D
	MOVE	A,-5(P)	;CNT
	ADDM	A,REMCHR(USER)	;TEST GCING LATER
	HRRZ	D,-1(SP)	;LOAD LENGTH
	HRRZ	B,(SP)
	CANON	<(SP)>,B	;STANDARD FORM 
	ADD	B,D		;ADD LENGTH
	HRRZ	C,TOPBYT(USER)
	CANON	<TOPBYT(USER)>,C
	CAMN	B,C		;SAME??
ISONTP:	SKIPLE	REMCHR(USER)	;GC NEEDED??
	JRST	NOTONT		;MAY WIND UP COPYING
XIT:	POP	P,D		;FINISH
	POP	P,C
	POP	P,B
	POP	P,A		
	SUB	P,X22
	JRST	@2(P)
NOTONT:				;ALWAYS GET ENOUGH TO COPY STRING
	HRRZ	D,-1(SP)	;GET LENGTH OF STRING
	ADD	A,D
	ADDM	D,REMCHR(USER)
	SKIPG	REMCHR(USER)	;REALLY GC ??
	JRST	CPYSTR		;NO REAL NEED
	PUSHJ	P,STRNGC	;GARBAGE IS COLLECTED
	HRRZ	B,(SP)
	CANON	<(SP)>,B	;ON TOP NOW ??
	ADD	B,D
	HRRZ	C,TOPBYT(USER)	
	CANON	<TOPBYT(USER)>,C
	CAME	B,C		;WELL
	JRST	CPYSTR		;NO, MUST COPY
	MOVN	D,D		;GIVE BACK CHARS GET FROM NOT COPYING
	ADDM	D,REMCHR(USER)	;
	JRST	XIT		;DONE
CPYSTR:	
	SKIPE	SGLIGN(USER)	;NEED FW BNDRY??
	PUSHJ	P,INSET		;YES
	MOVE	B,TOPBYT(USER)	;NEW STRING BP
	EXCH	B,(SP)
	JUMPE	D,XIT		;DONE ??
	ILDB	C,B		;COPY CHARS
	IDPB	C,TOPBYT(USER)
	SOJG	D,.-2		;
	JRST	XIT		;DONE
BPTBL:	4
	5
	0
	0
	0
	1
	2
        3				;MAP
BEND SONTP
HERE(STRNGC)
	MOVE	USER,GOGTAB
	CAME	RF,RACS+RF(USER)	;ALL RUNTIMES SHOULD BOTH
	 ERR	 <DRYROT -- RF (R12) not saved in RACS at STRNGC>
	MOVEM	RF,RACS+RF(USER)	;WILL RESTORE AFTER SORTING ROUTINES
	SKIPN	SGCTIME(USER)	;User can
	 JRST	 SGC1
	MOVEI	TEMP,0		;TIME SG STARTS
NOTENX <
	CALL6	(TEMP,MSTIME)
	MOVNM	TEMP,SGCTIME(USER)
>;NOTENX
TENX <
	MOVEM	1,SGCTIME(USER)		;SAVE 1 & 2
	MOVE	TEMP,2			;"TIME" GIVES TIME IN 1, DIVISOR
	JSYS	TIME			;TO GET SECONDS IN 2 (ALWAYS
	MOVNS	1			;1000 SO FAR)
	EXCH	1,SGCTIME(USER)		;BUT SHOULD THIS REALLY BE TIME
	MOVE	2,TEMP			;OF DAY, NOT BILLABLE RUNTIME?
>;TENX
SGC1:	MOVEM	11,SGACS+11(USER)
	MOVEI	11,SGACS(USER)
	BLT	11,SGACS+10(USER)
	AOS	TEMP,SGCCNT(USER)	;COUNT TIMES THROUGH GC
	MOVNM	TEMP,SGCCNT(USER)	;INDICATE THAT GC IS IN PROGRESS
	SKIPN	.SGCINT
	 JRST	 NOTRP
	PUSH	P,A			;SIZE OF REQUEST
	PUSH	P,0			;CONVENTION IS 4 PARAMS
	PUSH	P,SGCCNT(USER)
	PUSH	P,0			;SO PUSH SOME [CENSORED] UP
	PUSHJ	P,@.SGCINT
NOTRP:
	HRRZ	TEMP,TOPBYTE(USER) ;MAKE SURE DIDN'T OVERFLOW
	CAMG	TEMP,STTOP(USER)
	CAMGE	TEMP,ST(USER)
	 ERR	 <TOPBYTE out of range at STRNGC -- will continue>,1
CALSG:	MOVEI	T,SGROUT(USER)		;GET LINKED LIST OF ROUTINE NAMES
	PUSH	P,T			;SAVE FIRST POINTER
	PUSH	P,[SGSORT]		;PROVIDE ACCESS TO SORTING ROUTINE
↑CALSGL:
	SKIPN	T,@-1(P)		;GO DOWN LIST UNTIL DONE
	JRST	ALLCOL			;DONE
	HRRZM	T,-1(P)			;SAVE NEW POINTER
	PUSHJ	P,@-1(T)		;CALL GENERATOR ROUTINE
	MOVE	RF,RACS+RF(USER)	;GET GOOD F BACK, ASSUMING GOOD USER
	JRST	CALSGL			;DO MORE THAN ONCE
ALLCOL:	SUB	P,X22			;Remove temp, SGSORT address
SGSWEP:	MOVEI	C,BKSZ
	PUSHJ	P,CORGET
STCORERR: ERR  <String garbage collector can't get core>
	MOVEM	B,STBUCK(USER)
	MOVE	B,STLIST(USER)		;Loop through all string spaces, 
	SETZM	SGCNUM(USER)		;Strings handled count (not incl. const.)
SPCLUP:	PUSHJ	P,SRTSPC		; sorting.  When through, .LIST
	SKIPE	B,.NEXT(B)		; in the header of each space
	 JRST	 SPCLUP			; will be the sorted dscrptr lst.
	MOVE	B,STBUCK(USER)	;Release the buckets (STBUCK=OFFSET, see blow).
	PUSHJ	P,CORREL
	MOVE	B,STLIST(USER)
	MOVE	C,B
	PUSHJ	P,DSTSET
SWPLUP:	PUSHJ	P,SOURCE	;Identify a source "nest", return params
	 JRST	 SWPDUN		; and adjust descriptors, no-skip when done
	PUSHJ	P,DEST		;Identify a destination location, move the
	JRST	SWPLUP		; source nest there, and re-create all 
SWPDUN:
	HLRZ	D,STREQD(USER)		;Requested char count +
	ADD	D,SGACS+A(USER)		; STREQD (see p. 2) char count.
	MOVE	E,D
GRANT:	ADD	D,REMCHR(USER)		;Granted, if total required
	JUMPL	D,GRANTED		; space exists in last DEST
	PUSHJ	P,WASTE			;Add up wasted space in DEST being left.
	MOVE	A,C			;Save space being abondoned
	SKIPN	C,.NEXT(C)		; space.  Otherwise, move
	 JRST	 EXPSTR			; to next space, if any, and
GRTSET:	PUSHJ	P,DSTSET		; continue to try to grant 
	MOVE	D,E			; request
	JRST	GRANT
EXPSTR:	HLRZ	C,STINCR(USER)		;STINCR (see p. 2) char count.
	CAML	E,C			;Is there going to be room?
	 ERR	 <String space expansion: request too big>
	HRRZ	C,STINCR(USER)		;STINCR  word count, + .HDRSIZ
	PUSHJ	P,CORGET
	 JRST	 [PUSHJ P,CORBIG	;If for some reason we can't get
		  MOVEI B,.HDRSIZ+1(C)	; STINCR words, make sure that
		  IMULI B,5		; a new block can at least satisfy
		  CAMGE B,E		; the request + STREQD.
		   ERR <String GC: no core to expand string space>
		  PUSHJ P,CORGET	;Will do, get it
		   ERR <DRYROT -- unexpected STRNGC core problem>
		  JRST .+1]
	MOVEI	B,.HDRSIZ(B)		;Adjust pointer to leave header,
	SUBI	C,.HDRSIZ		; set up header area parameters,
	MOVEM	C,.STTOP(B)		; link to previous area
	MOVEM	C,.SIZE(B)
	ADDM	B,.STTOP(B)
	SETZM	.NEXT(B)
	SETZM	.LIST(B)
	MOVEM	B,.NEXT(A)
	MOVE	C,B			;This becomes last destination
	JRST	GRTSET			;Go satisfy request, now guaranteed.
GRANTED:HRRZM	C,ST(USER)		;Update ST, STTOP, release any
	MOVE	TEMP,.STTOP(C)		; spaces made unnecessary by diminished
	MOVEM	TEMP,STTOP(USER)	; active strings
	SKIPN	A,.NEXT(C)		;Get next space past last DEST, if any,
	 JRST	 STSTAT			; then clear any next space pointers.
	SETZM	.NEXT(C)
RELLUP:	MOVEI	B,-.HDRSIZ(A)		;Release any spaces which are
	MOVE	A,.NEXT(A)
	PUSHJ	P,CORREL		; apparently no longer necessary.
	JUMPN	A,RELLUP
STSTAT:				;Check that Full-word alignment produced
	SKIPE	SGLIGN(USER)	;Alignment also implies clearing
	 PUSHJ	 P,RESCLR	;Free space
	MOVEI	B,=15		;Update REMCHR by initial request, plus a
	ADD	B,SGACS+A(USER)	; bit of slop (NOT by STREQD, which specifies
	ADDB	B,REMCHR(USER)	; free space -- slop is unfree, for safety.)
	JUMPGE	B,[ERR <DRYROT -- String GC Surprised at Untoward Occurrence>]
	MOVMS	SGCCNT(USER)	;Now indicate done with GC
	SKIPN	SGCTIME(USER)	;Timing active?
	 JRST	 NOTIME		;No
	MOVEI	TEMP,
NOTENX <
	CALL6	(TEMP,MSTIME)	;Collect GC times
>;NOTENX
TENX <
	EXCH	1,TEMP
	PUSH	P,2
	JSYS	TIME
	POP	P,2
	EXCH	1,TEMP
>;TENX
	ADDB	TEMP,SGCTIME(USER)
	ADDM	TEMP,SGCTOTAL(USER)
NOTIME:
	SKIPN	.SGCINT
	 JRST	 QUITGC
	MOVN	TEMP,REMCHR(USER);SIZE OF GRANT, LESS ORIGINAL REQUEST
	PUSH	P,TEMP
	PUSH	P,SGACS+1(USER)	;ORIGINAL REQUEST
	PUSH	P,SGCCNT(USER)	;AS FAR AS I CAN TELL, JUST USING UP CELLS
	PUSH	P,SGCNUM(USER)	; IN THE CALL STACK
	PUSHJ	P,@.SGCINT
QUITGC:	MOVE	USER,GOGTAB	;PARANOID
	HRLZI	11,SGACS(USER)	;Restore and return
	BLT	11,11
	POPJ	P,
SGSORT:	HLLZ	B,(A)		;don't collect constants
	JUMPE	B,SGRST
	HRRZ	TEMP,1(A)
	MOVEI	B,STLIST-.NEXT(USER)
SGLUP1:	SKIPN	B,.NEXT(B)
	 JRST	 NORANGE	;Range exhausted, bad string
	CAML	TEMP,B		;Address check of string bp
	CAML	TEMP,.STTOP(B)	; against both ends of each 
	 JRST	 SGLUP1		; space determines if string in range
INRANGE:SUB	TEMP,B		;Convert bp to space-relative
	IMULI	TEMP,5		; character count
	HLLZ	C,1(A)
	TLNN	C,777770	;Make sure there are still byte ptr. bits
	 JRST	 [MOVE A,A	;ERR type 7 gets AC # from here
		  ERR <SGSORT-- string encountered twice, descriptor addr = >,7
		  JRST SGRST]	;Don't handle again.
	HRRI	C,[BYTE(7) 0,1,2,3,4,5]
	ILDB	C,C		;Space-relative count fits in
	ADD	C,TEMP		; rh, lh 0 signals
	MOVEM	C,1(A)		; re-encounter (above)
	MOVE	C,.LIST(B)	;Insert descriptor, linked by
	HRLM	C,(A)		; string number field, into
	HRRZM	A,.LIST(B)	; list for this space
	JRST	SGRST
NORANGE:MOVE	A,A		;String not in range, complain, NULL it,
	ERR	<String GC: Descriptor byte ptr. out of bounds, Addr. is >,7
	SETZM	(A)		; and go on.
SGRST:	ADDI	A,2		;Auto-increment descriptor index
	POPJ	P,
HERE(%SPGC)	HRRZ	A,SPDL(USER)	;START AT BASE OF STACK
↑%SPGC1:ADDI	A,1
	JRST	SGTST		;AND WORK UP TO CURRENT POINTER
STRNGSTACKMARKLOOP:
	PUSHJ	P,SGSORT	;SORT IT INTO LIST
SGTST:
	CAIGE	A,(SP)		;DONE?
	 JRST	 STRNGSTACKMARKLOOP ;NO
GPOPJ:	POPJ	P,		;YES, GO ON TO NEXT TYPE
HERE (%STRMRK)
	SKIPN	T,STRLNK(USER)	;GET LINK
	 POPJ	 P,		; NO STRINGS AT ALL
STMKL1:	HRRZ	A,-1(T);<	;=>1ST STRING
	HLRZ	Q2,-1(T)	;# STRINGS THIS PROC
	JRST	SOJLP		;GO LOOP
STMKLP:	PUSHJ	P,SGSORT	;SORT VARIABLES INTO LIST
SOJLP:	SOJGE	Q2,STMKLP	;SORT UNTIL DONE WITH THIS PROC (SGSORT INCRS A)
STRMK4:	HRRZ	T,(T)		;NEXT PROCEDURE
	JUMPN	T,STMKL1	; IF THERE IS ONE
	POPJ	P,		;DONE
INTERNAL %ARRSRT
HERE (%ARRSRT)
↑%ARSR1:
PROCDO:	HLRZ	Q1,1(RF)	;FETCH PDA
	CAIN	Q1,SPRPDA	;IS IT SPROUTER??
	POPJ	P,		;YES
	MOVE	Q1,PD.LLW(Q1)	;WE HAVE TO DO SOMETHING -- PT AT LVI
CHK:	SKIPN	T,(Q1)		;GET ENTRY
	JRST	GODOWN		;0 MEANS OF PROC DESCR
	TLC	T,100000	;TYPE 2? (STRING ARRAY)
	TLNE	T,740000	;
	AOJA	Q1,CHK		;NO
	SKIPN	A,@T		;THERE??
	AOJA	Q1,CHK		;NO
	SUBI	A,1;<		;A=>2D WORD, FIRST ENTRY -- DCS 5-3-72
	SKIPL	Q2,-1(A)	;BETTER BE THERE
	ERR	<DRYROT at Arrsrt>
	PUSHJ	P,ARPUTX	;GO SORT IT
	AOJA	Q1,CHK
GODOWN:	HRRZ	RF,(RF)		;NOTE THAT RESTR WILL PUT RF BACK
	CAIE	RF,-1		;
	JRST	PROCDO 		;-1 WILL SAY END
LARR:	SKIPN	E,ARYLS(USER)	;LEAPING LISTS
	POPJ	P,		;NONE
LAR1:	
	HLRZ	Q2,(E)		;GET ADDRESS
	MOVEI	A,-1(Q2);<	;A=>1ST WORD, FIRST ENTRY
	SKIPL	Q2,-2(Q2)		;BE SURE
	ERR	<DRYROT -- LEAPing error at ARRSRT>
	PUSHJ	P,ARPUTX	;GO SORT IT
LAR2:	HRRZ	E,(E)		;MERRILY WE LINK ALONG
	JUMPN	E,LAR1		;
	POPJ	P,		;HOME AT LAST
ARPUTX:	
	HRRZS	Q2		;YES, GET TOTAL SIZE
	LSH	Q2,-1		;NUMBER OF STRINGS
	JRST	ARSLP
ARS3:	PUSHJ	 P,SGSORT	; BUT COLLECT NON-CONSTANTS 
ARSLP:	SOJGE	Q2,ARS3		;A INCREMENTED IN SGSORT, LOOP UNTIL DONE
	POPJ	P,		;ALL DONE WITH THIS ARRAY.
SRTSPC:	MOVE	A,STBUCK(USER)	;Clear bucket list
	SETZM	(A)
	ADDI	A,1
	HRLI	A,-1(A)
	MOVEI	C,BKSZ-2(A)
	BLT	A,(C)
	SKIPN	A,.LIST(B)
	 JRST	 SORTED
DSCLUP:	AOS	SGCNUM(USER)	;Count strings handled.
	HLRZ	FF,(A)
	MOVE	C,1(A)
	MOVE	E,C		;For later (below)
	IMULI	C,MLT
	IDIV	C,.SIZE(B)	;Compute bucket entry
	ADD	C,STBUCK(USER)	; (partition space among bckts)
	MOVE	Q1,C
	HRRZ	T,(A)
SGSLUP:	MOVE	D,C
	HLRZ	C,(C)
	JUMPE	C,[HRRM A,(Q1)	;** NEW will be end string,
		   JRST INSERT]	;    keep track of it for linkage
	CAMGE	E,1(C)
	 JRST	 INSERT		;NEW begins before NEXT, insert
	CAME	E,1(C)
	 JRST	 SGSLUP		;NEW begins after NEXT, keep looking
	HRRZ	TEMP,(C)
	CAMG	T,TEMP		;Insert by descending length
	 JRST	 SGSLUP
INSERT:	HRLM	A,(D)
	HRLM	C,(A)		;Link is in lh of word 2 of descriptor
	MOVE	A,FF
	JUMPN	A,DSCLUP
SORTED:	MOVE	C,STBUCK(USER)	;Starting at the end of the bucket
	HRLI	C,D		; array, look only at non-zero
	MOVEI	D,BKSZ-1	; entries.  Each iteration, retain
	MOVEI	A,0		; the newest <first> pointer, having
LNKLUP:	SKIPN	E,@C		; placed the previous <first> pointer
	 JRST	 AOCHK		; into the list identified by the
	HRLM	A,(E)		; newest <last> pointer.  The first
	HLRZ	A,E		; <first> pointer is 0
AOCHK:	SOJGE	D,LNKLUP
	MOVEM	A,.LIST(B)
	POPJ	P,
SOURCE:	MOVE	E,.LIST(B)
	JUMPE	E,[SKIPN B,.NEXT(B)
		   POPJ P,		;no-skip, return
		   JRST SOURCE]
	MOVE	Q1,1(E)
	IDIVI	Q1,5
	ADD	Q1,B
	HLL	Q1,[PTBL1: POINT 7,0	;!HOOK! IF PTBL OF SUBSTR AVAIL, 
		    POINT 7,0,6		; declare it external and use it
		    POINT 7,0,13	; here -- tables are the same
		    POINT 7,0,20
		    POINT 7,0,27
		    POINT 7,0,35](Q2)
	PUSH	P,Q1
	HRLS	E
	MOVN	A,1(E)
	HRRZ	D,(E)
	SUB	D,A
	ADDM	A,1(E)		;Adjust 1st descr. location count to nest-rel.
SRCLUP:	HLRZ	Q1,(E)		;Next elt.
	JUMPE	Q1,NONEST	;If end-loc in D does not reach the next
	CAMG	D,1(Q1)		; descriptor's location, nest is done
	 JRST	 NONEST		;(Adjoining, non-overlapping nests must be
	HRRZ	TEMP,(Q1)
	ADD	TEMP,1(Q1)	; moved separately because of full-word reqmt.
	CAMGE	D,TEMP		;Adjust nest-end location, if new string
	 MOVE	 D,TEMP		; extends beyond old nest
	ADDM	A,1(Q1)		;Adjust location count to nest-relative.
	HRR	E,Q1		;Will be last descriptor in nest at NONEST
	JRST	SRCLUP
NONEST:	HRRZM	Q1,.LIST(B)	;Update list, retrieve BP, compute length,
	HRRZS	(E)		;Clear last elt in nest
	HLRZS	E		;Return ptr. to 1st, as advertised
	ADD	D,A		; skip-return as advertised
	POP	P,A
	AOS	(P)
	POPJ	P,
DEST:	MOVE	Q1,D		;SAVE LENGTH
DEST1:	SKIPN	SGLIGN(USER)
	 JRST	 NOLIGN
	PUSHJ	P,INSET			;Inset aligns TOPBYTE to full word,
	PUSH	P,D+1			; but it should already be there really.
	ADDI	D,4			;Move smallest multiple of 5 characters
	IDIVI	D,5			; which hold nest.
	IMULI	D,5
	POP	P,D+1
NOLIGN:	ADDM	D,REMCHR(USER)		;Standard room test
	SKIPGE	REMCHR(USER)
	 JRST	 ISROOM
NOROOM:	PUSHJ	P,WASTE			;Count waste in space being left
	HRRZ	C,.NEXT(C)		;Since we are moving strings "down",
	JUMPE	C,[ERR <DRYROT -- No more room for strings -- very strange>]
	PUSHJ	P,DSTSET		; space is a fatal error.
	JRST	DEST1			;Try again, C, REMCHR, TOPBYTE are adjusted.
ISROOM:	MOVE	FF,TOPBYTE(USER)
	CAME	A,FF			;Avoid moving the nest to its previous
	 JRST	 MVTST			; location (expensive NO-OP).
	 JRST	 MVDON
MVLP:	ILDB	TEMP,A
	IDPB	TEMP,FF
MVTST:	SOJGE	D,MVLP
	MOVE	FF,TOPBYTE(USER)	;FF←BP of first char
MVDON:	MOVSI	A,40			; in destination nest
	MOVE	D,E			;First, adjust TOPBYTE, then
	MOVEI	E,TOPBYTE-1(USER)	; the strings of the nest
	LDB	TEMP,[POINT 3,FF,5]
	TRC	TEMP,4
	JRST	FIXTOP		;Start in middle to get topbyte
FIXLP:	HLRZ	D,(E)
	HLLM	A,(E)		;Update string number
	MOVE	Q1,1(E)		;Compute new BP -- see SUBSTR in STRSER
FIXTOP:	MOVE	T,FF
	ADD	Q1,TEMP
	CAILE	Q1,4
	 JRST	 [CAILE Q1,9
		  JRST	    [IDIVI Q1,5
			     ADD   T,Q1
			     HLL   T,PTBL1(Q2)
			     JRST  PTWY]
		  SUBI  Q1,5
		  AOJA  T,.+1]
	HLL	T,PTBL1(Q1)
PTWY:
	MOVEM	T,1(E)		;Store new BP, to descriptor or topbyte
	MOVE	E,D		;loop
	 JUMPN	 E,FIXLP
	POPJ	P,
DSTSET:	HRLI	C,(<POINT 7,0>)
	MOVEM	C,TOPBYTE(USER)
	MOVN	TEMP,.SIZE(C)
	IMULI	TEMP,5
	MOVEM	TEMP,REMCHR(USER)
	POPJ	P,
WASTE:	PUSH	P,TEMP+1
	MOVN	TEMP,REMCHR(USER)	;Unused characters this space
	IDIVI	TEMP,5			;Just rough estimate.
	POP	P,TEMP+1
	ADDM	TEMP,SGCWASTE(USER)
	POPJ	P,
HEREFK(SGINS,.SGINS)
	PUSH	P,-2(P)		;ADDR OF ROUTINE
	PUSHJ	P,SGREM		;NEVER LET IT BE IN TWICE
	MOVE	USER,GOGTAB
	POP	P,UUO1(USER)
	POP	P,LPSA;<	;=>LINK BLOCK FOR NEW ROUTINE
	POP	P,-1(LPSA)	;PUT ROUTINE ADDRESS AWAY
	HRL	LPSA,SGROUT(USER);GET OLD LINK POINTER
	HLRM	LPSA,(LPSA)	;PUT IN NEW LINK POSITION
	HRRM	LPSA,SGROUT(USER);PUT NEW POINTER IN LINK HEAD
	JRST	@3(P)		;RETURN
HEREFK(SGREM,.SGREM)
	MOVE	USER,GOGTAB
	POP	P,UUO1(USER)
	POP	P,TEMP		;ADDR TO BE REMOVED
	MOVEI	LPSA,SGROUT(USER);HEAD OF LIST
SGRL:	MOVE	USER,LPSA	;PREV←THIS
	SKIPN	LPSA,(USER)	;THIS←(PREV)
	 JRST	 @2(P)		;DIDN'T FIND IT
	CAME	TEMP,-1(LPSA)	;IS THIS THE ROUTINE?
	 JRST	 SGRL		;NO, GET NEXT
	HRRZ	TEMP,(LPSA)	;YES, REMOVE IT FROM LIST
	HRRM	TEMP,(USER)
	JRST	@2(P)
HEREFK(STCLER,.STCLR)			;
	SKIPE	SGLIGN(USER)		;CLEAR REST?
	PUSHJ	P,RESCLR	;CLEAR REST OF STRING SPACE
	SKIPN	T,STRLNK(USER)	;PARALLELS STRNGC'S LOOP
	POPJ	P,		;CLOSELY
	PUSH	P,B		;JUST IN CASE
	HRLZI	B,-1		;FOR TESTING STRING NO.
STC1:	HRRZ	A,-1(T)
	HLRZ	Q2,-1(T)
STCLLP:	SOJL	Q2,STCLD1
	TDNE	B,(A)		;DON'T COLLECT STRING CONSTANTS
	SETZM	(A)
	ADDI	A,2
	JRST	STCLLP
STCLD1:	HRRZ	T,(T)
	JUMPN	T,STC1
	POP	P,B
	POPJ	P,
RESCLR:	SKIPL	A,TOPBYTE(USER)	;CAN ZERO FIRST WORD IF 440700
	ADDI	A,1		;ELSE START AT NEXT
	SETZM	(A)
	HRLS	A
	ADDI	A,1		;BLT WORD
	MOVE	B,STTOP(USER)	;END OF STRING SPACE
	BLT	A,-1(B)		;ZERO!!
	POPJ	P,
INTERNAL BRKMSK
↑BRKMSK:	0
	FOR @& JJ←=17,0,-1 <
	<1 ⊗ (JJ+=18)> + (1 ⊗ JJ)>
>;NOLOW
ENDCOM (SGC)